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);
134 if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) {
137 RX_SEEN_EVALS((REGEXP *)MUTABLE_PTR(msv));
140 sv_catsv_nomg(tmpstr, msv);
147 tryAMAGICregexp(tmpstr);
150 #undef tryAMAGICregexp
153 SV * const sv = SvRV(tmpstr);
154 if (SvTYPE(sv) == SVt_REGEXP)
157 else if (SvTYPE(tmpstr) == SVt_REGEXP)
158 re = (REGEXP*) tmpstr;
161 /* The match's LHS's get-magic might need to access this op's reg-
162 exp (as is sometimes the case with $'; see bug 70764). So we
163 must call get-magic now before we replace the regexp. Hopeful-
164 ly this hack can be replaced with the approach described at
165 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
166 /msg122415.html some day. */
167 if(pm->op_type == OP_MATCH) {
169 const bool was_tainted = PL_tainted;
170 if (pm->op_flags & OPf_STACKED)
172 else if (pm->op_private & OPpTARGET_MY)
173 lhs = PAD_SV(pm->op_targ);
176 /* Restore the previous value of PL_tainted (which may have been
177 modified by get-magic), to avoid incorrectly setting the
178 RXf_TAINTED flag further down. */
179 PL_tainted = was_tainted;
182 re = reg_temp_copy(NULL, re);
183 ReREFCNT_dec(PM_GETRE(pm));
188 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
191 assert (re != (REGEXP*) &PL_sv_undef);
193 /* Check against the last compiled regexp. */
194 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
195 memNE(RX_PRECOMP(re), t, len))
197 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
198 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
202 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
204 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
206 } else if (PL_curcop->cop_hints_hash) {
207 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
208 if (ptr && SvIOK(ptr) && SvIV(ptr))
209 eng = INT2PTR(regexp_engine*,SvIV(ptr));
212 if (PL_op->op_flags & OPf_SPECIAL)
213 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
215 if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
216 /* Not doing UTF-8, despite what the SV says. Is this only if
217 we're trapped in use 'bytes'? */
218 /* Make a copy of the octet sequence, but without the flag on,
219 as the compiler now honours the SvUTF8 flag on tmpstr. */
221 const char *const p = SvPV(tmpstr, len);
222 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
224 else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
225 /* make a copy to avoid extra stringifies */
226 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
230 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
232 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
234 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
235 inside tie/overload accessors. */
241 #ifndef INCOMPLETE_TAINTS
244 SvTAINTED_on((SV*)re);
245 RX_EXTFLAGS(re) |= RXf_TAINTED;
250 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
254 #if !defined(USE_ITHREADS)
255 /* can't change the optree at runtime either */
256 /* PMf_KEEP is handled differently under threads to avoid these problems */
257 if (pm->op_pmflags & PMf_KEEP) {
258 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
259 cLOGOP->op_first->op_next = PL_op->op_next;
269 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
270 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
271 register SV * const dstr = cx->sb_dstr;
272 register char *s = cx->sb_s;
273 register char *m = cx->sb_m;
274 char *orig = cx->sb_orig;
275 register REGEXP * const rx = cx->sb_rx;
277 REGEXP *old = PM_GETRE(pm);
284 PM_SETRE(pm,ReREFCNT_inc(rx));
287 rxres_restore(&cx->sb_rxres, rx);
288 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
290 if (cx->sb_iters++) {
291 const I32 saviters = cx->sb_iters;
292 if (cx->sb_iters > cx->sb_maxiters)
293 DIE(aTHX_ "Substitution loop");
295 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
297 /* See "how taint works" above pp_subst() */
299 cx->sb_rxtainted |= SUBST_TAINT_REPL;
300 sv_catsv_nomg(dstr, POPs);
301 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
305 /* I believe that we can't set REXEC_SCREAM here if
306 SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
307 equal to s. [See the comment before Perl_re_intuit_start(), which is
308 called from Perl_regexec_flags(), which says that it should be when
309 SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
310 with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
312 if (CxONCE(cx) || s < orig ||
313 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
314 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
315 ((cx->sb_rflags & REXEC_COPY_STR)
316 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
317 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
319 SV *targ = cx->sb_targ;
321 assert(cx->sb_strend >= s);
322 if(cx->sb_strend > s) {
323 if (DO_UTF8(dstr) && !SvUTF8(targ))
324 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
326 sv_catpvn(dstr, s, cx->sb_strend - s);
328 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
329 cx->sb_rxtainted |= SUBST_TAINT_PAT;
331 if (pm->op_pmflags & PMf_NONDESTRUCT) {
333 /* From here on down we're using the copy, and leaving the
334 original untouched. */
339 sv_force_normal_flags(targ, SV_COW_DROP_PV);
344 SvPV_set(targ, SvPVX(dstr));
345 SvCUR_set(targ, SvCUR(dstr));
346 SvLEN_set(targ, SvLEN(dstr));
349 SvPV_set(dstr, NULL);
351 mPUSHi(saviters - 1);
353 (void)SvPOK_only_UTF8(targ);
356 /* update the taint state of various various variables in
357 * preparation for final exit.
358 * See "how taint works" above pp_subst() */
360 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
361 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
362 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
364 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
366 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
367 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
369 SvTAINTED_on(TOPs); /* taint return value */
370 /* needed for mg_set below */
371 PL_tainted = cBOOL(cx->sb_rxtainted &
372 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
375 /* PL_tainted must be correctly set for this mg_set */
378 LEAVE_SCOPE(cx->sb_oldsave);
380 RETURNOP(pm->op_next);
383 cx->sb_iters = saviters;
385 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
388 cx->sb_orig = orig = RX_SUBBEG(rx);
390 cx->sb_strend = s + (cx->sb_strend - m);
392 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
394 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
395 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
397 sv_catpvn(dstr, s, m-s);
399 cx->sb_s = RX_OFFS(rx)[0].end + orig;
400 { /* Update the pos() information. */
402 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
404 SvUPGRADE(sv, SVt_PVMG);
405 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
406 #ifdef PERL_OLD_COPY_ON_WRITE
408 sv_force_normal_flags(sv, 0);
410 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
413 mg->mg_len = m - orig;
416 (void)ReREFCNT_inc(rx);
417 /* update the taint state of various various variables in preparation
418 * for calling the code block.
419 * See "how taint works" above pp_subst() */
421 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
422 cx->sb_rxtainted |= SUBST_TAINT_PAT;
424 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
425 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
426 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
428 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
430 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
431 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
432 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
433 ? cx->sb_dstr : cx->sb_targ);
436 rxres_save(&cx->sb_rxres, rx);
438 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
442 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
447 PERL_ARGS_ASSERT_RXRES_SAVE;
450 if (!p || p[1] < RX_NPARENS(rx)) {
451 #ifdef PERL_OLD_COPY_ON_WRITE
452 i = 7 + RX_NPARENS(rx) * 2;
454 i = 6 + RX_NPARENS(rx) * 2;
463 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
464 RX_MATCH_COPIED_off(rx);
466 #ifdef PERL_OLD_COPY_ON_WRITE
467 *p++ = PTR2UV(RX_SAVED_COPY(rx));
468 RX_SAVED_COPY(rx) = NULL;
471 *p++ = RX_NPARENS(rx);
473 *p++ = PTR2UV(RX_SUBBEG(rx));
474 *p++ = (UV)RX_SUBLEN(rx);
475 for (i = 0; i <= RX_NPARENS(rx); ++i) {
476 *p++ = (UV)RX_OFFS(rx)[i].start;
477 *p++ = (UV)RX_OFFS(rx)[i].end;
482 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
487 PERL_ARGS_ASSERT_RXRES_RESTORE;
490 RX_MATCH_COPY_FREE(rx);
491 RX_MATCH_COPIED_set(rx, *p);
494 #ifdef PERL_OLD_COPY_ON_WRITE
495 if (RX_SAVED_COPY(rx))
496 SvREFCNT_dec (RX_SAVED_COPY(rx));
497 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
501 RX_NPARENS(rx) = *p++;
503 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
504 RX_SUBLEN(rx) = (I32)(*p++);
505 for (i = 0; i <= RX_NPARENS(rx); ++i) {
506 RX_OFFS(rx)[i].start = (I32)(*p++);
507 RX_OFFS(rx)[i].end = (I32)(*p++);
512 S_rxres_free(pTHX_ void **rsp)
514 UV * const p = (UV*)*rsp;
516 PERL_ARGS_ASSERT_RXRES_FREE;
521 void *tmp = INT2PTR(char*,*p);
524 PoisonFree(*p, 1, sizeof(*p));
526 Safefree(INT2PTR(char*,*p));
528 #ifdef PERL_OLD_COPY_ON_WRITE
530 SvREFCNT_dec (INT2PTR(SV*,p[1]));
538 #define FORM_NUM_BLANK (1<<30)
539 #define FORM_NUM_POINT (1<<29)
543 dVAR; dSP; dMARK; dORIGMARK;
544 register SV * const tmpForm = *++MARK;
545 SV *formsv; /* contains text of original format */
546 register U32 *fpc; /* format ops program counter */
547 register char *t; /* current append position in target string */
548 const char *f; /* current position in format string */
550 register SV *sv = NULL; /* current item */
551 const char *item = NULL;/* string value of current item */
552 I32 itemsize = 0; /* length of current item, possibly truncated */
553 I32 fieldsize = 0; /* width of current field */
554 I32 lines = 0; /* number of lines that have been output */
555 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
556 const char *chophere = NULL; /* where to chop current item */
557 STRLEN linemark = 0; /* pos of start of line in output */
559 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
561 STRLEN linemax; /* estimate of output size in bytes */
562 bool item_is_utf8 = FALSE;
563 bool targ_is_utf8 = FALSE;
566 U8 *source; /* source of bytes to append */
567 STRLEN to_copy; /* how may bytes to append */
568 char trans; /* what chars to translate */
570 mg = doparseform(tmpForm);
572 fpc = (U32*)mg->mg_ptr;
573 /* the actual string the format was compiled from.
574 * with overload etc, this may not match tmpForm */
578 SvPV_force(PL_formtarget, len);
579 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
580 SvTAINTED_on(PL_formtarget);
581 if (DO_UTF8(PL_formtarget))
583 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
584 t = SvGROW(PL_formtarget, len + linemax + 1);
585 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
587 f = SvPV_const(formsv, len);
591 const char *name = "???";
594 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
595 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
596 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
597 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
598 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
600 case FF_CHECKNL: name = "CHECKNL"; break;
601 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
602 case FF_SPACE: name = "SPACE"; break;
603 case FF_HALFSPACE: name = "HALFSPACE"; break;
604 case FF_ITEM: name = "ITEM"; break;
605 case FF_CHOP: name = "CHOP"; break;
606 case FF_LINEGLOB: name = "LINEGLOB"; break;
607 case FF_NEWLINE: name = "NEWLINE"; break;
608 case FF_MORE: name = "MORE"; break;
609 case FF_LINEMARK: name = "LINEMARK"; break;
610 case FF_END: name = "END"; break;
611 case FF_0DECIMAL: name = "0DECIMAL"; break;
612 case FF_LINESNGL: name = "LINESNGL"; break;
615 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
617 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
621 linemark = t - SvPVX(PL_formtarget);
631 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
647 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
650 SvTAINTED_on(PL_formtarget);
656 const char *s = item = SvPV_const(sv, len);
659 itemsize = sv_len_utf8(sv);
660 if (itemsize != (I32)len) {
662 if (itemsize > fieldsize) {
663 itemsize = fieldsize;
664 itembytes = itemsize;
665 sv_pos_u2b(sv, &itembytes, 0);
669 send = chophere = s + itembytes;
679 sv_pos_b2u(sv, &itemsize);
683 item_is_utf8 = FALSE;
684 if (itemsize > fieldsize)
685 itemsize = fieldsize;
686 send = chophere = s + itemsize;
700 const char *s = item = SvPV_const(sv, len);
703 itemsize = sv_len_utf8(sv);
704 if (itemsize != (I32)len) {
706 if (itemsize <= fieldsize) {
707 const char *send = chophere = s + itemsize;
720 itemsize = fieldsize;
721 itembytes = itemsize;
722 sv_pos_u2b(sv, &itembytes, 0);
723 send = chophere = s + itembytes;
724 while (s < send || (s == send && isSPACE(*s))) {
734 if (strchr(PL_chopset, *s))
739 itemsize = chophere - item;
740 sv_pos_b2u(sv, &itemsize);
746 item_is_utf8 = FALSE;
747 if (itemsize <= fieldsize) {
748 const char *const send = chophere = s + itemsize;
761 itemsize = fieldsize;
762 send = chophere = s + itemsize;
763 while (s < send || (s == send && isSPACE(*s))) {
773 if (strchr(PL_chopset, *s))
778 itemsize = chophere - item;
784 arg = fieldsize - itemsize;
793 arg = fieldsize - itemsize;
807 /* convert to_copy from chars to bytes */
811 to_copy = s - source;
817 const char *s = chophere;
831 const bool oneline = fpc[-1] == FF_LINESNGL;
832 const char *s = item = SvPV_const(sv, len);
833 const char *const send = s + len;
835 item_is_utf8 = DO_UTF8(sv);
846 to_copy = s - SvPVX_const(sv) - 1;
860 /* append to_copy bytes from source to PL_formstring.
861 * item_is_utf8 implies source is utf8.
862 * if trans, translate certain characters during the copy */
867 SvCUR_set(PL_formtarget,
868 t - SvPVX_const(PL_formtarget));
870 if (targ_is_utf8 && !item_is_utf8) {
871 source = tmp = bytes_to_utf8(source, &to_copy);
873 if (item_is_utf8 && !targ_is_utf8) {
875 /* Upgrade targ to UTF8, and then we reduce it to
876 a problem we have a simple solution for.
877 Don't need get magic. */
878 sv_utf8_upgrade_nomg(PL_formtarget);
880 /* re-calculate linemark */
881 s = (U8*)SvPVX(PL_formtarget);
882 /* the bytes we initially allocated to append the
883 * whole line may have been gobbled up during the
884 * upgrade, so allocate a whole new line's worth
889 linemark = s - (U8*)SvPVX(PL_formtarget);
891 /* Easy. They agree. */
892 assert (item_is_utf8 == targ_is_utf8);
895 /* @* and ^* are the only things that can exceed
896 * the linemax, so grow by the output size, plus
897 * a whole new form's worth in case of any further
899 grow = linemax + to_copy;
901 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
902 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
904 Copy(source, t, to_copy, char);
906 /* blank out ~ or control chars, depending on trans.
907 * works on bytes not chars, so relies on not
908 * matching utf8 continuation bytes */
910 U8 *send = s + to_copy;
913 if (trans == '~' ? (ch == '~') :
926 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
934 #if defined(USE_LONG_DOUBLE)
936 ((arg & FORM_NUM_POINT) ?
937 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
940 ((arg & FORM_NUM_POINT) ?
941 "%#0*.*f" : "%0*.*f");
946 #if defined(USE_LONG_DOUBLE)
948 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
951 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
954 /* If the field is marked with ^ and the value is undefined,
956 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
964 /* overflow evidence */
965 if (num_overflow(value, fieldsize, arg)) {
971 /* Formats aren't yet marked for locales, so assume "yes". */
973 STORE_NUMERIC_STANDARD_SET_LOCAL();
974 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
975 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
976 RESTORE_NUMERIC_STANDARD();
983 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
991 if (arg) { /* repeat until fields exhausted? */
997 t = SvPVX(PL_formtarget) + linemark;
1004 const char *s = chophere;
1005 const char *send = item + len;
1007 while (isSPACE(*s) && (s < send))
1012 arg = fieldsize - itemsize;
1019 if (strnEQ(s1," ",3)) {
1020 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1031 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
1033 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1035 SvUTF8_on(PL_formtarget);
1036 FmLINES(PL_formtarget) += lines;
1038 if (fpc[-1] == FF_BLANK)
1039 RETURNOP(cLISTOP->op_first);
1051 if (PL_stack_base + *PL_markstack_ptr == SP) {
1053 if (GIMME_V == G_SCALAR)
1055 RETURNOP(PL_op->op_next->op_next);
1057 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1058 Perl_pp_pushmark(aTHX); /* push dst */
1059 Perl_pp_pushmark(aTHX); /* push src */
1060 ENTER_with_name("grep"); /* enter outer scope */
1063 if (PL_op->op_private & OPpGREP_LEX)
1064 SAVESPTR(PAD_SVl(PL_op->op_targ));
1067 ENTER_with_name("grep_item"); /* enter inner scope */
1070 src = PL_stack_base[*PL_markstack_ptr];
1072 if (PL_op->op_private & OPpGREP_LEX)
1073 PAD_SVl(PL_op->op_targ) = src;
1078 if (PL_op->op_type == OP_MAPSTART)
1079 Perl_pp_pushmark(aTHX); /* push top */
1080 return ((LOGOP*)PL_op->op_next)->op_other;
1086 const I32 gimme = GIMME_V;
1087 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1093 /* first, move source pointer to the next item in the source list */
1094 ++PL_markstack_ptr[-1];
1096 /* if there are new items, push them into the destination list */
1097 if (items && gimme != G_VOID) {
1098 /* might need to make room back there first */
1099 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1100 /* XXX this implementation is very pessimal because the stack
1101 * is repeatedly extended for every set of items. Is possible
1102 * to do this without any stack extension or copying at all
1103 * by maintaining a separate list over which the map iterates
1104 * (like foreach does). --gsar */
1106 /* everything in the stack after the destination list moves
1107 * towards the end the stack by the amount of room needed */
1108 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1110 /* items to shift up (accounting for the moved source pointer) */
1111 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1113 /* This optimization is by Ben Tilly and it does
1114 * things differently from what Sarathy (gsar)
1115 * is describing. The downside of this optimization is
1116 * that leaves "holes" (uninitialized and hopefully unused areas)
1117 * to the Perl stack, but on the other hand this
1118 * shouldn't be a problem. If Sarathy's idea gets
1119 * implemented, this optimization should become
1120 * irrelevant. --jhi */
1122 shift = count; /* Avoid shifting too often --Ben Tilly */
1126 dst = (SP += shift);
1127 PL_markstack_ptr[-1] += shift;
1128 *PL_markstack_ptr += shift;
1132 /* copy the new items down to the destination list */
1133 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1134 if (gimme == G_ARRAY) {
1135 /* add returned items to the collection (making mortal copies
1136 * if necessary), then clear the current temps stack frame
1137 * *except* for those items. We do this splicing the items
1138 * into the start of the tmps frame (so some items may be on
1139 * the tmps stack twice), then moving PL_tmps_floor above
1140 * them, then freeing the frame. That way, the only tmps that
1141 * accumulate over iterations are the return values for map.
1142 * We have to do to this way so that everything gets correctly
1143 * freed if we die during the map.
1147 /* make space for the slice */
1148 EXTEND_MORTAL(items);
1149 tmpsbase = PL_tmps_floor + 1;
1150 Move(PL_tmps_stack + tmpsbase,
1151 PL_tmps_stack + tmpsbase + items,
1152 PL_tmps_ix - PL_tmps_floor,
1154 PL_tmps_ix += items;
1159 sv = sv_mortalcopy(sv);
1161 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1163 /* clear the stack frame except for the items */
1164 PL_tmps_floor += items;
1166 /* FREETMPS may have cleared the TEMP flag on some of the items */
1169 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1172 /* scalar context: we don't care about which values map returns
1173 * (we use undef here). And so we certainly don't want to do mortal
1174 * copies of meaningless values. */
1175 while (items-- > 0) {
1177 *dst-- = &PL_sv_undef;
1185 LEAVE_with_name("grep_item"); /* exit inner scope */
1188 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1190 (void)POPMARK; /* pop top */
1191 LEAVE_with_name("grep"); /* exit outer scope */
1192 (void)POPMARK; /* pop src */
1193 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1194 (void)POPMARK; /* pop dst */
1195 SP = PL_stack_base + POPMARK; /* pop original mark */
1196 if (gimme == G_SCALAR) {
1197 if (PL_op->op_private & OPpGREP_LEX) {
1198 SV* sv = sv_newmortal();
1199 sv_setiv(sv, items);
1207 else if (gimme == G_ARRAY)
1214 ENTER_with_name("grep_item"); /* enter inner scope */
1217 /* set $_ to the new source item */
1218 src = PL_stack_base[PL_markstack_ptr[-1]];
1220 if (PL_op->op_private & OPpGREP_LEX)
1221 PAD_SVl(PL_op->op_targ) = src;
1225 RETURNOP(cLOGOP->op_other);
1234 if (GIMME == G_ARRAY)
1236 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1237 return cLOGOP->op_other;
1247 if (GIMME == G_ARRAY) {
1248 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1252 SV * const targ = PAD_SV(PL_op->op_targ);
1255 if (PL_op->op_private & OPpFLIP_LINENUM) {
1256 if (GvIO(PL_last_in_gv)) {
1257 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1260 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1262 flip = SvIV(sv) == SvIV(GvSV(gv));
1268 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1269 if (PL_op->op_flags & OPf_SPECIAL) {
1277 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1280 sv_setpvs(TARG, "");
1286 /* This code tries to decide if "$left .. $right" should use the
1287 magical string increment, or if the range is numeric (we make
1288 an exception for .."0" [#18165]). AMS 20021031. */
1290 #define RANGE_IS_NUMERIC(left,right) ( \
1291 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1292 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1293 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1294 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1295 && (!SvOK(right) || looks_like_number(right))))
1301 if (GIMME == G_ARRAY) {
1307 if (RANGE_IS_NUMERIC(left,right)) {
1310 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1311 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1312 DIE(aTHX_ "Range iterator outside integer range");
1313 i = SvIV_nomg(left);
1314 max = SvIV_nomg(right);
1323 SV * const sv = sv_2mortal(newSViv(i++));
1329 const char * const lpv = SvPV_nomg_const(left, llen);
1330 const char * const tmps = SvPV_nomg_const(right, len);
1332 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1333 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1335 if (strEQ(SvPVX_const(sv),tmps))
1337 sv = sv_2mortal(newSVsv(sv));
1344 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1348 if (PL_op->op_private & OPpFLIP_LINENUM) {
1349 if (GvIO(PL_last_in_gv)) {
1350 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1353 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1354 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1362 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1363 sv_catpvs(targ, "E0");
1373 static const char * const context_name[] = {
1375 NULL, /* CXt_WHEN never actually needs "block" */
1376 NULL, /* CXt_BLOCK never actually needs "block" */
1377 NULL, /* CXt_GIVEN never actually needs "block" */
1378 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1379 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1380 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1381 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1389 S_dopoptolabel(pTHX_ const char *label)
1394 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1396 for (i = cxstack_ix; i >= 0; i--) {
1397 register const PERL_CONTEXT * const cx = &cxstack[i];
1398 switch (CxTYPE(cx)) {
1404 /* diag_listed_as: Exiting subroutine via %s */
1405 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1406 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1407 if (CxTYPE(cx) == CXt_NULL)
1410 case CXt_LOOP_LAZYIV:
1411 case CXt_LOOP_LAZYSV:
1413 case CXt_LOOP_PLAIN:
1415 const char *cx_label = CxLABEL(cx);
1416 if (!cx_label || strNE(label, cx_label) ) {
1417 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1418 (long)i, cx_label));
1421 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1432 Perl_dowantarray(pTHX)
1435 const I32 gimme = block_gimme();
1436 return (gimme == G_VOID) ? G_SCALAR : gimme;
1440 Perl_block_gimme(pTHX)
1443 const I32 cxix = dopoptosub(cxstack_ix);
1447 switch (cxstack[cxix].blk_gimme) {
1455 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1462 Perl_is_lvalue_sub(pTHX)
1465 const I32 cxix = dopoptosub(cxstack_ix);
1466 assert(cxix >= 0); /* We should only be called from inside subs */
1468 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1469 return CxLVAL(cxstack + cxix);
1474 /* only used by PUSHSUB */
1476 Perl_was_lvalue_sub(pTHX)
1479 const I32 cxix = dopoptosub(cxstack_ix-1);
1480 assert(cxix >= 0); /* We should only be called from inside subs */
1482 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1483 return CxLVAL(cxstack + cxix);
1489 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1494 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1496 for (i = startingblock; i >= 0; i--) {
1497 register const PERL_CONTEXT * const cx = &cxstk[i];
1498 switch (CxTYPE(cx)) {
1504 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1512 S_dopoptoeval(pTHX_ I32 startingblock)
1516 for (i = startingblock; i >= 0; i--) {
1517 register const PERL_CONTEXT *cx = &cxstack[i];
1518 switch (CxTYPE(cx)) {
1522 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1530 S_dopoptoloop(pTHX_ I32 startingblock)
1534 for (i = startingblock; i >= 0; i--) {
1535 register const PERL_CONTEXT * const cx = &cxstack[i];
1536 switch (CxTYPE(cx)) {
1542 /* diag_listed_as: Exiting subroutine via %s */
1543 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1544 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1545 if ((CxTYPE(cx)) == CXt_NULL)
1548 case CXt_LOOP_LAZYIV:
1549 case CXt_LOOP_LAZYSV:
1551 case CXt_LOOP_PLAIN:
1552 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1560 S_dopoptogiven(pTHX_ I32 startingblock)
1564 for (i = startingblock; i >= 0; i--) {
1565 register const PERL_CONTEXT *cx = &cxstack[i];
1566 switch (CxTYPE(cx)) {
1570 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1572 case CXt_LOOP_PLAIN:
1573 assert(!CxFOREACHDEF(cx));
1575 case CXt_LOOP_LAZYIV:
1576 case CXt_LOOP_LAZYSV:
1578 if (CxFOREACHDEF(cx)) {
1579 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1588 S_dopoptowhen(pTHX_ I32 startingblock)
1592 for (i = startingblock; i >= 0; i--) {
1593 register const PERL_CONTEXT *cx = &cxstack[i];
1594 switch (CxTYPE(cx)) {
1598 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1606 Perl_dounwind(pTHX_ I32 cxix)
1611 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1614 while (cxstack_ix > cxix) {
1616 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1617 DEBUG_CX("UNWIND"); \
1618 /* Note: we don't need to restore the base context info till the end. */
1619 switch (CxTYPE(cx)) {
1622 continue; /* not break */
1630 case CXt_LOOP_LAZYIV:
1631 case CXt_LOOP_LAZYSV:
1633 case CXt_LOOP_PLAIN:
1644 PERL_UNUSED_VAR(optype);
1648 Perl_qerror(pTHX_ SV *err)
1652 PERL_ARGS_ASSERT_QERROR;
1655 if (PL_in_eval & EVAL_KEEPERR) {
1656 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1660 sv_catsv(ERRSV, err);
1663 sv_catsv(PL_errors, err);
1665 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1667 ++PL_parser->error_count;
1671 Perl_die_unwind(pTHX_ SV *msv)
1674 SV *exceptsv = sv_mortalcopy(msv);
1675 U8 in_eval = PL_in_eval;
1676 PERL_ARGS_ASSERT_DIE_UNWIND;
1683 * Historically, perl used to set ERRSV ($@) early in the die
1684 * process and rely on it not getting clobbered during unwinding.
1685 * That sucked, because it was liable to get clobbered, so the
1686 * setting of ERRSV used to emit the exception from eval{} has
1687 * been moved to much later, after unwinding (see just before
1688 * JMPENV_JUMP below). However, some modules were relying on the
1689 * early setting, by examining $@ during unwinding to use it as
1690 * a flag indicating whether the current unwinding was caused by
1691 * an exception. It was never a reliable flag for that purpose,
1692 * being totally open to false positives even without actual
1693 * clobberage, but was useful enough for production code to
1694 * semantically rely on it.
1696 * We'd like to have a proper introspective interface that
1697 * explicitly describes the reason for whatever unwinding
1698 * operations are currently in progress, so that those modules
1699 * work reliably and $@ isn't further overloaded. But we don't
1700 * have one yet. In its absence, as a stopgap measure, ERRSV is
1701 * now *additionally* set here, before unwinding, to serve as the
1702 * (unreliable) flag that it used to.
1704 * This behaviour is temporary, and should be removed when a
1705 * proper way to detect exceptional unwinding has been developed.
1706 * As of 2010-12, the authors of modules relying on the hack
1707 * are aware of the issue, because the modules failed on
1708 * perls 5.13.{1..7} which had late setting of $@ without this
1709 * early-setting hack.
1711 if (!(in_eval & EVAL_KEEPERR)) {
1712 SvTEMP_off(exceptsv);
1713 sv_setsv(ERRSV, exceptsv);
1716 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1717 && PL_curstackinfo->si_prev)
1726 register PERL_CONTEXT *cx;
1729 JMPENV *restartjmpenv;
1732 if (cxix < cxstack_ix)
1735 POPBLOCK(cx,PL_curpm);
1736 if (CxTYPE(cx) != CXt_EVAL) {
1738 const char* message = SvPVx_const(exceptsv, msglen);
1739 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1740 PerlIO_write(Perl_error_log, message, msglen);
1744 namesv = cx->blk_eval.old_namesv;
1745 oldcop = cx->blk_oldcop;
1746 restartjmpenv = cx->blk_eval.cur_top_env;
1747 restartop = cx->blk_eval.retop;
1749 if (gimme == G_SCALAR)
1750 *++newsp = &PL_sv_undef;
1751 PL_stack_sp = newsp;
1755 /* LEAVE could clobber PL_curcop (see save_re_context())
1756 * XXX it might be better to find a way to avoid messing with
1757 * PL_curcop in save_re_context() instead, but this is a more
1758 * minimal fix --GSAR */
1761 if (optype == OP_REQUIRE) {
1762 (void)hv_store(GvHVn(PL_incgv),
1763 SvPVX_const(namesv),
1764 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1766 /* note that unlike pp_entereval, pp_require isn't
1767 * supposed to trap errors. So now that we've popped the
1768 * EVAL that pp_require pushed, and processed the error
1769 * message, rethrow the error */
1770 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1771 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1774 if (in_eval & EVAL_KEEPERR) {
1775 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1779 sv_setsv(ERRSV, exceptsv);
1781 PL_restartjmpenv = restartjmpenv;
1782 PL_restartop = restartop;
1788 write_to_stderr(exceptsv);
1795 dVAR; dSP; dPOPTOPssrl;
1796 if (SvTRUE(left) != SvTRUE(right))
1803 =for apidoc caller_cx
1805 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1806 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1807 information returned to Perl by C<caller>. Note that XSUBs don't get a
1808 stack frame, so C<caller_cx(0, NULL)> will return information for the
1809 immediately-surrounding Perl code.
1811 This function skips over the automatic calls to C<&DB::sub> made on the
1812 behalf of the debugger. If the stack frame requested was a sub called by
1813 C<DB::sub>, the return value will be the frame for the call to
1814 C<DB::sub>, since that has the correct line number/etc. for the call
1815 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1816 frame for the sub call itself.
1821 const PERL_CONTEXT *
1822 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1824 register I32 cxix = dopoptosub(cxstack_ix);
1825 register const PERL_CONTEXT *cx;
1826 register const PERL_CONTEXT *ccstack = cxstack;
1827 const PERL_SI *top_si = PL_curstackinfo;
1830 /* we may be in a higher stacklevel, so dig down deeper */
1831 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1832 top_si = top_si->si_prev;
1833 ccstack = top_si->si_cxstack;
1834 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1838 /* caller() should not report the automatic calls to &DB::sub */
1839 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1840 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1844 cxix = dopoptosub_at(ccstack, cxix - 1);
1847 cx = &ccstack[cxix];
1848 if (dbcxp) *dbcxp = cx;
1850 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1851 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1852 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1853 field below is defined for any cx. */
1854 /* caller() should not report the automatic calls to &DB::sub */
1855 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1856 cx = &ccstack[dbcxix];
1866 register const PERL_CONTEXT *cx;
1867 const PERL_CONTEXT *dbcx;
1869 const HEK *stash_hek;
1871 bool has_arg = MAXARG && TOPs;
1879 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1881 if (GIMME != G_ARRAY) {
1888 stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
1889 if (GIMME != G_ARRAY) {
1892 PUSHs(&PL_sv_undef);
1895 sv_sethek(TARG, stash_hek);
1904 PUSHs(&PL_sv_undef);
1907 sv_sethek(TARG, stash_hek);
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 =
2011 (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
2012 sv_reset(tmps, CopSTASH(PL_curcop));
2017 /* like pp_nextstate, but used instead when the debugger is active */
2022 PL_curcop = (COP*)PL_op;
2023 TAINT_NOT; /* Each statement is presumed innocent */
2024 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2029 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2030 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2033 register PERL_CONTEXT *cx;
2034 const I32 gimme = G_ARRAY;
2036 GV * const gv = PL_DBgv;
2037 register CV * const cv = GvCV(gv);
2040 DIE(aTHX_ "No DB::DB routine defined");
2042 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2043 /* don't do recursive DB::DB call */
2058 (void)(*CvXSUB(cv))(aTHX_ cv);
2065 PUSHBLOCK(cx, CXt_SUB, SP);
2067 cx->blk_sub.retop = PL_op->op_next;
2070 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2071 RETURNOP(CvSTART(cv));
2079 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2082 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2084 if (flags & SVs_PADTMP) {
2085 flags &= ~SVs_PADTMP;
2088 if (gimme == G_SCALAR) {
2090 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2091 ? *SP : sv_mortalcopy(*SP);
2093 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2096 *++MARK = &PL_sv_undef;
2100 else if (gimme == G_ARRAY) {
2101 /* in case LEAVE wipes old return values */
2102 while (++MARK <= SP) {
2103 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2106 *++newsp = sv_mortalcopy(*MARK);
2107 TAINT_NOT; /* Each item is independent */
2110 /* When this function was called with MARK == newsp, we reach this
2111 * point with SP == newsp. */
2120 register PERL_CONTEXT *cx;
2121 I32 gimme = GIMME_V;
2123 ENTER_with_name("block");
2126 PUSHBLOCK(cx, CXt_BLOCK, SP);
2134 register PERL_CONTEXT *cx;
2139 if (PL_op->op_flags & OPf_SPECIAL) {
2140 cx = &cxstack[cxstack_ix];
2141 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2146 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2149 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2150 PL_curpm = newpm; /* Don't pop $1 et al till now */
2152 LEAVE_with_name("block");
2160 register PERL_CONTEXT *cx;
2161 const I32 gimme = GIMME_V;
2162 void *itervar; /* location of the iteration variable */
2163 U8 cxtype = CXt_LOOP_FOR;
2165 ENTER_with_name("loop1");
2168 if (PL_op->op_targ) { /* "my" variable */
2169 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2170 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2171 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2172 SVs_PADSTALE, SVs_PADSTALE);
2174 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2176 itervar = PL_comppad;
2178 itervar = &PAD_SVl(PL_op->op_targ);
2181 else { /* symbol table variable */
2182 GV * const gv = MUTABLE_GV(POPs);
2183 SV** svp = &GvSV(gv);
2184 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2186 itervar = (void *)gv;
2189 if (PL_op->op_private & OPpITER_DEF)
2190 cxtype |= CXp_FOR_DEF;
2192 ENTER_with_name("loop2");
2194 PUSHBLOCK(cx, cxtype, SP);
2195 PUSHLOOP_FOR(cx, itervar, MARK);
2196 if (PL_op->op_flags & OPf_STACKED) {
2197 SV *maybe_ary = POPs;
2198 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2200 SV * const right = maybe_ary;
2203 if (RANGE_IS_NUMERIC(sv,right)) {
2204 cx->cx_type &= ~CXTYPEMASK;
2205 cx->cx_type |= CXt_LOOP_LAZYIV;
2206 /* Make sure that no-one re-orders cop.h and breaks our
2208 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2209 #ifdef NV_PRESERVES_UV
2210 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2211 (SvNV_nomg(sv) > (NV)IV_MAX)))
2213 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2214 (SvNV_nomg(right) < (NV)IV_MIN))))
2216 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2218 ((SvNV_nomg(sv) > 0) &&
2219 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2220 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2222 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2224 ((SvNV_nomg(right) > 0) &&
2225 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2226 (SvNV_nomg(right) > (NV)UV_MAX))
2229 DIE(aTHX_ "Range iterator outside integer range");
2230 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2231 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2233 /* for correct -Dstv display */
2234 cx->blk_oldsp = sp - PL_stack_base;
2238 cx->cx_type &= ~CXTYPEMASK;
2239 cx->cx_type |= CXt_LOOP_LAZYSV;
2240 /* Make sure that no-one re-orders cop.h and breaks our
2242 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2243 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2244 cx->blk_loop.state_u.lazysv.end = right;
2245 SvREFCNT_inc(right);
2246 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2247 /* This will do the upgrade to SVt_PV, and warn if the value
2248 is uninitialised. */
2249 (void) SvPV_nolen_const(right);
2250 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2251 to replace !SvOK() with a pointer to "". */
2253 SvREFCNT_dec(right);
2254 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2258 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2259 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2260 SvREFCNT_inc(maybe_ary);
2261 cx->blk_loop.state_u.ary.ix =
2262 (PL_op->op_private & OPpITER_REVERSED) ?
2263 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2267 else { /* iterating over items on the stack */
2268 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2269 if (PL_op->op_private & OPpITER_REVERSED) {
2270 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2273 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2283 register PERL_CONTEXT *cx;
2284 const I32 gimme = GIMME_V;
2286 ENTER_with_name("loop1");
2288 ENTER_with_name("loop2");
2290 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2291 PUSHLOOP_PLAIN(cx, SP);
2299 register PERL_CONTEXT *cx;
2306 assert(CxTYPE_is_LOOP(cx));
2308 newsp = PL_stack_base + cx->blk_loop.resetsp;
2311 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2314 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2315 PL_curpm = newpm; /* ... and pop $1 et al */
2317 LEAVE_with_name("loop2");
2318 LEAVE_with_name("loop1");
2324 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2325 PERL_CONTEXT *cx, PMOP *newpm)
2327 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2328 if (gimme == G_SCALAR) {
2329 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2331 const char *what = NULL;
2333 assert(MARK+1 == SP);
2334 if ((SvPADTMP(TOPs) ||
2335 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2338 !SvSMAGICAL(TOPs)) {
2340 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2341 : "a readonly value" : "a temporary";
2346 /* sub:lvalue{} will take us here. */
2355 "Can't return %s from lvalue subroutine", what
2360 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2361 *++newsp = SvREFCNT_inc(*SP);
2368 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2373 *++newsp = &PL_sv_undef;
2375 if (CxLVAL(cx) & OPpDEREF) {
2378 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2382 else if (gimme == G_ARRAY) {
2383 assert (!(CxLVAL(cx) & OPpDEREF));
2384 if (ref || !CxLVAL(cx))
2385 while (++MARK <= SP)
2389 : ref && SvFLAGS(*MARK) & SVs_PADTMP
2390 ? sv_mortalcopy(*MARK)
2391 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2392 else while (++MARK <= SP) {
2393 if (*MARK != &PL_sv_undef
2395 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2400 /* Might be flattened array after $#array = */
2407 /* diag_listed_as: Can't return %s from lvalue subroutine */
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),
2487 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2489 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2494 retop = cx->blk_sub.retop;
2497 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2501 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2503 if (gimme == G_SCALAR) {
2506 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2507 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2508 && !SvMAGICAL(TOPs)) {
2509 *++newsp = SvREFCNT_inc(*SP);
2514 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2516 *++newsp = sv_mortalcopy(sv);
2520 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2521 && !SvMAGICAL(*SP)) {
2525 *++newsp = sv_mortalcopy(*SP);
2528 *++newsp = sv_mortalcopy(*SP);
2531 *++newsp = &PL_sv_undef;
2533 else if (gimme == G_ARRAY) {
2534 while (++MARK <= SP) {
2535 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2536 && !SvGMAGICAL(*MARK)
2537 ? *MARK : sv_mortalcopy(*MARK);
2538 TAINT_NOT; /* Each item is independent */
2541 PL_stack_sp = newsp;
2545 /* Stack values are safe: */
2548 POPSUB(cx,sv); /* release CV and @_ ... */
2552 PL_curpm = newpm; /* ... and pop $1 et al */
2561 /* This duplicates parts of pp_leavesub, so that it can share code with
2569 register PERL_CONTEXT *cx;
2572 if (CxMULTICALL(&cxstack[cxstack_ix]))
2576 cxstack_ix++; /* temporarily protect top context */
2580 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2584 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2585 PL_curpm = newpm; /* ... and pop $1 et al */
2588 return cx->blk_sub.retop;
2595 register PERL_CONTEXT *cx;
2606 if (PL_op->op_flags & OPf_SPECIAL) {
2607 cxix = dopoptoloop(cxstack_ix);
2609 DIE(aTHX_ "Can't \"last\" outside a loop block");
2612 cxix = dopoptolabel(cPVOP->op_pv);
2614 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2616 if (cxix < cxstack_ix)
2620 cxstack_ix++; /* temporarily protect top context */
2622 switch (CxTYPE(cx)) {
2623 case CXt_LOOP_LAZYIV:
2624 case CXt_LOOP_LAZYSV:
2626 case CXt_LOOP_PLAIN:
2628 newsp = PL_stack_base + cx->blk_loop.resetsp;
2629 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2633 nextop = cx->blk_sub.retop;
2637 nextop = cx->blk_eval.retop;
2641 nextop = cx->blk_sub.retop;
2644 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2648 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2649 pop2 == CXt_SUB ? SVs_TEMP : 0);
2654 /* Stack values are safe: */
2656 case CXt_LOOP_LAZYIV:
2657 case CXt_LOOP_PLAIN:
2658 case CXt_LOOP_LAZYSV:
2660 POPLOOP(cx); /* release loop vars ... */
2664 POPSUB(cx,sv); /* release CV and @_ ... */
2667 PL_curpm = newpm; /* ... and pop $1 et al */
2670 PERL_UNUSED_VAR(optype);
2671 PERL_UNUSED_VAR(gimme);
2679 register PERL_CONTEXT *cx;
2682 if (PL_op->op_flags & OPf_SPECIAL) {
2683 cxix = dopoptoloop(cxstack_ix);
2685 DIE(aTHX_ "Can't \"next\" outside a loop block");
2688 cxix = dopoptolabel(cPVOP->op_pv);
2690 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2692 if (cxix < cxstack_ix)
2695 /* clear off anything above the scope we're re-entering, but
2696 * save the rest until after a possible continue block */
2697 inner = PL_scopestack_ix;
2699 if (PL_scopestack_ix < inner)
2700 leave_scope(PL_scopestack[PL_scopestack_ix]);
2701 PL_curcop = cx->blk_oldcop;
2702 return (cx)->blk_loop.my_op->op_nextop;
2709 register PERL_CONTEXT *cx;
2713 if (PL_op->op_flags & OPf_SPECIAL) {
2714 cxix = dopoptoloop(cxstack_ix);
2716 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2719 cxix = dopoptolabel(cPVOP->op_pv);
2721 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2723 if (cxix < cxstack_ix)
2726 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2727 if (redo_op->op_type == OP_ENTER) {
2728 /* pop one less context to avoid $x being freed in while (my $x..) */
2730 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2731 redo_op = redo_op->op_next;
2735 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2736 LEAVE_SCOPE(oldsave);
2738 PL_curcop = cx->blk_oldcop;
2743 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2747 static const char too_deep[] = "Target of goto is too deeply nested";
2749 PERL_ARGS_ASSERT_DOFINDLABEL;
2752 Perl_croak(aTHX_ too_deep);
2753 if (o->op_type == OP_LEAVE ||
2754 o->op_type == OP_SCOPE ||
2755 o->op_type == OP_LEAVELOOP ||
2756 o->op_type == OP_LEAVESUB ||
2757 o->op_type == OP_LEAVETRY)
2759 *ops++ = cUNOPo->op_first;
2761 Perl_croak(aTHX_ too_deep);
2764 if (o->op_flags & OPf_KIDS) {
2766 /* First try all the kids at this level, since that's likeliest. */
2767 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2768 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2769 const char *kid_label = CopLABEL(kCOP);
2770 if (kid_label && strEQ(kid_label, label))
2774 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2775 if (kid == PL_lastgotoprobe)
2777 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2780 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2781 ops[-1]->op_type == OP_DBSTATE)
2786 if ((o = dofindlabel(kid, label, ops, oplimit)))
2799 register PERL_CONTEXT *cx;
2800 #define GOTO_DEPTH 64
2801 OP *enterops[GOTO_DEPTH];
2802 const char *label = NULL;
2803 const bool do_dump = (PL_op->op_type == OP_DUMP);
2804 static const char must_have_label[] = "goto must have label";
2806 if (PL_op->op_flags & OPf_STACKED) {
2807 SV * const sv = POPs;
2809 /* This egregious kludge implements goto &subroutine */
2810 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2812 register PERL_CONTEXT *cx;
2813 CV *cv = MUTABLE_CV(SvRV(sv));
2820 if (!CvROOT(cv) && !CvXSUB(cv)) {
2821 const GV * const gv = CvGV(cv);
2825 /* autoloaded stub? */
2826 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2828 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2830 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2831 if (autogv && (cv = GvCV(autogv)))
2833 tmpstr = sv_newmortal();
2834 gv_efullname3(tmpstr, gv, NULL);
2835 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2837 DIE(aTHX_ "Goto undefined subroutine");
2840 /* First do some returnish stuff. */
2841 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2843 cxix = dopoptosub(cxstack_ix);
2845 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2846 if (cxix < cxstack_ix)
2850 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2851 if (CxTYPE(cx) == CXt_EVAL) {
2853 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2854 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2856 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2857 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2859 else if (CxMULTICALL(cx))
2860 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2861 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2862 /* put @_ back onto stack */
2863 AV* av = cx->blk_sub.argarray;
2865 items = AvFILLp(av) + 1;
2866 EXTEND(SP, items+1); /* @_ could have been extended. */
2867 Copy(AvARRAY(av), SP + 1, items, SV*);
2868 SvREFCNT_dec(GvAV(PL_defgv));
2869 GvAV(PL_defgv) = cx->blk_sub.savearray;
2871 /* abandon @_ if it got reified */
2876 av_extend(av, items-1);
2878 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2881 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2882 AV* const av = GvAV(PL_defgv);
2883 items = AvFILLp(av) + 1;
2884 EXTEND(SP, items+1); /* @_ could have been extended. */
2885 Copy(AvARRAY(av), SP + 1, items, SV*);
2889 if (CxTYPE(cx) == CXt_SUB &&
2890 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2891 SvREFCNT_dec(cx->blk_sub.cv);
2892 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2893 LEAVE_SCOPE(oldsave);
2895 /* A destructor called during LEAVE_SCOPE could have undefined
2896 * our precious cv. See bug #99850. */
2897 if (!CvROOT(cv) && !CvXSUB(cv)) {
2898 const GV * const gv = CvGV(cv);
2900 SV * const tmpstr = sv_newmortal();
2901 gv_efullname3(tmpstr, gv, NULL);
2902 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2905 DIE(aTHX_ "Goto undefined subroutine");
2908 /* Now do some callish stuff. */
2910 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2912 OP* const retop = cx->blk_sub.retop;
2913 SV **newsp PERL_UNUSED_DECL;
2914 I32 gimme PERL_UNUSED_DECL;
2917 for (index=0; index<items; index++)
2918 sv_2mortal(SP[-index]);
2921 /* XS subs don't have a CxSUB, so pop it */
2922 POPBLOCK(cx, PL_curpm);
2923 /* Push a mark for the start of arglist */
2926 (void)(*CvXSUB(cv))(aTHX_ cv);
2931 AV* const padlist = CvPADLIST(cv);
2932 if (CxTYPE(cx) == CXt_EVAL) {
2933 PL_in_eval = CxOLD_IN_EVAL(cx);
2934 PL_eval_root = cx->blk_eval.old_eval_root;
2935 cx->cx_type = CXt_SUB;
2937 cx->blk_sub.cv = cv;
2938 cx->blk_sub.olddepth = CvDEPTH(cv);
2941 if (CvDEPTH(cv) < 2)
2942 SvREFCNT_inc_simple_void_NN(cv);
2944 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2945 sub_crush_depth(cv);
2946 pad_push(padlist, CvDEPTH(cv));
2948 PL_curcop = cx->blk_oldcop;
2950 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2953 AV *const av = MUTABLE_AV(PAD_SVl(0));
2955 cx->blk_sub.savearray = GvAV(PL_defgv);
2956 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2957 CX_CURPAD_SAVE(cx->blk_sub);
2958 cx->blk_sub.argarray = av;
2960 if (items >= AvMAX(av) + 1) {
2961 SV **ary = AvALLOC(av);
2962 if (AvARRAY(av) != ary) {
2963 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2966 if (items >= AvMAX(av) + 1) {
2967 AvMAX(av) = items - 1;
2968 Renew(ary,items+1,SV*);
2974 Copy(mark,AvARRAY(av),items,SV*);
2975 AvFILLp(av) = items - 1;
2976 assert(!AvREAL(av));
2978 /* transfer 'ownership' of refcnts to new @_ */
2988 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2989 Perl_get_db_sub(aTHX_ NULL, cv);
2991 CV * const gotocv = get_cvs("DB::goto", 0);
2993 PUSHMARK( PL_stack_sp );
2994 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2999 RETURNOP(CvSTART(cv));
3003 label = SvPV_nolen_const(sv);
3004 if (!(do_dump || *label))
3005 DIE(aTHX_ must_have_label);
3008 else if (PL_op->op_flags & OPf_SPECIAL) {
3010 DIE(aTHX_ must_have_label);
3013 label = cPVOP->op_pv;
3017 if (label && *label) {
3018 OP *gotoprobe = NULL;
3019 bool leaving_eval = FALSE;
3020 bool in_block = FALSE;
3021 PERL_CONTEXT *last_eval_cx = NULL;
3025 PL_lastgotoprobe = NULL;
3027 for (ix = cxstack_ix; ix >= 0; ix--) {
3029 switch (CxTYPE(cx)) {
3031 leaving_eval = TRUE;
3032 if (!CxTRYBLOCK(cx)) {
3033 gotoprobe = (last_eval_cx ?
3034 last_eval_cx->blk_eval.old_eval_root :
3039 /* else fall through */
3040 case CXt_LOOP_LAZYIV:
3041 case CXt_LOOP_LAZYSV:
3043 case CXt_LOOP_PLAIN:
3046 gotoprobe = cx->blk_oldcop->op_sibling;
3052 gotoprobe = cx->blk_oldcop->op_sibling;
3055 gotoprobe = PL_main_root;
3058 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3059 gotoprobe = CvROOT(cx->blk_sub.cv);
3065 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3068 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3069 CxTYPE(cx), (long) ix);
3070 gotoprobe = PL_main_root;
3074 retop = dofindlabel(gotoprobe, label,
3075 enterops, enterops + GOTO_DEPTH);
3078 if (gotoprobe->op_sibling &&
3079 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3080 gotoprobe->op_sibling->op_sibling) {
3081 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3082 label, enterops, enterops + GOTO_DEPTH);
3087 PL_lastgotoprobe = gotoprobe;
3090 DIE(aTHX_ "Can't find label %s", label);
3092 /* if we're leaving an eval, check before we pop any frames
3093 that we're not going to punt, otherwise the error
3096 if (leaving_eval && *enterops && enterops[1]) {
3098 for (i = 1; enterops[i]; i++)
3099 if (enterops[i]->op_type == OP_ENTERITER)
3100 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3103 if (*enterops && enterops[1]) {
3104 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3106 deprecate("\"goto\" to jump into a construct");
3109 /* pop unwanted frames */
3111 if (ix < cxstack_ix) {
3118 oldsave = PL_scopestack[PL_scopestack_ix];
3119 LEAVE_SCOPE(oldsave);
3122 /* push wanted frames */
3124 if (*enterops && enterops[1]) {
3125 OP * const oldop = PL_op;
3126 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3127 for (; enterops[ix]; ix++) {
3128 PL_op = enterops[ix];
3129 /* Eventually we may want to stack the needed arguments
3130 * for each op. For now, we punt on the hard ones. */
3131 if (PL_op->op_type == OP_ENTERITER)
3132 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3133 PL_op->op_ppaddr(aTHX);
3141 if (!retop) retop = PL_main_start;
3143 PL_restartop = retop;
3144 PL_do_undump = TRUE;
3148 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3149 PL_do_undump = FALSE;
3164 anum = 0; (void)POPs;
3169 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3171 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3174 PL_exit_flags |= PERL_EXIT_EXPECTED;
3176 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3177 if (anum || !(PL_minus_c && PL_madskills))
3182 PUSHs(&PL_sv_undef);
3189 S_save_lines(pTHX_ AV *array, SV *sv)
3191 const char *s = SvPVX_const(sv);
3192 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3195 PERL_ARGS_ASSERT_SAVE_LINES;
3197 while (s && s < send) {
3199 SV * const tmpstr = newSV_type(SVt_PVMG);
3201 t = (const char *)memchr(s, '\n', send - s);
3207 sv_setpvn(tmpstr, s, t - s);
3208 av_store(array, line++, tmpstr);
3216 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3218 0 is used as continue inside eval,
3220 3 is used for a die caught by an inner eval - continue inner loop
3222 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3223 establish a local jmpenv to handle exception traps.
3228 S_docatch(pTHX_ OP *o)
3232 OP * const oldop = PL_op;
3236 assert(CATCH_GET == TRUE);
3243 assert(cxstack_ix >= 0);
3244 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3245 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3250 /* die caught by an inner eval - continue inner loop */
3251 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3252 PL_restartjmpenv = NULL;
3253 PL_op = PL_restartop;
3269 /* James Bond: Do you expect me to talk?
3270 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3272 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3273 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3275 Currently it is not used outside the core code. Best if it stays that way.
3277 Hence it's now deprecated, and will be removed.
3280 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3281 /* sv Text to convert to OP tree. */
3282 /* startop op_free() this to undo. */
3283 /* code Short string id of the caller. */
3285 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3286 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3289 /* Don't use this. It will go away without warning once the regexp engine is
3290 refactored not to use it. */
3292 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3295 dVAR; dSP; /* Make POPBLOCK work. */
3301 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3302 char *tmpbuf = tbuf;
3305 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3309 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3311 ENTER_with_name("eval");
3312 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3314 /* switch to eval mode */
3316 if (IN_PERL_COMPILETIME) {
3317 SAVECOPSTASH_FREE(&PL_compiling);
3318 CopSTASH_set(&PL_compiling, PL_curstash);
3320 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3321 SV * const sv = sv_newmortal();
3322 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3323 code, (unsigned long)++PL_evalseq,
3324 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3329 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3330 (unsigned long)++PL_evalseq);
3331 SAVECOPFILE_FREE(&PL_compiling);
3332 CopFILE_set(&PL_compiling, tmpbuf+2);
3333 SAVECOPLINE(&PL_compiling);
3334 CopLINE_set(&PL_compiling, 1);
3335 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3336 deleting the eval's FILEGV from the stash before gv_check() runs
3337 (i.e. before run-time proper). To work around the coredump that
3338 ensues, we always turn GvMULTI_on for any globals that were
3339 introduced within evals. See force_ident(). GSAR 96-10-12 */
3340 safestr = savepvn(tmpbuf, len);
3341 SAVEDELETE(PL_defstash, safestr, len);
3343 #ifdef OP_IN_REGISTER
3349 /* we get here either during compilation, or via pp_regcomp at runtime */
3350 runtime = IN_PERL_RUNTIME;
3353 runcv = find_runcv(NULL);
3355 /* At run time, we have to fetch the hints from PL_curcop. */
3356 PL_hints = PL_curcop->cop_hints;
3357 if (PL_hints & HINT_LOCALIZE_HH) {
3358 /* SAVEHINTS created a new HV in PL_hintgv, which we
3360 SvREFCNT_dec(GvHV(PL_hintgv));
3362 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3363 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3365 SAVECOMPILEWARNINGS();
3366 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3367 cophh_free(CopHINTHASH_get(&PL_compiling));
3368 /* XXX Does this need to avoid copying a label? */
3369 PL_compiling.cop_hints_hash
3370 = cophh_copy(PL_curcop->cop_hints_hash);
3374 PL_op->op_type = OP_ENTEREVAL;
3375 PL_op->op_flags = 0; /* Avoid uninit warning. */
3376 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3378 need_catch = CATCH_GET;
3382 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3384 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3385 CATCH_SET(need_catch);
3386 POPBLOCK(cx,PL_curpm);
3389 (*startop)->op_type = OP_NULL;
3390 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3391 /* XXX DAPM do this properly one year */
3392 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3393 LEAVE_with_name("eval");
3394 if (IN_PERL_COMPILETIME)
3395 CopHINTS_set(&PL_compiling, PL_hints);
3396 #ifdef OP_IN_REGISTER
3399 PERL_UNUSED_VAR(newsp);
3400 PERL_UNUSED_VAR(optype);
3402 return PL_eval_start;
3407 =for apidoc find_runcv
3409 Locate the CV corresponding to the currently executing sub or eval.
3410 If db_seqp is non_null, skip CVs that are in the DB package and populate
3411 *db_seqp with the cop sequence number at the point that the DB:: code was
3412 entered. (allows debuggers to eval in the scope of the breakpoint rather
3413 than in the scope of the debugger itself).
3419 Perl_find_runcv(pTHX_ U32 *db_seqp)
3425 *db_seqp = PL_curcop->cop_seq;
3426 for (si = PL_curstackinfo; si; si = si->si_prev) {
3428 for (ix = si->si_cxix; ix >= 0; ix--) {
3429 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3430 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3431 CV * const cv = cx->blk_sub.cv;
3432 /* skip DB:: code */
3433 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3434 *db_seqp = cx->blk_oldcop->cop_seq;
3439 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3440 return cx->blk_eval.cv;
3447 /* Run yyparse() in a setjmp wrapper. Returns:
3448 * 0: yyparse() successful
3449 * 1: yyparse() failed
3453 S_try_yyparse(pTHX_ int gramtype)
3458 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3462 ret = yyparse(gramtype) ? 1 : 0;
3476 /* Compile a require/do, an eval '', or a /(?{...})/.
3477 * In the last case, startop is non-null, and contains the address of
3478 * a pointer that should be set to the just-compiled code.
3479 * outside is the lexically enclosing CV (if any) that invoked us.
3480 * Returns a bool indicating whether the compile was successful; if so,
3481 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3482 * pushes undef (also croaks if startop != NULL).
3485 /* This function is called from three places, sv_compile_2op, pp_return
3486 * and pp_entereval. These can be distinguished as follows:
3487 * sv_compile_2op - startop is non-null
3488 * pp_require - startop is null; saveop is not entereval
3489 * pp_entereval - startop is null; saveop is entereval
3493 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3496 OP * const saveop = PL_op;
3497 COP * const oldcurcop = PL_curcop;
3498 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3502 PL_in_eval = (in_require
3503 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3508 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3510 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3511 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3512 cxstack[cxstack_ix].blk_gimme = gimme;
3514 CvOUTSIDE_SEQ(evalcv) = seq;
3515 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3517 /* set up a scratch pad */
3519 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3520 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3524 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3526 /* make sure we compile in the right package */
3528 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3529 SAVEGENERICSV(PL_curstash);
3530 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3532 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3533 SAVESPTR(PL_beginav);
3534 PL_beginav = newAV();
3535 SAVEFREESV(PL_beginav);
3536 SAVESPTR(PL_unitcheckav);
3537 PL_unitcheckav = newAV();
3538 SAVEFREESV(PL_unitcheckav);
3541 SAVEBOOL(PL_madskills);
3545 if (!startop) ENTER_with_name("evalcomp");
3546 SAVESPTR(PL_compcv);
3549 /* try to compile it */
3551 PL_eval_root = NULL;
3552 PL_curcop = &PL_compiling;
3553 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3554 PL_in_eval |= EVAL_KEEPERR;
3559 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3563 hv_clear(GvHV(PL_hintgv));
3566 PL_hints = saveop->op_private & OPpEVAL_COPHH
3567 ? oldcurcop->cop_hints : saveop->op_targ;
3569 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3570 SvREFCNT_dec(GvHV(PL_hintgv));
3571 GvHV(PL_hintgv) = hh;
3574 SAVECOMPILEWARNINGS();
3576 if (PL_dowarn & G_WARN_ALL_ON)
3577 PL_compiling.cop_warnings = pWARN_ALL ;
3578 else if (PL_dowarn & G_WARN_ALL_OFF)
3579 PL_compiling.cop_warnings = pWARN_NONE ;
3581 PL_compiling.cop_warnings = pWARN_STD ;
3584 PL_compiling.cop_warnings =
3585 DUP_WARNINGS(oldcurcop->cop_warnings);
3586 cophh_free(CopHINTHASH_get(&PL_compiling));
3587 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3588 /* The label, if present, is the first entry on the chain. So rather
3589 than writing a blank label in front of it (which involves an
3590 allocation), just use the next entry in the chain. */
3591 PL_compiling.cop_hints_hash
3592 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3593 /* Check the assumption that this removed the label. */
3594 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3597 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3601 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3603 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3604 * so honour CATCH_GET and trap it here if necessary */
3606 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3608 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3609 SV **newsp; /* Used by POPBLOCK. */
3611 I32 optype; /* Used by POPEVAL. */
3616 PERL_UNUSED_VAR(newsp);
3617 PERL_UNUSED_VAR(optype);
3619 /* note that if yystatus == 3, then the EVAL CX block has already
3620 * been popped, and various vars restored */
3622 if (yystatus != 3) {
3624 op_free(PL_eval_root);
3625 PL_eval_root = NULL;
3627 SP = PL_stack_base + POPMARK; /* pop original mark */
3629 POPBLOCK(cx,PL_curpm);
3631 namesv = cx->blk_eval.old_namesv;
3633 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3634 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3639 /* If cx is still NULL, it means that we didn't go in the
3640 * POPEVAL branch. */
3641 cx = &cxstack[cxstack_ix];
3642 assert(CxTYPE(cx) == CXt_EVAL);
3643 namesv = cx->blk_eval.old_namesv;
3645 (void)hv_store(GvHVn(PL_incgv),
3646 SvPVX_const(namesv),
3647 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3649 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3652 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3655 if (yystatus != 3) {
3656 POPBLOCK(cx,PL_curpm);
3659 Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3662 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3665 if (!*(SvPVx_nolen_const(ERRSV))) {
3666 sv_setpvs(ERRSV, "Compilation error");
3669 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3673 else if (!startop) LEAVE_with_name("evalcomp");
3674 CopLINE_set(&PL_compiling, 0);
3676 *startop = PL_eval_root;
3678 SAVEFREEOP(PL_eval_root);
3680 DEBUG_x(dump_eval());
3682 /* Register with debugger: */
3683 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3684 CV * const cv = get_cvs("DB::postponed", 0);
3688 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3690 call_sv(MUTABLE_SV(cv), G_DISCARD);
3694 if (PL_unitcheckav) {
3695 OP *es = PL_eval_start;
3696 call_list(PL_scopestack_ix, PL_unitcheckav);
3700 /* compiled okay, so do it */
3702 CvDEPTH(evalcv) = 1;
3703 SP = PL_stack_base + POPMARK; /* pop original mark */
3704 PL_op = saveop; /* The caller may need it. */
3705 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3712 S_check_type_and_open(pTHX_ SV *name)
3715 const char *p = SvPV_nolen_const(name);
3716 const int st_rc = PerlLIO_stat(p, &st);
3718 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3720 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3724 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3725 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3727 return PerlIO_open(p, PERL_SCRIPT_MODE);
3731 #ifndef PERL_DISABLE_PMC
3733 S_doopen_pm(pTHX_ SV *name)
3736 const char *p = SvPV_const(name, namelen);
3738 PERL_ARGS_ASSERT_DOOPEN_PM;
3740 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3741 SV *const pmcsv = sv_newmortal();
3744 SvSetSV_nosteal(pmcsv,name);
3745 sv_catpvn(pmcsv, "c", 1);
3747 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3748 return check_type_and_open(pmcsv);
3750 return check_type_and_open(name);
3753 # define doopen_pm(name) check_type_and_open(name)
3754 #endif /* !PERL_DISABLE_PMC */
3759 register PERL_CONTEXT *cx;
3766 int vms_unixname = 0;
3768 const char *tryname = NULL;
3770 const I32 gimme = GIMME_V;
3771 int filter_has_file = 0;
3772 PerlIO *tryrsfp = NULL;
3773 SV *filter_cache = NULL;
3774 SV *filter_state = NULL;
3775 SV *filter_sub = NULL;
3781 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3782 sv = sv_2mortal(new_version(sv));
3783 if (!sv_derived_from(PL_patchlevel, "version"))
3784 upg_version(PL_patchlevel, TRUE);
3785 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3786 if ( vcmp(sv,PL_patchlevel) <= 0 )
3787 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3788 SVfARG(sv_2mortal(vnormal(sv))),
3789 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3793 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3796 SV * const req = SvRV(sv);
3797 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3799 /* get the left hand term */
3800 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3802 first = SvIV(*av_fetch(lav,0,0));
3803 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3804 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3805 || av_len(lav) > 1 /* FP with > 3 digits */
3806 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3808 DIE(aTHX_ "Perl %"SVf" required--this is only "
3810 SVfARG(sv_2mortal(vnormal(req))),
3811 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3814 else { /* probably 'use 5.10' or 'use 5.8' */
3819 second = SvIV(*av_fetch(lav,1,0));
3821 second /= second >= 600 ? 100 : 10;
3822 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3823 (int)first, (int)second);
3824 upg_version(hintsv, TRUE);
3826 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3827 "--this is only %"SVf", stopped",
3828 SVfARG(sv_2mortal(vnormal(req))),
3829 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3830 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3838 name = SvPV_const(sv, len);
3839 if (!(name && len > 0 && *name))
3840 DIE(aTHX_ "Null filename used");
3841 TAINT_PROPER("require");
3845 /* The key in the %ENV hash is in the syntax of file passed as the argument
3846 * usually this is in UNIX format, but sometimes in VMS format, which
3847 * can result in a module being pulled in more than once.
3848 * To prevent this, the key must be stored in UNIX format if the VMS
3849 * name can be translated to UNIX.
3851 if ((unixname = tounixspec(name, NULL)) != NULL) {
3852 unixlen = strlen(unixname);
3858 /* if not VMS or VMS name can not be translated to UNIX, pass it
3861 unixname = (char *) name;
3864 if (PL_op->op_type == OP_REQUIRE) {
3865 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3866 unixname, unixlen, 0);
3868 if (*svp != &PL_sv_undef)
3871 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3872 "Compilation failed in require", unixname);
3876 /* prepare to compile file */
3878 if (path_is_absolute(name)) {
3879 /* At this point, name is SvPVX(sv) */
3881 tryrsfp = doopen_pm(sv);
3884 AV * const ar = GvAVn(PL_incgv);
3890 namesv = newSV_type(SVt_PV);
3891 for (i = 0; i <= AvFILL(ar); i++) {
3892 SV * const dirsv = *av_fetch(ar, i, TRUE);
3894 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3901 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3902 && !sv_isobject(loader))
3904 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3907 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3908 PTR2UV(SvRV(dirsv)), name);
3909 tryname = SvPVX_const(namesv);
3912 ENTER_with_name("call_INC");
3920 if (sv_isobject(loader))
3921 count = call_method("INC", G_ARRAY);
3923 count = call_sv(loader, G_ARRAY);
3933 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3934 && !isGV_with_GP(SvRV(arg))) {
3935 filter_cache = SvRV(arg);
3936 SvREFCNT_inc_simple_void_NN(filter_cache);
3943 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3947 if (isGV_with_GP(arg)) {
3948 IO * const io = GvIO((const GV *)arg);
3953 tryrsfp = IoIFP(io);
3954 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3955 PerlIO_close(IoOFP(io));
3966 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3968 SvREFCNT_inc_simple_void_NN(filter_sub);
3971 filter_state = SP[i];
3972 SvREFCNT_inc_simple_void(filter_state);
3976 if (!tryrsfp && (filter_cache || filter_sub)) {
3977 tryrsfp = PerlIO_open(BIT_BUCKET,
3985 LEAVE_with_name("call_INC");
3987 /* Adjust file name if the hook has set an %INC entry.
3988 This needs to happen after the FREETMPS above. */
3989 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3991 tryname = SvPV_nolen_const(*svp);
3998 filter_has_file = 0;
4000 SvREFCNT_dec(filter_cache);
4001 filter_cache = NULL;
4004 SvREFCNT_dec(filter_state);
4005 filter_state = NULL;
4008 SvREFCNT_dec(filter_sub);
4013 if (!path_is_absolute(name)
4019 dir = SvPV_const(dirsv, dirlen);
4027 if ((unixdir = tounixpath(dir, NULL)) == NULL)
4029 sv_setpv(namesv, unixdir);
4030 sv_catpv(namesv, unixname);
4032 # ifdef __SYMBIAN32__
4033 if (PL_origfilename[0] &&
4034 PL_origfilename[1] == ':' &&
4035 !(dir[0] && dir[1] == ':'))
4036 Perl_sv_setpvf(aTHX_ namesv,
4041 Perl_sv_setpvf(aTHX_ namesv,
4045 /* The equivalent of
4046 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4047 but without the need to parse the format string, or
4048 call strlen on either pointer, and with the correct
4049 allocation up front. */
4051 char *tmp = SvGROW(namesv, dirlen + len + 2);
4053 memcpy(tmp, dir, dirlen);
4056 /* name came from an SV, so it will have a '\0' at the
4057 end that we can copy as part of this memcpy(). */
4058 memcpy(tmp, name, len + 1);
4060 SvCUR_set(namesv, dirlen + len + 1);
4065 TAINT_PROPER("require");
4066 tryname = SvPVX_const(namesv);
4067 tryrsfp = doopen_pm(namesv);
4069 if (tryname[0] == '.' && tryname[1] == '/') {
4071 while (*++tryname == '/');
4075 else if (errno == EMFILE)
4076 /* no point in trying other paths if out of handles */
4085 if (PL_op->op_type == OP_REQUIRE) {
4086 if(errno == EMFILE) {
4087 /* diag_listed_as: Can't locate %s */
4088 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
4090 if (namesv) { /* did we lookup @INC? */
4091 AV * const ar = GvAVn(PL_incgv);
4093 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4094 for (i = 0; i <= AvFILL(ar); i++) {
4095 sv_catpvs(inc, " ");
4096 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4099 /* diag_listed_as: Can't locate %s */
4101 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4103 (memEQ(name + len - 2, ".h", 3)
4104 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4105 (memEQ(name + len - 3, ".ph", 4)
4106 ? " (did you run h2ph?)" : ""),
4111 DIE(aTHX_ "Can't locate %s", name);
4117 SETERRNO(0, SS_NORMAL);
4119 /* Assume success here to prevent recursive requirement. */
4120 /* name is never assigned to again, so len is still strlen(name) */
4121 /* Check whether a hook in @INC has already filled %INC */
4123 (void)hv_store(GvHVn(PL_incgv),
4124 unixname, unixlen, newSVpv(tryname,0),0);
4126 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4128 (void)hv_store(GvHVn(PL_incgv),
4129 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4132 ENTER_with_name("eval");
4134 SAVECOPFILE_FREE(&PL_compiling);
4135 CopFILE_set(&PL_compiling, tryname);
4136 lex_start(NULL, tryrsfp, 0);
4138 if (filter_sub || filter_cache) {
4139 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4140 than hanging another SV from it. In turn, filter_add() optionally
4141 takes the SV to use as the filter (or creates a new SV if passed
4142 NULL), so simply pass in whatever value filter_cache has. */
4143 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4144 IoLINES(datasv) = filter_has_file;
4145 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4146 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4149 /* switch to eval mode */
4150 PUSHBLOCK(cx, CXt_EVAL, SP);
4152 cx->blk_eval.retop = PL_op->op_next;
4154 SAVECOPLINE(&PL_compiling);
4155 CopLINE_set(&PL_compiling, 0);
4159 /* Store and reset encoding. */
4160 encoding = PL_encoding;
4163 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4164 op = DOCATCH(PL_eval_start);
4166 op = PL_op->op_next;
4168 /* Restore encoding. */
4169 PL_encoding = encoding;
4174 /* This is a op added to hold the hints hash for
4175 pp_entereval. The hash can be modified by the code
4176 being eval'ed, so we return a copy instead. */
4182 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4190 register PERL_CONTEXT *cx;
4192 const I32 gimme = GIMME_V;
4193 const U32 was = PL_breakable_sub_gen;
4194 char tbuf[TYPE_DIGITS(long) + 12];
4195 bool saved_delete = FALSE;
4196 char *tmpbuf = tbuf;
4199 U32 seq, lex_flags = 0;
4200 HV *saved_hh = NULL;
4201 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4203 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4204 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4206 else if (PL_hints & HINT_LOCALIZE_HH || (
4207 PL_op->op_private & OPpEVAL_COPHH
4208 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4210 saved_hh = cop_hints_2hv(PL_curcop, 0);
4211 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4215 /* make sure we've got a plain PV (no overload etc) before testing
4216 * for taint. Making a copy here is probably overkill, but better
4217 * safe than sorry */
4219 const char * const p = SvPV_const(sv, len);
4221 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4222 lex_flags |= LEX_START_COPIED;
4224 if (bytes && SvUTF8(sv))
4225 SvPVbyte_force(sv, len);
4227 else if (bytes && SvUTF8(sv)) {
4228 /* Don't modify someone else's scalar */
4231 (void)sv_2mortal(sv);
4232 SvPVbyte_force(sv,len);
4233 lex_flags |= LEX_START_COPIED;
4236 TAINT_IF(SvTAINTED(sv));
4237 TAINT_PROPER("eval");
4239 ENTER_with_name("eval");
4240 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4241 ? LEX_IGNORE_UTF8_HINTS
4242 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4247 /* switch to eval mode */
4249 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4250 SV * const temp_sv = sv_newmortal();
4251 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4252 (unsigned long)++PL_evalseq,
4253 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4254 tmpbuf = SvPVX(temp_sv);
4255 len = SvCUR(temp_sv);
4258 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4259 SAVECOPFILE_FREE(&PL_compiling);
4260 CopFILE_set(&PL_compiling, tmpbuf+2);
4261 SAVECOPLINE(&PL_compiling);
4262 CopLINE_set(&PL_compiling, 1);
4263 /* special case: an eval '' executed within the DB package gets lexically
4264 * placed in the first non-DB CV rather than the current CV - this
4265 * allows the debugger to execute code, find lexicals etc, in the
4266 * scope of the code being debugged. Passing &seq gets find_runcv
4267 * to do the dirty work for us */
4268 runcv = find_runcv(&seq);
4270 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4272 cx->blk_eval.retop = PL_op->op_next;
4274 /* prepare to compile string */
4276 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4277 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4279 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4280 deleting the eval's FILEGV from the stash before gv_check() runs
4281 (i.e. before run-time proper). To work around the coredump that
4282 ensues, we always turn GvMULTI_on for any globals that were
4283 introduced within evals. See force_ident(). GSAR 96-10-12 */
4284 char *const safestr = savepvn(tmpbuf, len);
4285 SAVEDELETE(PL_defstash, safestr, len);
4286 saved_delete = TRUE;
4291 if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4292 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4293 ? (PERLDB_LINE || PERLDB_SAVESRC)
4294 : PERLDB_SAVESRC_NOSUBS) {
4295 /* Retain the filegv we created. */
4296 } else if (!saved_delete) {
4297 char *const safestr = savepvn(tmpbuf, len);
4298 SAVEDELETE(PL_defstash, safestr, len);
4300 return DOCATCH(PL_eval_start);
4302 /* We have already left the scope set up earlier thanks to the LEAVE
4304 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4305 ? (PERLDB_LINE || PERLDB_SAVESRC)
4306 : PERLDB_SAVESRC_INVALID) {
4307 /* Retain the filegv we created. */
4308 } else if (!saved_delete) {
4309 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4311 return PL_op->op_next;
4321 register PERL_CONTEXT *cx;
4323 const U8 save_flags = PL_op -> op_flags;
4331 namesv = cx->blk_eval.old_namesv;
4332 retop = cx->blk_eval.retop;
4333 evalcv = cx->blk_eval.cv;
4336 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4338 PL_curpm = newpm; /* Don't pop $1 et al till now */
4341 assert(CvDEPTH(evalcv) == 1);
4343 CvDEPTH(evalcv) = 0;
4345 if (optype == OP_REQUIRE &&
4346 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4348 /* Unassume the success we assumed earlier. */
4349 (void)hv_delete(GvHVn(PL_incgv),
4350 SvPVX_const(namesv),
4351 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4353 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4355 /* die_unwind() did LEAVE, or we won't be here */
4358 LEAVE_with_name("eval");
4359 if (!(save_flags & OPf_SPECIAL)) {
4367 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4368 close to the related Perl_create_eval_scope. */
4370 Perl_delete_eval_scope(pTHX)
4375 register PERL_CONTEXT *cx;
4381 LEAVE_with_name("eval_scope");
4382 PERL_UNUSED_VAR(newsp);
4383 PERL_UNUSED_VAR(gimme);
4384 PERL_UNUSED_VAR(optype);
4387 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4388 also needed by Perl_fold_constants. */
4390 Perl_create_eval_scope(pTHX_ U32 flags)
4393 const I32 gimme = GIMME_V;
4395 ENTER_with_name("eval_scope");
4398 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4401 PL_in_eval = EVAL_INEVAL;
4402 if (flags & G_KEEPERR)
4403 PL_in_eval |= EVAL_KEEPERR;
4406 if (flags & G_FAKINGEVAL) {
4407 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4415 PERL_CONTEXT * const cx = create_eval_scope(0);
4416 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4417 return DOCATCH(PL_op->op_next);
4426 register PERL_CONTEXT *cx;
4432 PERL_UNUSED_VAR(optype);
4435 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4436 PL_curpm = newpm; /* Don't pop $1 et al till now */
4438 LEAVE_with_name("eval_scope");
4446 register PERL_CONTEXT *cx;
4447 const I32 gimme = GIMME_V;
4449 ENTER_with_name("given");
4452 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4453 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4455 PUSHBLOCK(cx, CXt_GIVEN, SP);
4464 register PERL_CONTEXT *cx;
4468 PERL_UNUSED_CONTEXT;
4471 assert(CxTYPE(cx) == CXt_GIVEN);
4474 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4475 PL_curpm = newpm; /* Don't pop $1 et al till now */
4477 LEAVE_with_name("given");
4481 /* Helper routines used by pp_smartmatch */
4483 S_make_matcher(pTHX_ REGEXP *re)
4486 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4488 PERL_ARGS_ASSERT_MAKE_MATCHER;
4490 PM_SETRE(matcher, ReREFCNT_inc(re));
4492 SAVEFREEOP((OP *) matcher);
4493 ENTER_with_name("matcher"); SAVETMPS;
4499 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4504 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4506 PL_op = (OP *) matcher;
4509 (void) Perl_pp_match(aTHX);
4511 return (SvTRUEx(POPs));
4515 S_destroy_matcher(pTHX_ PMOP *matcher)
4519 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4520 PERL_UNUSED_ARG(matcher);
4523 LEAVE_with_name("matcher");
4526 /* Do a smart match */
4529 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4530 return do_smartmatch(NULL, NULL, 0);
4533 /* This version of do_smartmatch() implements the
4534 * table of smart matches that is found in perlsyn.
4537 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4542 bool object_on_left = FALSE;
4543 SV *e = TOPs; /* e is for 'expression' */
4544 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4546 /* Take care only to invoke mg_get() once for each argument.
4547 * Currently we do this by copying the SV if it's magical. */
4549 if (!copied && SvGMAGICAL(d))
4550 d = sv_mortalcopy(d);
4557 e = sv_mortalcopy(e);
4559 /* First of all, handle overload magic of the rightmost argument */
4562 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4563 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4565 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4572 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4575 SP -= 2; /* Pop the values */
4580 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4587 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4588 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4589 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4591 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4592 object_on_left = TRUE;
4595 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4597 if (object_on_left) {
4598 goto sm_any_sub; /* Treat objects like scalars */
4600 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4601 /* Test sub truth for each key */
4603 bool andedresults = TRUE;
4604 HV *hv = (HV*) SvRV(d);
4605 I32 numkeys = hv_iterinit(hv);
4606 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4609 while ( (he = hv_iternext(hv)) ) {
4610 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4611 ENTER_with_name("smartmatch_hash_key_test");
4614 PUSHs(hv_iterkeysv(he));
4616 c = call_sv(e, G_SCALAR);
4619 andedresults = FALSE;
4621 andedresults = SvTRUEx(POPs) && andedresults;
4623 LEAVE_with_name("smartmatch_hash_key_test");
4630 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4631 /* Test sub truth for each element */
4633 bool andedresults = TRUE;
4634 AV *av = (AV*) SvRV(d);
4635 const I32 len = av_len(av);
4636 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4639 for (i = 0; i <= len; ++i) {
4640 SV * const * const svp = av_fetch(av, i, FALSE);
4641 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4642 ENTER_with_name("smartmatch_array_elem_test");
4648 c = call_sv(e, G_SCALAR);
4651 andedresults = FALSE;
4653 andedresults = SvTRUEx(POPs) && andedresults;
4655 LEAVE_with_name("smartmatch_array_elem_test");
4664 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4665 ENTER_with_name("smartmatch_coderef");
4670 c = call_sv(e, G_SCALAR);
4674 else if (SvTEMP(TOPs))
4675 SvREFCNT_inc_void(TOPs);
4677 LEAVE_with_name("smartmatch_coderef");
4682 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4683 if (object_on_left) {
4684 goto sm_any_hash; /* Treat objects like scalars */
4686 else if (!SvOK(d)) {
4687 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4690 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4691 /* Check that the key-sets are identical */
4693 HV *other_hv = MUTABLE_HV(SvRV(d));
4695 bool other_tied = FALSE;
4696 U32 this_key_count = 0,
4697 other_key_count = 0;
4698 HV *hv = MUTABLE_HV(SvRV(e));
4700 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4701 /* Tied hashes don't know how many keys they have. */
4702 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4705 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4706 HV * const temp = other_hv;
4711 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4714 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4717 /* The hashes have the same number of keys, so it suffices
4718 to check that one is a subset of the other. */
4719 (void) hv_iterinit(hv);
4720 while ( (he = hv_iternext(hv)) ) {
4721 SV *key = hv_iterkeysv(he);
4723 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4726 if(!hv_exists_ent(other_hv, key, 0)) {
4727 (void) hv_iterinit(hv); /* reset iterator */
4733 (void) hv_iterinit(other_hv);
4734 while ( hv_iternext(other_hv) )
4738 other_key_count = HvUSEDKEYS(other_hv);
4740 if (this_key_count != other_key_count)
4745 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4746 AV * const other_av = MUTABLE_AV(SvRV(d));
4747 const I32 other_len = av_len(other_av) + 1;
4749 HV *hv = MUTABLE_HV(SvRV(e));
4751 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4752 for (i = 0; i < other_len; ++i) {
4753 SV ** const svp = av_fetch(other_av, i, FALSE);
4754 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4755 if (svp) { /* ??? When can this not happen? */
4756 if (hv_exists_ent(hv, *svp, 0))
4762 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4763 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4766 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4768 HV *hv = MUTABLE_HV(SvRV(e));
4770 (void) hv_iterinit(hv);
4771 while ( (he = hv_iternext(hv)) ) {
4772 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4773 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4774 (void) hv_iterinit(hv);
4775 destroy_matcher(matcher);
4779 destroy_matcher(matcher);
4785 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4786 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4793 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4794 if (object_on_left) {
4795 goto sm_any_array; /* Treat objects like scalars */
4797 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4798 AV * const other_av = MUTABLE_AV(SvRV(e));
4799 const I32 other_len = av_len(other_av) + 1;
4802 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4803 for (i = 0; i < other_len; ++i) {
4804 SV ** const svp = av_fetch(other_av, i, FALSE);
4806 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4807 if (svp) { /* ??? When can this not happen? */
4808 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4814 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4815 AV *other_av = MUTABLE_AV(SvRV(d));
4816 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4817 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4821 const I32 other_len = av_len(other_av);
4823 if (NULL == seen_this) {
4824 seen_this = newHV();
4825 (void) sv_2mortal(MUTABLE_SV(seen_this));
4827 if (NULL == seen_other) {
4828 seen_other = newHV();
4829 (void) sv_2mortal(MUTABLE_SV(seen_other));
4831 for(i = 0; i <= other_len; ++i) {
4832 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4833 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4835 if (!this_elem || !other_elem) {
4836 if ((this_elem && SvOK(*this_elem))
4837 || (other_elem && SvOK(*other_elem)))
4840 else if (hv_exists_ent(seen_this,
4841 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4842 hv_exists_ent(seen_other,
4843 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4845 if (*this_elem != *other_elem)
4849 (void)hv_store_ent(seen_this,
4850 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4852 (void)hv_store_ent(seen_other,
4853 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4859 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4860 (void) do_smartmatch(seen_this, seen_other, 0);
4862 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4871 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4872 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4875 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4876 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4879 for(i = 0; i <= this_len; ++i) {
4880 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4881 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4882 if (svp && matcher_matches_sv(matcher, *svp)) {
4883 destroy_matcher(matcher);
4887 destroy_matcher(matcher);
4891 else if (!SvOK(d)) {
4892 /* undef ~~ array */
4893 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4896 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4897 for (i = 0; i <= this_len; ++i) {
4898 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4899 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4900 if (!svp || !SvOK(*svp))
4909 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4911 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4912 for (i = 0; i <= this_len; ++i) {
4913 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4920 /* infinite recursion isn't supposed to happen here */
4921 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4922 (void) do_smartmatch(NULL, NULL, 1);
4924 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4933 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4934 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4935 SV *t = d; d = e; e = t;
4936 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4939 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4940 SV *t = d; d = e; e = t;
4941 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4942 goto sm_regex_array;
4945 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4947 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4949 PUSHs(matcher_matches_sv(matcher, d)
4952 destroy_matcher(matcher);
4957 /* See if there is overload magic on left */
4958 else if (object_on_left && SvAMAGIC(d)) {
4960 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4961 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4964 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4972 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4975 else if (!SvOK(d)) {
4976 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4977 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4982 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4983 DEBUG_M(if (SvNIOK(e))
4984 Perl_deb(aTHX_ " applying rule Any-Num\n");
4986 Perl_deb(aTHX_ " applying rule Num-numish\n");
4988 /* numeric comparison */
4991 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4992 (void) Perl_pp_i_eq(aTHX);
4994 (void) Perl_pp_eq(aTHX);
5002 /* As a last resort, use string comparison */
5003 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
5006 return Perl_pp_seq(aTHX);
5012 register PERL_CONTEXT *cx;
5013 const I32 gimme = GIMME_V;
5015 /* This is essentially an optimization: if the match
5016 fails, we don't want to push a context and then
5017 pop it again right away, so we skip straight
5018 to the op that follows the leavewhen.
5019 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5021 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5022 RETURNOP(cLOGOP->op_other->op_next);
5024 ENTER_with_name("when");
5027 PUSHBLOCK(cx, CXt_WHEN, SP);
5037 register PERL_CONTEXT *cx;
5042 cxix = dopoptogiven(cxstack_ix);
5044 /* diag_listed_as: Can't "when" outside a topicalizer */
5045 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5046 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5049 assert(CxTYPE(cx) == CXt_WHEN);
5052 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
5053 PL_curpm = newpm; /* pop $1 et al */
5055 LEAVE_with_name("when");
5057 if (cxix < cxstack_ix)
5060 cx = &cxstack[cxix];
5062 if (CxFOREACH(cx)) {
5063 /* clear off anything above the scope we're re-entering */
5064 I32 inner = PL_scopestack_ix;
5067 if (PL_scopestack_ix < inner)
5068 leave_scope(PL_scopestack[PL_scopestack_ix]);
5069 PL_curcop = cx->blk_oldcop;
5071 return cx->blk_loop.my_op->op_nextop;
5074 RETURNOP(cx->blk_givwhen.leave_op);
5081 register PERL_CONTEXT *cx;
5086 PERL_UNUSED_VAR(gimme);
5088 cxix = dopoptowhen(cxstack_ix);
5090 DIE(aTHX_ "Can't \"continue\" outside a when block");
5092 if (cxix < cxstack_ix)
5096 assert(CxTYPE(cx) == CXt_WHEN);
5099 PL_curpm = newpm; /* pop $1 et al */
5101 LEAVE_with_name("when");
5102 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5109 register PERL_CONTEXT *cx;
5111 cxix = dopoptogiven(cxstack_ix);
5113 DIE(aTHX_ "Can't \"break\" outside a given block");
5115 cx = &cxstack[cxix];
5117 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5119 if (cxix < cxstack_ix)
5122 /* Restore the sp at the time we entered the given block */
5125 return cx->blk_givwhen.leave_op;
5129 S_doparseform(pTHX_ SV *sv)
5132 register char *s = SvPV(sv, len);
5133 register char *send;
5134 register char *base = NULL; /* start of current field */
5135 register I32 skipspaces = 0; /* number of contiguous spaces seen */
5136 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5137 bool repeat = FALSE; /* ~~ seen on this line */
5138 bool postspace = FALSE; /* a text field may need right padding */
5141 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5143 bool ischop; /* it's a ^ rather than a @ */
5144 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5145 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5149 PERL_ARGS_ASSERT_DOPARSEFORM;
5152 Perl_croak(aTHX_ "Null picture in formline");
5154 if (SvTYPE(sv) >= SVt_PVMG) {
5155 /* This might, of course, still return NULL. */
5156 mg = mg_find(sv, PERL_MAGIC_fm);
5158 sv_upgrade(sv, SVt_PVMG);
5162 /* still the same as previously-compiled string? */
5163 SV *old = mg->mg_obj;
5164 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5165 && len == SvCUR(old)
5166 && strnEQ(SvPVX(old), SvPVX(sv), len)
5168 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5172 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5173 Safefree(mg->mg_ptr);
5179 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5180 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5183 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5184 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5188 /* estimate the buffer size needed */
5189 for (base = s; s <= send; s++) {
5190 if (*s == '\n' || *s == '@' || *s == '^')
5196 Newx(fops, maxops, U32);
5201 *fpc++ = FF_LINEMARK;
5202 noblank = repeat = FALSE;
5220 case ' ': case '\t':
5227 } /* else FALL THROUGH */
5235 *fpc++ = FF_LITERAL;
5243 *fpc++ = (U32)skipspaces;
5247 *fpc++ = FF_NEWLINE;
5251 arg = fpc - linepc + 1;
5258 *fpc++ = FF_LINEMARK;
5259 noblank = repeat = FALSE;
5268 ischop = s[-1] == '^';
5274 arg = (s - base) - 1;
5276 *fpc++ = FF_LITERAL;
5282 if (*s == '*') { /* @* or ^* */
5284 *fpc++ = 2; /* skip the @* or ^* */
5286 *fpc++ = FF_LINESNGL;
5289 *fpc++ = FF_LINEGLOB;
5291 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5292 arg = ischop ? FORM_NUM_BLANK : 0;
5297 const char * const f = ++s;
5300 arg |= FORM_NUM_POINT + (s - f);
5302 *fpc++ = s - base; /* fieldsize for FETCH */
5303 *fpc++ = FF_DECIMAL;
5305 unchopnum |= ! ischop;
5307 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5308 arg = ischop ? FORM_NUM_BLANK : 0;
5310 s++; /* skip the '0' first */
5314 const char * const f = ++s;
5317 arg |= FORM_NUM_POINT + (s - f);
5319 *fpc++ = s - base; /* fieldsize for FETCH */
5320 *fpc++ = FF_0DECIMAL;
5322 unchopnum |= ! ischop;
5324 else { /* text field */
5326 bool ismore = FALSE;
5329 while (*++s == '>') ;
5330 prespace = FF_SPACE;
5332 else if (*s == '|') {
5333 while (*++s == '|') ;
5334 prespace = FF_HALFSPACE;
5339 while (*++s == '<') ;
5342 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5346 *fpc++ = s - base; /* fieldsize for FETCH */
5348 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5351 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5365 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5368 mg->mg_ptr = (char *) fops;
5369 mg->mg_len = arg * sizeof(U32);
5370 mg->mg_obj = sv_copy;
5371 mg->mg_flags |= MGf_REFCOUNTED;
5373 if (unchopnum && repeat)
5374 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5381 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5383 /* Can value be printed in fldsize chars, using %*.*f ? */
5387 int intsize = fldsize - (value < 0 ? 1 : 0);
5389 if (frcsize & FORM_NUM_POINT)
5391 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5394 while (intsize--) pwr *= 10.0;
5395 while (frcsize--) eps /= 10.0;
5398 if (value + eps >= pwr)
5401 if (value - eps <= -pwr)
5408 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5411 SV * const datasv = FILTER_DATA(idx);
5412 const int filter_has_file = IoLINES(datasv);
5413 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5414 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5419 char *prune_from = NULL;
5420 bool read_from_cache = FALSE;
5423 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5425 assert(maxlen >= 0);
5428 /* I was having segfault trouble under Linux 2.2.5 after a
5429 parse error occured. (Had to hack around it with a test
5430 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5431 not sure where the trouble is yet. XXX */
5434 SV *const cache = datasv;
5437 const char *cache_p = SvPV(cache, cache_len);
5441 /* Running in block mode and we have some cached data already.
5443 if (cache_len >= umaxlen) {
5444 /* In fact, so much data we don't even need to call
5449 const char *const first_nl =
5450 (const char *)memchr(cache_p, '\n', cache_len);
5452 take = first_nl + 1 - cache_p;
5456 sv_catpvn(buf_sv, cache_p, take);
5457 sv_chop(cache, cache_p + take);
5458 /* Definitely not EOF */
5462 sv_catsv(buf_sv, cache);
5464 umaxlen -= cache_len;
5467 read_from_cache = TRUE;
5471 /* Filter API says that the filter appends to the contents of the buffer.
5472 Usually the buffer is "", so the details don't matter. But if it's not,
5473 then clearly what it contains is already filtered by this filter, so we
5474 don't want to pass it in a second time.
5475 I'm going to use a mortal in case the upstream filter croaks. */
5476 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5477 ? sv_newmortal() : buf_sv;
5478 SvUPGRADE(upstream, SVt_PV);
5480 if (filter_has_file) {
5481 status = FILTER_READ(idx+1, upstream, 0);
5484 if (filter_sub && status >= 0) {
5488 ENTER_with_name("call_filter_sub");
5493 DEFSV_set(upstream);
5497 PUSHs(filter_state);
5500 count = call_sv(filter_sub, G_SCALAR);
5512 LEAVE_with_name("call_filter_sub");
5515 if(SvOK(upstream)) {
5516 got_p = SvPV(upstream, got_len);
5518 if (got_len > umaxlen) {
5519 prune_from = got_p + umaxlen;
5522 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5523 if (first_nl && first_nl + 1 < got_p + got_len) {
5524 /* There's a second line here... */
5525 prune_from = first_nl + 1;
5530 /* Oh. Too long. Stuff some in our cache. */
5531 STRLEN cached_len = got_p + got_len - prune_from;
5532 SV *const cache = datasv;
5535 /* Cache should be empty. */
5536 assert(!SvCUR(cache));
5539 sv_setpvn(cache, prune_from, cached_len);
5540 /* If you ask for block mode, you may well split UTF-8 characters.
5541 "If it breaks, you get to keep both parts"
5542 (Your code is broken if you don't put them back together again
5543 before something notices.) */
5544 if (SvUTF8(upstream)) {
5547 SvCUR_set(upstream, got_len - cached_len);
5549 /* Can't yet be EOF */
5554 /* If they are at EOF but buf_sv has something in it, then they may never
5555 have touched the SV upstream, so it may be undefined. If we naively
5556 concatenate it then we get a warning about use of uninitialised value.
5558 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5559 sv_catsv(buf_sv, upstream);
5563 IoLINES(datasv) = 0;
5565 SvREFCNT_dec(filter_state);
5566 IoTOP_GV(datasv) = NULL;
5569 SvREFCNT_dec(filter_sub);
5570 IoBOTTOM_GV(datasv) = NULL;
5572 filter_del(S_run_user_filter);
5574 if (status == 0 && read_from_cache) {
5575 /* If we read some data from the cache (and by getting here it implies
5576 that we emptied the cache) then we aren't yet at EOF, and mustn't
5577 report that to our caller. */
5583 /* perhaps someone can come up with a better name for
5584 this? it is not really "absolute", per se ... */
5586 S_path_is_absolute(const char *name)
5588 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5590 if (PERL_FILE_IS_ABSOLUTE(name)
5592 || (*name == '.' && ((name[1] == '/' ||
5593 (name[1] == '.' && name[2] == '/'))
5594 || (name[1] == '\\' ||
5595 ( name[1] == '.' && name[2] == '\\')))
5598 || (*name == '.' && (name[1] == '/' ||
5599 (name[1] == '.' && name[2] == '/')))
5611 * c-indentation-style: bsd
5613 * indent-tabs-mode: t
5616 * ex: set ts=8 sts=4 sw=4 noet: