3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
46 const PERL_CONTEXT *cx;
49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
53 cxix = dopoptosub(cxstack_ix);
59 switch (cx->blk_gimme) {
72 /* XXXX Should store the old value to allow for tie/overload - and
73 restore in regcomp, where marked with XXXX. */
83 register PMOP *pm = (PMOP*)cLOGOP->op_other;
87 /* prevent recompiling under /o and ithreads. */
88 #if defined(USE_ITHREADS)
89 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
90 if (PL_op->op_flags & OPf_STACKED) {
100 #define tryAMAGICregexp(rx) \
103 if (SvROK(rx) && SvAMAGIC(rx)) { \
104 SV *sv = AMG_CALLunary(rx, regexp_amg); \
108 if (SvTYPE(sv) != SVt_REGEXP) \
109 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
116 if (PL_op->op_flags & OPf_STACKED) {
117 /* multiple args; concatenate them */
119 tmpstr = PAD_SV(ARGTARG);
120 sv_setpvs(tmpstr, "");
121 while (++MARK <= SP) {
125 tryAMAGICregexp(msv);
127 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
128 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
130 sv_setsv(tmpstr, sv);
133 sv_catsv_nomg(tmpstr, msv);
140 tryAMAGICregexp(tmpstr);
143 #undef tryAMAGICregexp
146 SV * const sv = SvRV(tmpstr);
147 if (SvTYPE(sv) == SVt_REGEXP)
150 else if (SvTYPE(tmpstr) == SVt_REGEXP)
151 re = (REGEXP*) tmpstr;
154 /* The match's LHS's get-magic might need to access this op's reg-
155 exp (as is sometimes the case with $'; see bug 70764). So we
156 must call get-magic now before we replace the regexp. Hopeful-
157 ly this hack can be replaced with the approach described at
158 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
159 /msg122415.html some day. */
160 if(pm->op_type == OP_MATCH) {
162 const bool was_tainted = PL_tainted;
163 if (pm->op_flags & OPf_STACKED)
165 else if (pm->op_private & OPpTARGET_MY)
166 lhs = PAD_SV(pm->op_targ);
169 /* Restore the previous value of PL_tainted (which may have been
170 modified by get-magic), to avoid incorrectly setting the
171 RXf_TAINTED flag further down. */
172 PL_tainted = was_tainted;
175 re = reg_temp_copy(NULL, re);
176 ReREFCNT_dec(PM_GETRE(pm));
181 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
184 assert (re != (REGEXP*) &PL_sv_undef);
186 /* Check against the last compiled regexp. */
187 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
188 memNE(RX_PRECOMP(re), t, len))
190 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
191 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
195 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
197 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
199 } else if (PL_curcop->cop_hints_hash) {
200 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
201 if (ptr && SvIOK(ptr) && SvIV(ptr))
202 eng = INT2PTR(regexp_engine*,SvIV(ptr));
205 if (PL_op->op_flags & OPf_SPECIAL)
206 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
208 if (!DO_UTF8(tmpstr) && SvUTF8(tmpstr)) {
209 /* Not doing UTF-8, despite what the SV says. Is this only if
210 we're trapped in use 'bytes'? */
211 /* Make a copy of the octet sequence, but without the flag on,
212 as the compiler now honours the SvUTF8 flag on tmpstr. */
214 const char *const p = SvPV(tmpstr, len);
215 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
217 else if (SvAMAGIC(tmpstr) || SvGMAGICAL(tmpstr)) {
218 /* make a copy to avoid extra stringifies */
219 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
223 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
225 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
227 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
228 inside tie/overload accessors. */
234 #ifndef INCOMPLETE_TAINTS
237 SvTAINTED_on((SV*)re);
238 RX_EXTFLAGS(re) |= RXf_TAINTED;
243 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
247 #if !defined(USE_ITHREADS)
248 /* can't change the optree at runtime either */
249 /* PMf_KEEP is handled differently under threads to avoid these problems */
250 if (pm->op_pmflags & PMf_KEEP) {
251 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
252 cLOGOP->op_first->op_next = PL_op->op_next;
262 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
263 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
264 register SV * const dstr = cx->sb_dstr;
265 register char *s = cx->sb_s;
266 register char *m = cx->sb_m;
267 char *orig = cx->sb_orig;
268 register REGEXP * const rx = cx->sb_rx;
270 REGEXP *old = PM_GETRE(pm);
277 PM_SETRE(pm,ReREFCNT_inc(rx));
280 rxres_restore(&cx->sb_rxres, rx);
281 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
283 if (cx->sb_iters++) {
284 const I32 saviters = cx->sb_iters;
285 if (cx->sb_iters > cx->sb_maxiters)
286 DIE(aTHX_ "Substitution loop");
288 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
290 /* See "how taint works" above pp_subst() */
292 cx->sb_rxtainted |= SUBST_TAINT_REPL;
293 sv_catsv_nomg(dstr, POPs);
294 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
298 /* I believe that we can't set REXEC_SCREAM here if
299 SvSCREAM(cx->sb_targ) is true because SvPVX(cx->sb_targ) isn't always
300 equal to s. [See the comment before Perl_re_intuit_start(), which is
301 called from Perl_regexec_flags(), which says that it should be when
302 SvSCREAM() is true.] s, cx->sb_strend and orig will be consistent
303 with SvPVX(cx->sb_targ), as substconst doesn't modify cx->sb_targ
305 if (CxONCE(cx) || s < orig ||
306 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
307 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
308 ((cx->sb_rflags & REXEC_COPY_STR)
309 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
310 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
312 SV *targ = cx->sb_targ;
314 assert(cx->sb_strend >= s);
315 if(cx->sb_strend > s) {
316 if (DO_UTF8(dstr) && !SvUTF8(targ))
317 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
319 sv_catpvn(dstr, s, cx->sb_strend - s);
321 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
322 cx->sb_rxtainted |= SUBST_TAINT_PAT;
324 if (pm->op_pmflags & PMf_NONDESTRUCT) {
326 /* From here on down we're using the copy, and leaving the
327 original untouched. */
331 #ifdef PERL_OLD_COPY_ON_WRITE
333 sv_force_normal_flags(targ, SV_COW_DROP_PV);
339 SvPV_set(targ, SvPVX(dstr));
340 SvCUR_set(targ, SvCUR(dstr));
341 SvLEN_set(targ, SvLEN(dstr));
344 SvPV_set(dstr, NULL);
346 mPUSHi(saviters - 1);
348 (void)SvPOK_only_UTF8(targ);
351 /* update the taint state of various various variables in
352 * preparation for final exit.
353 * See "how taint works" above pp_subst() */
355 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
356 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
357 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
359 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
361 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
362 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
364 SvTAINTED_on(TOPs); /* taint return value */
365 /* needed for mg_set below */
366 PL_tainted = cBOOL(cx->sb_rxtainted &
367 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
370 /* PL_tainted must be correctly set for this mg_set */
373 LEAVE_SCOPE(cx->sb_oldsave);
375 RETURNOP(pm->op_next);
378 cx->sb_iters = saviters;
380 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
383 cx->sb_orig = orig = RX_SUBBEG(rx);
385 cx->sb_strend = s + (cx->sb_strend - m);
387 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
389 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
390 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
392 sv_catpvn(dstr, s, m-s);
394 cx->sb_s = RX_OFFS(rx)[0].end + orig;
395 { /* Update the pos() information. */
397 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
399 SvUPGRADE(sv, SVt_PVMG);
400 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
401 #ifdef PERL_OLD_COPY_ON_WRITE
403 sv_force_normal_flags(sv, 0);
405 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
408 mg->mg_len = m - orig;
411 (void)ReREFCNT_inc(rx);
412 /* update the taint state of various various variables in preparation
413 * for calling the code block.
414 * See "how taint works" above pp_subst() */
416 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
417 cx->sb_rxtainted |= SUBST_TAINT_PAT;
419 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
420 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
421 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
423 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
425 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
426 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
427 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
428 ? cx->sb_dstr : cx->sb_targ);
431 rxres_save(&cx->sb_rxres, rx);
433 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
437 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
442 PERL_ARGS_ASSERT_RXRES_SAVE;
445 if (!p || p[1] < RX_NPARENS(rx)) {
446 #ifdef PERL_OLD_COPY_ON_WRITE
447 i = 7 + RX_NPARENS(rx) * 2;
449 i = 6 + RX_NPARENS(rx) * 2;
458 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
459 RX_MATCH_COPIED_off(rx);
461 #ifdef PERL_OLD_COPY_ON_WRITE
462 *p++ = PTR2UV(RX_SAVED_COPY(rx));
463 RX_SAVED_COPY(rx) = NULL;
466 *p++ = RX_NPARENS(rx);
468 *p++ = PTR2UV(RX_SUBBEG(rx));
469 *p++ = (UV)RX_SUBLEN(rx);
470 for (i = 0; i <= RX_NPARENS(rx); ++i) {
471 *p++ = (UV)RX_OFFS(rx)[i].start;
472 *p++ = (UV)RX_OFFS(rx)[i].end;
477 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
482 PERL_ARGS_ASSERT_RXRES_RESTORE;
485 RX_MATCH_COPY_FREE(rx);
486 RX_MATCH_COPIED_set(rx, *p);
489 #ifdef PERL_OLD_COPY_ON_WRITE
490 if (RX_SAVED_COPY(rx))
491 SvREFCNT_dec (RX_SAVED_COPY(rx));
492 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
496 RX_NPARENS(rx) = *p++;
498 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
499 RX_SUBLEN(rx) = (I32)(*p++);
500 for (i = 0; i <= RX_NPARENS(rx); ++i) {
501 RX_OFFS(rx)[i].start = (I32)(*p++);
502 RX_OFFS(rx)[i].end = (I32)(*p++);
507 S_rxres_free(pTHX_ void **rsp)
509 UV * const p = (UV*)*rsp;
511 PERL_ARGS_ASSERT_RXRES_FREE;
516 void *tmp = INT2PTR(char*,*p);
519 PoisonFree(*p, 1, sizeof(*p));
521 Safefree(INT2PTR(char*,*p));
523 #ifdef PERL_OLD_COPY_ON_WRITE
525 SvREFCNT_dec (INT2PTR(SV*,p[1]));
533 #define FORM_NUM_BLANK (1<<30)
534 #define FORM_NUM_POINT (1<<29)
538 dVAR; dSP; dMARK; dORIGMARK;
539 register SV * const tmpForm = *++MARK;
540 SV *formsv; /* contains text of original format */
541 register U32 *fpc; /* format ops program counter */
542 register char *t; /* current append position in target string */
543 const char *f; /* current position in format string */
545 register SV *sv = NULL; /* current item */
546 const char *item = NULL;/* string value of current item */
547 I32 itemsize = 0; /* length of current item, possibly truncated */
548 I32 fieldsize = 0; /* width of current field */
549 I32 lines = 0; /* number of lines that have been output */
550 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
551 const char *chophere = NULL; /* where to chop current item */
552 STRLEN linemark = 0; /* pos of start of line in output */
554 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
556 STRLEN linemax; /* estimate of output size in bytes */
557 bool item_is_utf8 = FALSE;
558 bool targ_is_utf8 = FALSE;
561 U8 *source; /* source of bytes to append */
562 STRLEN to_copy; /* how may bytes to append */
563 char trans; /* what chars to translate */
565 mg = doparseform(tmpForm);
567 fpc = (U32*)mg->mg_ptr;
568 /* the actual string the format was compiled from.
569 * with overload etc, this may not match tmpForm */
573 SvPV_force(PL_formtarget, len);
574 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
575 SvTAINTED_on(PL_formtarget);
576 if (DO_UTF8(PL_formtarget))
578 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
579 t = SvGROW(PL_formtarget, len + linemax + 1);
580 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
582 f = SvPV_const(formsv, len);
586 const char *name = "???";
589 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
590 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
591 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
592 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
593 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
595 case FF_CHECKNL: name = "CHECKNL"; break;
596 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
597 case FF_SPACE: name = "SPACE"; break;
598 case FF_HALFSPACE: name = "HALFSPACE"; break;
599 case FF_ITEM: name = "ITEM"; break;
600 case FF_CHOP: name = "CHOP"; break;
601 case FF_LINEGLOB: name = "LINEGLOB"; break;
602 case FF_NEWLINE: name = "NEWLINE"; break;
603 case FF_MORE: name = "MORE"; break;
604 case FF_LINEMARK: name = "LINEMARK"; break;
605 case FF_END: name = "END"; break;
606 case FF_0DECIMAL: name = "0DECIMAL"; break;
607 case FF_LINESNGL: name = "LINESNGL"; break;
610 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
612 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
616 linemark = t - SvPVX(PL_formtarget);
626 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
642 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
645 SvTAINTED_on(PL_formtarget);
651 const char *s = item = SvPV_const(sv, len);
654 itemsize = sv_len_utf8(sv);
655 if (itemsize != (I32)len) {
657 if (itemsize > fieldsize) {
658 itemsize = fieldsize;
659 itembytes = itemsize;
660 sv_pos_u2b(sv, &itembytes, 0);
664 send = chophere = s + itembytes;
674 sv_pos_b2u(sv, &itemsize);
678 item_is_utf8 = FALSE;
679 if (itemsize > fieldsize)
680 itemsize = fieldsize;
681 send = chophere = s + itemsize;
695 const char *s = item = SvPV_const(sv, len);
698 itemsize = sv_len_utf8(sv);
699 if (itemsize != (I32)len) {
701 if (itemsize <= fieldsize) {
702 const char *send = chophere = s + itemsize;
715 itemsize = fieldsize;
716 itembytes = itemsize;
717 sv_pos_u2b(sv, &itembytes, 0);
718 send = chophere = s + itembytes;
719 while (s < send || (s == send && isSPACE(*s))) {
729 if (strchr(PL_chopset, *s))
734 itemsize = chophere - item;
735 sv_pos_b2u(sv, &itemsize);
741 item_is_utf8 = FALSE;
742 if (itemsize <= fieldsize) {
743 const char *const send = chophere = s + itemsize;
756 itemsize = fieldsize;
757 send = chophere = s + itemsize;
758 while (s < send || (s == send && isSPACE(*s))) {
768 if (strchr(PL_chopset, *s))
773 itemsize = chophere - item;
779 arg = fieldsize - itemsize;
788 arg = fieldsize - itemsize;
802 /* convert to_copy from chars to bytes */
806 to_copy = s - source;
812 const char *s = chophere;
826 const bool oneline = fpc[-1] == FF_LINESNGL;
827 const char *s = item = SvPV_const(sv, len);
828 const char *const send = s + len;
830 item_is_utf8 = DO_UTF8(sv);
841 to_copy = s - SvPVX_const(sv) - 1;
855 /* append to_copy bytes from source to PL_formstring.
856 * item_is_utf8 implies source is utf8.
857 * if trans, translate certain characters during the copy */
862 SvCUR_set(PL_formtarget,
863 t - SvPVX_const(PL_formtarget));
865 if (targ_is_utf8 && !item_is_utf8) {
866 source = tmp = bytes_to_utf8(source, &to_copy);
868 if (item_is_utf8 && !targ_is_utf8) {
870 /* Upgrade targ to UTF8, and then we reduce it to
871 a problem we have a simple solution for.
872 Don't need get magic. */
873 sv_utf8_upgrade_nomg(PL_formtarget);
875 /* re-calculate linemark */
876 s = (U8*)SvPVX(PL_formtarget);
877 /* the bytes we initially allocated to append the
878 * whole line may have been gobbled up during the
879 * upgrade, so allocate a whole new line's worth
884 linemark = s - (U8*)SvPVX(PL_formtarget);
886 /* Easy. They agree. */
887 assert (item_is_utf8 == targ_is_utf8);
890 /* @* and ^* are the only things that can exceed
891 * the linemax, so grow by the output size, plus
892 * a whole new form's worth in case of any further
894 grow = linemax + to_copy;
896 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
897 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
899 Copy(source, t, to_copy, char);
901 /* blank out ~ or control chars, depending on trans.
902 * works on bytes not chars, so relies on not
903 * matching utf8 continuation bytes */
905 U8 *send = s + to_copy;
908 if (trans == '~' ? (ch == '~') :
921 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
929 #if defined(USE_LONG_DOUBLE)
931 ((arg & FORM_NUM_POINT) ?
932 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
935 ((arg & FORM_NUM_POINT) ?
936 "%#0*.*f" : "%0*.*f");
941 #if defined(USE_LONG_DOUBLE)
943 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
946 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
949 /* If the field is marked with ^ and the value is undefined,
951 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
959 /* overflow evidence */
960 if (num_overflow(value, fieldsize, arg)) {
966 /* Formats aren't yet marked for locales, so assume "yes". */
968 STORE_NUMERIC_STANDARD_SET_LOCAL();
969 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
970 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
971 RESTORE_NUMERIC_STANDARD();
978 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
986 if (arg) { /* repeat until fields exhausted? */
992 t = SvPVX(PL_formtarget) + linemark;
999 const char *s = chophere;
1000 const char *send = item + len;
1002 while (isSPACE(*s) && (s < send))
1007 arg = fieldsize - itemsize;
1014 if (strnEQ(s1," ",3)) {
1015 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1026 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
1028 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1030 SvUTF8_on(PL_formtarget);
1031 FmLINES(PL_formtarget) += lines;
1033 if (fpc[-1] == FF_BLANK)
1034 RETURNOP(cLISTOP->op_first);
1046 if (PL_stack_base + *PL_markstack_ptr == SP) {
1048 if (GIMME_V == G_SCALAR)
1050 RETURNOP(PL_op->op_next->op_next);
1052 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1053 Perl_pp_pushmark(aTHX); /* push dst */
1054 Perl_pp_pushmark(aTHX); /* push src */
1055 ENTER_with_name("grep"); /* enter outer scope */
1058 if (PL_op->op_private & OPpGREP_LEX)
1059 SAVESPTR(PAD_SVl(PL_op->op_targ));
1062 ENTER_with_name("grep_item"); /* enter inner scope */
1065 src = PL_stack_base[*PL_markstack_ptr];
1067 if (PL_op->op_private & OPpGREP_LEX)
1068 PAD_SVl(PL_op->op_targ) = src;
1073 if (PL_op->op_type == OP_MAPSTART)
1074 Perl_pp_pushmark(aTHX); /* push top */
1075 return ((LOGOP*)PL_op->op_next)->op_other;
1081 const I32 gimme = GIMME_V;
1082 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1088 /* first, move source pointer to the next item in the source list */
1089 ++PL_markstack_ptr[-1];
1091 /* if there are new items, push them into the destination list */
1092 if (items && gimme != G_VOID) {
1093 /* might need to make room back there first */
1094 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1095 /* XXX this implementation is very pessimal because the stack
1096 * is repeatedly extended for every set of items. Is possible
1097 * to do this without any stack extension or copying at all
1098 * by maintaining a separate list over which the map iterates
1099 * (like foreach does). --gsar */
1101 /* everything in the stack after the destination list moves
1102 * towards the end the stack by the amount of room needed */
1103 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1105 /* items to shift up (accounting for the moved source pointer) */
1106 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1108 /* This optimization is by Ben Tilly and it does
1109 * things differently from what Sarathy (gsar)
1110 * is describing. The downside of this optimization is
1111 * that leaves "holes" (uninitialized and hopefully unused areas)
1112 * to the Perl stack, but on the other hand this
1113 * shouldn't be a problem. If Sarathy's idea gets
1114 * implemented, this optimization should become
1115 * irrelevant. --jhi */
1117 shift = count; /* Avoid shifting too often --Ben Tilly */
1121 dst = (SP += shift);
1122 PL_markstack_ptr[-1] += shift;
1123 *PL_markstack_ptr += shift;
1127 /* copy the new items down to the destination list */
1128 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1129 if (gimme == G_ARRAY) {
1130 /* add returned items to the collection (making mortal copies
1131 * if necessary), then clear the current temps stack frame
1132 * *except* for those items. We do this splicing the items
1133 * into the start of the tmps frame (so some items may be on
1134 * the tmps stack twice), then moving PL_tmps_floor above
1135 * them, then freeing the frame. That way, the only tmps that
1136 * accumulate over iterations are the return values for map.
1137 * We have to do to this way so that everything gets correctly
1138 * freed if we die during the map.
1142 /* make space for the slice */
1143 EXTEND_MORTAL(items);
1144 tmpsbase = PL_tmps_floor + 1;
1145 Move(PL_tmps_stack + tmpsbase,
1146 PL_tmps_stack + tmpsbase + items,
1147 PL_tmps_ix - PL_tmps_floor,
1149 PL_tmps_ix += items;
1154 sv = sv_mortalcopy(sv);
1156 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1158 /* clear the stack frame except for the items */
1159 PL_tmps_floor += items;
1161 /* FREETMPS may have cleared the TEMP flag on some of the items */
1164 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1167 /* scalar context: we don't care about which values map returns
1168 * (we use undef here). And so we certainly don't want to do mortal
1169 * copies of meaningless values. */
1170 while (items-- > 0) {
1172 *dst-- = &PL_sv_undef;
1180 LEAVE_with_name("grep_item"); /* exit inner scope */
1183 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1185 (void)POPMARK; /* pop top */
1186 LEAVE_with_name("grep"); /* exit outer scope */
1187 (void)POPMARK; /* pop src */
1188 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1189 (void)POPMARK; /* pop dst */
1190 SP = PL_stack_base + POPMARK; /* pop original mark */
1191 if (gimme == G_SCALAR) {
1192 if (PL_op->op_private & OPpGREP_LEX) {
1193 SV* sv = sv_newmortal();
1194 sv_setiv(sv, items);
1202 else if (gimme == G_ARRAY)
1209 ENTER_with_name("grep_item"); /* enter inner scope */
1212 /* set $_ to the new source item */
1213 src = PL_stack_base[PL_markstack_ptr[-1]];
1215 if (PL_op->op_private & OPpGREP_LEX)
1216 PAD_SVl(PL_op->op_targ) = src;
1220 RETURNOP(cLOGOP->op_other);
1229 if (GIMME == G_ARRAY)
1231 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1232 return cLOGOP->op_other;
1242 if (GIMME == G_ARRAY) {
1243 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1247 SV * const targ = PAD_SV(PL_op->op_targ);
1250 if (PL_op->op_private & OPpFLIP_LINENUM) {
1251 if (GvIO(PL_last_in_gv)) {
1252 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1255 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1257 flip = SvIV(sv) == SvIV(GvSV(gv));
1263 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1264 if (PL_op->op_flags & OPf_SPECIAL) {
1272 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1275 sv_setpvs(TARG, "");
1281 /* This code tries to decide if "$left .. $right" should use the
1282 magical string increment, or if the range is numeric (we make
1283 an exception for .."0" [#18165]). AMS 20021031. */
1285 #define RANGE_IS_NUMERIC(left,right) ( \
1286 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1287 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1288 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1289 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1290 && (!SvOK(right) || looks_like_number(right))))
1296 if (GIMME == G_ARRAY) {
1302 if (RANGE_IS_NUMERIC(left,right)) {
1305 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1306 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1307 DIE(aTHX_ "Range iterator outside integer range");
1308 i = SvIV_nomg(left);
1309 max = SvIV_nomg(right);
1318 SV * const sv = sv_2mortal(newSViv(i++));
1324 const char * const lpv = SvPV_nomg_const(left, llen);
1325 const char * const tmps = SvPV_nomg_const(right, len);
1327 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1328 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1330 if (strEQ(SvPVX_const(sv),tmps))
1332 sv = sv_2mortal(newSVsv(sv));
1339 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1343 if (PL_op->op_private & OPpFLIP_LINENUM) {
1344 if (GvIO(PL_last_in_gv)) {
1345 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1348 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1349 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1357 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1358 sv_catpvs(targ, "E0");
1368 static const char * const context_name[] = {
1370 NULL, /* CXt_WHEN never actually needs "block" */
1371 NULL, /* CXt_BLOCK never actually needs "block" */
1372 NULL, /* CXt_GIVEN never actually needs "block" */
1373 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1374 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1375 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1376 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1384 S_dopoptolabel(pTHX_ const char *label)
1389 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1391 for (i = cxstack_ix; i >= 0; i--) {
1392 register const PERL_CONTEXT * const cx = &cxstack[i];
1393 switch (CxTYPE(cx)) {
1399 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1400 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1401 if (CxTYPE(cx) == CXt_NULL)
1404 case CXt_LOOP_LAZYIV:
1405 case CXt_LOOP_LAZYSV:
1407 case CXt_LOOP_PLAIN:
1409 const char *cx_label = CxLABEL(cx);
1410 if (!cx_label || strNE(label, cx_label) ) {
1411 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1412 (long)i, cx_label));
1415 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1426 Perl_dowantarray(pTHX)
1429 const I32 gimme = block_gimme();
1430 return (gimme == G_VOID) ? G_SCALAR : gimme;
1434 Perl_block_gimme(pTHX)
1437 const I32 cxix = dopoptosub(cxstack_ix);
1441 switch (cxstack[cxix].blk_gimme) {
1449 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1456 Perl_is_lvalue_sub(pTHX)
1459 const I32 cxix = dopoptosub(cxstack_ix);
1460 assert(cxix >= 0); /* We should only be called from inside subs */
1462 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1463 return CxLVAL(cxstack + cxix);
1468 /* only used by PUSHSUB */
1470 Perl_was_lvalue_sub(pTHX)
1473 const I32 cxix = dopoptosub(cxstack_ix-1);
1474 assert(cxix >= 0); /* We should only be called from inside subs */
1476 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1477 return CxLVAL(cxstack + cxix);
1483 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1488 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1490 for (i = startingblock; i >= 0; i--) {
1491 register const PERL_CONTEXT * const cx = &cxstk[i];
1492 switch (CxTYPE(cx)) {
1498 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1506 S_dopoptoeval(pTHX_ I32 startingblock)
1510 for (i = startingblock; i >= 0; i--) {
1511 register const PERL_CONTEXT *cx = &cxstack[i];
1512 switch (CxTYPE(cx)) {
1516 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1524 S_dopoptoloop(pTHX_ I32 startingblock)
1528 for (i = startingblock; i >= 0; i--) {
1529 register const PERL_CONTEXT * const cx = &cxstack[i];
1530 switch (CxTYPE(cx)) {
1536 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1537 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1538 if ((CxTYPE(cx)) == CXt_NULL)
1541 case CXt_LOOP_LAZYIV:
1542 case CXt_LOOP_LAZYSV:
1544 case CXt_LOOP_PLAIN:
1545 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1553 S_dopoptogiven(pTHX_ I32 startingblock)
1557 for (i = startingblock; i >= 0; i--) {
1558 register const PERL_CONTEXT *cx = &cxstack[i];
1559 switch (CxTYPE(cx)) {
1563 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1565 case CXt_LOOP_PLAIN:
1566 assert(!CxFOREACHDEF(cx));
1568 case CXt_LOOP_LAZYIV:
1569 case CXt_LOOP_LAZYSV:
1571 if (CxFOREACHDEF(cx)) {
1572 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1581 S_dopoptowhen(pTHX_ I32 startingblock)
1585 for (i = startingblock; i >= 0; i--) {
1586 register const PERL_CONTEXT *cx = &cxstack[i];
1587 switch (CxTYPE(cx)) {
1591 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1599 Perl_dounwind(pTHX_ I32 cxix)
1604 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1607 while (cxstack_ix > cxix) {
1609 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1610 DEBUG_CX("UNWIND"); \
1611 /* Note: we don't need to restore the base context info till the end. */
1612 switch (CxTYPE(cx)) {
1615 continue; /* not break */
1623 case CXt_LOOP_LAZYIV:
1624 case CXt_LOOP_LAZYSV:
1626 case CXt_LOOP_PLAIN:
1637 PERL_UNUSED_VAR(optype);
1641 Perl_qerror(pTHX_ SV *err)
1645 PERL_ARGS_ASSERT_QERROR;
1648 if (PL_in_eval & EVAL_KEEPERR) {
1649 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1653 sv_catsv(ERRSV, err);
1656 sv_catsv(PL_errors, err);
1658 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1660 ++PL_parser->error_count;
1664 Perl_die_unwind(pTHX_ SV *msv)
1667 SV *exceptsv = sv_mortalcopy(msv);
1668 U8 in_eval = PL_in_eval;
1669 PERL_ARGS_ASSERT_DIE_UNWIND;
1676 * Historically, perl used to set ERRSV ($@) early in the die
1677 * process and rely on it not getting clobbered during unwinding.
1678 * That sucked, because it was liable to get clobbered, so the
1679 * setting of ERRSV used to emit the exception from eval{} has
1680 * been moved to much later, after unwinding (see just before
1681 * JMPENV_JUMP below). However, some modules were relying on the
1682 * early setting, by examining $@ during unwinding to use it as
1683 * a flag indicating whether the current unwinding was caused by
1684 * an exception. It was never a reliable flag for that purpose,
1685 * being totally open to false positives even without actual
1686 * clobberage, but was useful enough for production code to
1687 * semantically rely on it.
1689 * We'd like to have a proper introspective interface that
1690 * explicitly describes the reason for whatever unwinding
1691 * operations are currently in progress, so that those modules
1692 * work reliably and $@ isn't further overloaded. But we don't
1693 * have one yet. In its absence, as a stopgap measure, ERRSV is
1694 * now *additionally* set here, before unwinding, to serve as the
1695 * (unreliable) flag that it used to.
1697 * This behaviour is temporary, and should be removed when a
1698 * proper way to detect exceptional unwinding has been developed.
1699 * As of 2010-12, the authors of modules relying on the hack
1700 * are aware of the issue, because the modules failed on
1701 * perls 5.13.{1..7} which had late setting of $@ without this
1702 * early-setting hack.
1704 if (!(in_eval & EVAL_KEEPERR)) {
1705 SvTEMP_off(exceptsv);
1706 sv_setsv(ERRSV, exceptsv);
1709 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1710 && PL_curstackinfo->si_prev)
1719 register PERL_CONTEXT *cx;
1722 JMPENV *restartjmpenv;
1725 if (cxix < cxstack_ix)
1728 POPBLOCK(cx,PL_curpm);
1729 if (CxTYPE(cx) != CXt_EVAL) {
1731 const char* message = SvPVx_const(exceptsv, msglen);
1732 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1733 PerlIO_write(Perl_error_log, message, msglen);
1737 namesv = cx->blk_eval.old_namesv;
1738 oldcop = cx->blk_oldcop;
1739 restartjmpenv = cx->blk_eval.cur_top_env;
1740 restartop = cx->blk_eval.retop;
1742 if (gimme == G_SCALAR)
1743 *++newsp = &PL_sv_undef;
1744 PL_stack_sp = newsp;
1748 /* LEAVE could clobber PL_curcop (see save_re_context())
1749 * XXX it might be better to find a way to avoid messing with
1750 * PL_curcop in save_re_context() instead, but this is a more
1751 * minimal fix --GSAR */
1754 if (optype == OP_REQUIRE) {
1755 (void)hv_store(GvHVn(PL_incgv),
1756 SvPVX_const(namesv),
1757 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1759 /* note that unlike pp_entereval, pp_require isn't
1760 * supposed to trap errors. So now that we've popped the
1761 * EVAL that pp_require pushed, and processed the error
1762 * message, rethrow the error */
1763 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1764 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1767 if (in_eval & EVAL_KEEPERR) {
1768 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1772 sv_setsv(ERRSV, exceptsv);
1774 PL_restartjmpenv = restartjmpenv;
1775 PL_restartop = restartop;
1781 write_to_stderr(exceptsv);
1788 dVAR; dSP; dPOPTOPssrl;
1789 if (SvTRUE(left) != SvTRUE(right))
1796 =for apidoc caller_cx
1798 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1799 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1800 information returned to Perl by C<caller>. Note that XSUBs don't get a
1801 stack frame, so C<caller_cx(0, NULL)> will return information for the
1802 immediately-surrounding Perl code.
1804 This function skips over the automatic calls to C<&DB::sub> made on the
1805 behalf of the debugger. If the stack frame requested was a sub called by
1806 C<DB::sub>, the return value will be the frame for the call to
1807 C<DB::sub>, since that has the correct line number/etc. for the call
1808 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1809 frame for the sub call itself.
1814 const PERL_CONTEXT *
1815 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1817 register I32 cxix = dopoptosub(cxstack_ix);
1818 register const PERL_CONTEXT *cx;
1819 register const PERL_CONTEXT *ccstack = cxstack;
1820 const PERL_SI *top_si = PL_curstackinfo;
1823 /* we may be in a higher stacklevel, so dig down deeper */
1824 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1825 top_si = top_si->si_prev;
1826 ccstack = top_si->si_cxstack;
1827 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1831 /* caller() should not report the automatic calls to &DB::sub */
1832 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1833 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1837 cxix = dopoptosub_at(ccstack, cxix - 1);
1840 cx = &ccstack[cxix];
1841 if (dbcxp) *dbcxp = cx;
1843 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1844 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1845 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1846 field below is defined for any cx. */
1847 /* caller() should not report the automatic calls to &DB::sub */
1848 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1849 cx = &ccstack[dbcxix];
1859 register const PERL_CONTEXT *cx;
1860 const PERL_CONTEXT *dbcx;
1862 const HEK *stash_hek;
1864 bool has_arg = MAXARG && TOPs;
1872 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1874 if (GIMME != G_ARRAY) {
1881 stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop));
1882 if (GIMME != G_ARRAY) {
1885 PUSHs(&PL_sv_undef);
1888 sv_sethek(TARG, stash_hek);
1897 PUSHs(&PL_sv_undef);
1900 sv_sethek(TARG, stash_hek);
1903 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1904 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1907 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1908 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1909 /* So is ccstack[dbcxix]. */
1911 SV * const sv = newSV(0);
1912 gv_efullname3(sv, cvgv, NULL);
1914 PUSHs(boolSV(CxHASARGS(cx)));
1917 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1918 PUSHs(boolSV(CxHASARGS(cx)));
1922 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1925 gimme = (I32)cx->blk_gimme;
1926 if (gimme == G_VOID)
1927 PUSHs(&PL_sv_undef);
1929 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1930 if (CxTYPE(cx) == CXt_EVAL) {
1932 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1933 PUSHs(cx->blk_eval.cur_text);
1937 else if (cx->blk_eval.old_namesv) {
1938 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1941 /* eval BLOCK (try blocks have old_namesv == 0) */
1943 PUSHs(&PL_sv_undef);
1944 PUSHs(&PL_sv_undef);
1948 PUSHs(&PL_sv_undef);
1949 PUSHs(&PL_sv_undef);
1951 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1952 && CopSTASH_eq(PL_curcop, PL_debstash))
1954 AV * const ary = cx->blk_sub.argarray;
1955 const int off = AvARRAY(ary) - AvALLOC(ary);
1957 Perl_init_dbargs(aTHX);
1959 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1960 av_extend(PL_dbargs, AvFILLp(ary) + off);
1961 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1962 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1964 /* XXX only hints propagated via op_private are currently
1965 * visible (others are not easily accessible, since they
1966 * use the global PL_hints) */
1967 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1970 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1972 if (old_warnings == pWARN_NONE ||
1973 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1974 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1975 else if (old_warnings == pWARN_ALL ||
1976 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1977 /* Get the bit mask for $warnings::Bits{all}, because
1978 * it could have been extended by warnings::register */
1980 HV * const bits = get_hv("warnings::Bits", 0);
1981 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1982 mask = newSVsv(*bits_all);
1985 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1989 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1993 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1994 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2003 const char * const tmps =
2004 (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
2005 sv_reset(tmps, CopSTASH(PL_curcop));
2010 /* like pp_nextstate, but used instead when the debugger is active */
2015 PL_curcop = (COP*)PL_op;
2016 TAINT_NOT; /* Each statement is presumed innocent */
2017 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2022 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2023 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2026 register PERL_CONTEXT *cx;
2027 const I32 gimme = G_ARRAY;
2029 GV * const gv = PL_DBgv;
2030 register CV * const cv = GvCV(gv);
2033 DIE(aTHX_ "No DB::DB routine defined");
2035 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2036 /* don't do recursive DB::DB call */
2051 (void)(*CvXSUB(cv))(aTHX_ cv);
2058 PUSHBLOCK(cx, CXt_SUB, SP);
2060 cx->blk_sub.retop = PL_op->op_next;
2063 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2064 RETURNOP(CvSTART(cv));
2072 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2075 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2077 if (flags & SVs_PADTMP) {
2078 flags &= ~SVs_PADTMP;
2081 if (gimme == G_SCALAR) {
2083 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2084 ? *SP : sv_mortalcopy(*SP);
2086 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2089 *++MARK = &PL_sv_undef;
2093 else if (gimme == G_ARRAY) {
2094 /* in case LEAVE wipes old return values */
2095 while (++MARK <= SP) {
2096 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2099 *++newsp = sv_mortalcopy(*MARK);
2100 TAINT_NOT; /* Each item is independent */
2103 /* When this function was called with MARK == newsp, we reach this
2104 * point with SP == newsp. */
2113 register PERL_CONTEXT *cx;
2114 I32 gimme = GIMME_V;
2116 ENTER_with_name("block");
2119 PUSHBLOCK(cx, CXt_BLOCK, SP);
2127 register PERL_CONTEXT *cx;
2132 if (PL_op->op_flags & OPf_SPECIAL) {
2133 cx = &cxstack[cxstack_ix];
2134 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2139 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2142 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2143 PL_curpm = newpm; /* Don't pop $1 et al till now */
2145 LEAVE_with_name("block");
2153 register PERL_CONTEXT *cx;
2154 const I32 gimme = GIMME_V;
2155 void *itervar; /* location of the iteration variable */
2156 U8 cxtype = CXt_LOOP_FOR;
2158 ENTER_with_name("loop1");
2161 if (PL_op->op_targ) { /* "my" variable */
2162 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2163 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2164 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2165 SVs_PADSTALE, SVs_PADSTALE);
2167 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2169 itervar = PL_comppad;
2171 itervar = &PAD_SVl(PL_op->op_targ);
2174 else { /* symbol table variable */
2175 GV * const gv = MUTABLE_GV(POPs);
2176 SV** svp = &GvSV(gv);
2177 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2179 itervar = (void *)gv;
2182 if (PL_op->op_private & OPpITER_DEF)
2183 cxtype |= CXp_FOR_DEF;
2185 ENTER_with_name("loop2");
2187 PUSHBLOCK(cx, cxtype, SP);
2188 PUSHLOOP_FOR(cx, itervar, MARK);
2189 if (PL_op->op_flags & OPf_STACKED) {
2190 SV *maybe_ary = POPs;
2191 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2193 SV * const right = maybe_ary;
2196 if (RANGE_IS_NUMERIC(sv,right)) {
2197 cx->cx_type &= ~CXTYPEMASK;
2198 cx->cx_type |= CXt_LOOP_LAZYIV;
2199 /* Make sure that no-one re-orders cop.h and breaks our
2201 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2202 #ifdef NV_PRESERVES_UV
2203 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2204 (SvNV_nomg(sv) > (NV)IV_MAX)))
2206 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2207 (SvNV_nomg(right) < (NV)IV_MIN))))
2209 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2211 ((SvNV_nomg(sv) > 0) &&
2212 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2213 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2215 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2217 ((SvNV_nomg(right) > 0) &&
2218 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2219 (SvNV_nomg(right) > (NV)UV_MAX))
2222 DIE(aTHX_ "Range iterator outside integer range");
2223 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2224 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2226 /* for correct -Dstv display */
2227 cx->blk_oldsp = sp - PL_stack_base;
2231 cx->cx_type &= ~CXTYPEMASK;
2232 cx->cx_type |= CXt_LOOP_LAZYSV;
2233 /* Make sure that no-one re-orders cop.h and breaks our
2235 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2236 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2237 cx->blk_loop.state_u.lazysv.end = right;
2238 SvREFCNT_inc(right);
2239 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2240 /* This will do the upgrade to SVt_PV, and warn if the value
2241 is uninitialised. */
2242 (void) SvPV_nolen_const(right);
2243 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2244 to replace !SvOK() with a pointer to "". */
2246 SvREFCNT_dec(right);
2247 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2251 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2252 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2253 SvREFCNT_inc(maybe_ary);
2254 cx->blk_loop.state_u.ary.ix =
2255 (PL_op->op_private & OPpITER_REVERSED) ?
2256 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2260 else { /* iterating over items on the stack */
2261 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2262 if (PL_op->op_private & OPpITER_REVERSED) {
2263 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2266 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2276 register PERL_CONTEXT *cx;
2277 const I32 gimme = GIMME_V;
2279 ENTER_with_name("loop1");
2281 ENTER_with_name("loop2");
2283 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2284 PUSHLOOP_PLAIN(cx, SP);
2292 register PERL_CONTEXT *cx;
2299 assert(CxTYPE_is_LOOP(cx));
2301 newsp = PL_stack_base + cx->blk_loop.resetsp;
2304 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2307 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2308 PL_curpm = newpm; /* ... and pop $1 et al */
2310 LEAVE_with_name("loop2");
2311 LEAVE_with_name("loop1");
2317 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2318 PERL_CONTEXT *cx, PMOP *newpm)
2320 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2321 if (gimme == G_SCALAR) {
2322 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2324 const char *what = NULL;
2326 assert(MARK+1 == SP);
2327 if ((SvPADTMP(TOPs) ||
2328 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2331 !SvSMAGICAL(TOPs)) {
2333 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2334 : "a readonly value" : "a temporary";
2339 /* sub:lvalue{} will take us here. */
2348 "Can't return %s from lvalue subroutine", what
2353 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2354 *++newsp = SvREFCNT_inc(*SP);
2361 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2366 *++newsp = &PL_sv_undef;
2368 if (CxLVAL(cx) & OPpDEREF) {
2371 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2375 else if (gimme == G_ARRAY) {
2376 assert (!(CxLVAL(cx) & OPpDEREF));
2377 if (ref || !CxLVAL(cx))
2378 while (++MARK <= SP)
2382 : ref && SvFLAGS(*MARK) & SVs_PADTMP
2383 ? sv_mortalcopy(*MARK)
2384 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2385 else while (++MARK <= SP) {
2386 if (*MARK != &PL_sv_undef
2388 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2393 /* Might be flattened array after $#array = */
2401 "Can't return a %s from lvalue subroutine",
2402 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2408 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2411 PL_stack_sp = newsp;
2417 register PERL_CONTEXT *cx;
2418 bool popsub2 = FALSE;
2419 bool clear_errsv = FALSE;
2429 const I32 cxix = dopoptosub(cxstack_ix);
2432 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2433 * sort block, which is a CXt_NULL
2436 PL_stack_base[1] = *PL_stack_sp;
2437 PL_stack_sp = PL_stack_base + 1;
2441 DIE(aTHX_ "Can't return outside a subroutine");
2443 if (cxix < cxstack_ix)
2446 if (CxMULTICALL(&cxstack[cxix])) {
2447 gimme = cxstack[cxix].blk_gimme;
2448 if (gimme == G_VOID)
2449 PL_stack_sp = PL_stack_base;
2450 else if (gimme == G_SCALAR) {
2451 PL_stack_base[1] = *PL_stack_sp;
2452 PL_stack_sp = PL_stack_base + 1;
2458 switch (CxTYPE(cx)) {
2461 lval = !!CvLVALUE(cx->blk_sub.cv);
2462 retop = cx->blk_sub.retop;
2463 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2466 if (!(PL_in_eval & EVAL_KEEPERR))
2469 namesv = cx->blk_eval.old_namesv;
2470 retop = cx->blk_eval.retop;
2473 if (optype == OP_REQUIRE &&
2474 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2476 /* Unassume the success we assumed earlier. */
2477 (void)hv_delete(GvHVn(PL_incgv),
2478 SvPVX_const(namesv),
2479 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2481 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2486 retop = cx->blk_sub.retop;
2489 DIE(aTHX_ "panic: return");
2493 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2495 if (gimme == G_SCALAR) {
2498 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2499 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2500 *++newsp = SvREFCNT_inc(*SP);
2505 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2507 *++newsp = sv_mortalcopy(sv);
2511 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
2515 *++newsp = sv_mortalcopy(*SP);
2518 *++newsp = sv_mortalcopy(*SP);
2521 *++newsp = &PL_sv_undef;
2523 else if (gimme == G_ARRAY) {
2524 while (++MARK <= SP) {
2525 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2526 ? *MARK : sv_mortalcopy(*MARK);
2527 TAINT_NOT; /* Each item is independent */
2530 PL_stack_sp = newsp;
2534 /* Stack values are safe: */
2537 POPSUB(cx,sv); /* release CV and @_ ... */
2541 PL_curpm = newpm; /* ... and pop $1 et al */
2550 /* This duplicates parts of pp_leavesub, so that it can share code with
2558 register PERL_CONTEXT *cx;
2561 if (CxMULTICALL(&cxstack[cxstack_ix]))
2565 cxstack_ix++; /* temporarily protect top context */
2569 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2573 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2574 PL_curpm = newpm; /* ... and pop $1 et al */
2577 return cx->blk_sub.retop;
2584 register PERL_CONTEXT *cx;
2595 if (PL_op->op_flags & OPf_SPECIAL) {
2596 cxix = dopoptoloop(cxstack_ix);
2598 DIE(aTHX_ "Can't \"last\" outside a loop block");
2601 cxix = dopoptolabel(cPVOP->op_pv);
2603 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2605 if (cxix < cxstack_ix)
2609 cxstack_ix++; /* temporarily protect top context */
2611 switch (CxTYPE(cx)) {
2612 case CXt_LOOP_LAZYIV:
2613 case CXt_LOOP_LAZYSV:
2615 case CXt_LOOP_PLAIN:
2617 newsp = PL_stack_base + cx->blk_loop.resetsp;
2618 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2622 nextop = cx->blk_sub.retop;
2626 nextop = cx->blk_eval.retop;
2630 nextop = cx->blk_sub.retop;
2633 DIE(aTHX_ "panic: last");
2637 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2638 pop2 == CXt_SUB ? SVs_TEMP : 0);
2643 /* Stack values are safe: */
2645 case CXt_LOOP_LAZYIV:
2646 case CXt_LOOP_PLAIN:
2647 case CXt_LOOP_LAZYSV:
2649 POPLOOP(cx); /* release loop vars ... */
2653 POPSUB(cx,sv); /* release CV and @_ ... */
2656 PL_curpm = newpm; /* ... and pop $1 et al */
2659 PERL_UNUSED_VAR(optype);
2660 PERL_UNUSED_VAR(gimme);
2668 register PERL_CONTEXT *cx;
2671 if (PL_op->op_flags & OPf_SPECIAL) {
2672 cxix = dopoptoloop(cxstack_ix);
2674 DIE(aTHX_ "Can't \"next\" outside a loop block");
2677 cxix = dopoptolabel(cPVOP->op_pv);
2679 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2681 if (cxix < cxstack_ix)
2684 /* clear off anything above the scope we're re-entering, but
2685 * save the rest until after a possible continue block */
2686 inner = PL_scopestack_ix;
2688 if (PL_scopestack_ix < inner)
2689 leave_scope(PL_scopestack[PL_scopestack_ix]);
2690 PL_curcop = cx->blk_oldcop;
2691 return (cx)->blk_loop.my_op->op_nextop;
2698 register PERL_CONTEXT *cx;
2702 if (PL_op->op_flags & OPf_SPECIAL) {
2703 cxix = dopoptoloop(cxstack_ix);
2705 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2708 cxix = dopoptolabel(cPVOP->op_pv);
2710 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2712 if (cxix < cxstack_ix)
2715 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2716 if (redo_op->op_type == OP_ENTER) {
2717 /* pop one less context to avoid $x being freed in while (my $x..) */
2719 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2720 redo_op = redo_op->op_next;
2724 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2725 LEAVE_SCOPE(oldsave);
2727 PL_curcop = cx->blk_oldcop;
2732 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2736 static const char too_deep[] = "Target of goto is too deeply nested";
2738 PERL_ARGS_ASSERT_DOFINDLABEL;
2741 Perl_croak(aTHX_ too_deep);
2742 if (o->op_type == OP_LEAVE ||
2743 o->op_type == OP_SCOPE ||
2744 o->op_type == OP_LEAVELOOP ||
2745 o->op_type == OP_LEAVESUB ||
2746 o->op_type == OP_LEAVETRY)
2748 *ops++ = cUNOPo->op_first;
2750 Perl_croak(aTHX_ too_deep);
2753 if (o->op_flags & OPf_KIDS) {
2755 /* First try all the kids at this level, since that's likeliest. */
2756 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2757 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2758 const char *kid_label = CopLABEL(kCOP);
2759 if (kid_label && strEQ(kid_label, label))
2763 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2764 if (kid == PL_lastgotoprobe)
2766 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2769 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2770 ops[-1]->op_type == OP_DBSTATE)
2775 if ((o = dofindlabel(kid, label, ops, oplimit)))
2788 register PERL_CONTEXT *cx;
2789 #define GOTO_DEPTH 64
2790 OP *enterops[GOTO_DEPTH];
2791 const char *label = NULL;
2792 const bool do_dump = (PL_op->op_type == OP_DUMP);
2793 static const char must_have_label[] = "goto must have label";
2795 if (PL_op->op_flags & OPf_STACKED) {
2796 SV * const sv = POPs;
2798 /* This egregious kludge implements goto &subroutine */
2799 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2801 register PERL_CONTEXT *cx;
2802 CV *cv = MUTABLE_CV(SvRV(sv));
2809 if (!CvROOT(cv) && !CvXSUB(cv)) {
2810 const GV * const gv = CvGV(cv);
2814 /* autoloaded stub? */
2815 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2817 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2819 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2820 if (autogv && (cv = GvCV(autogv)))
2822 tmpstr = sv_newmortal();
2823 gv_efullname3(tmpstr, gv, NULL);
2824 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2826 DIE(aTHX_ "Goto undefined subroutine");
2829 /* First do some returnish stuff. */
2830 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2832 cxix = dopoptosub(cxstack_ix);
2834 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2835 if (cxix < cxstack_ix)
2839 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2840 if (CxTYPE(cx) == CXt_EVAL) {
2842 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2844 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2846 else if (CxMULTICALL(cx))
2847 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2848 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2849 /* put @_ back onto stack */
2850 AV* av = cx->blk_sub.argarray;
2852 items = AvFILLp(av) + 1;
2853 EXTEND(SP, items+1); /* @_ could have been extended. */
2854 Copy(AvARRAY(av), SP + 1, items, SV*);
2855 SvREFCNT_dec(GvAV(PL_defgv));
2856 GvAV(PL_defgv) = cx->blk_sub.savearray;
2858 /* abandon @_ if it got reified */
2863 av_extend(av, items-1);
2865 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2868 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2869 AV* const av = GvAV(PL_defgv);
2870 items = AvFILLp(av) + 1;
2871 EXTEND(SP, items+1); /* @_ could have been extended. */
2872 Copy(AvARRAY(av), SP + 1, items, SV*);
2876 if (CxTYPE(cx) == CXt_SUB &&
2877 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2878 SvREFCNT_dec(cx->blk_sub.cv);
2879 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2880 LEAVE_SCOPE(oldsave);
2882 /* Now do some callish stuff. */
2884 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2886 OP* const retop = cx->blk_sub.retop;
2887 SV **newsp PERL_UNUSED_DECL;
2888 I32 gimme PERL_UNUSED_DECL;
2891 for (index=0; index<items; index++)
2892 sv_2mortal(SP[-index]);
2895 /* XS subs don't have a CxSUB, so pop it */
2896 POPBLOCK(cx, PL_curpm);
2897 /* Push a mark for the start of arglist */
2900 (void)(*CvXSUB(cv))(aTHX_ cv);
2905 AV* const padlist = CvPADLIST(cv);
2906 if (CxTYPE(cx) == CXt_EVAL) {
2907 PL_in_eval = CxOLD_IN_EVAL(cx);
2908 PL_eval_root = cx->blk_eval.old_eval_root;
2909 cx->cx_type = CXt_SUB;
2911 cx->blk_sub.cv = cv;
2912 cx->blk_sub.olddepth = CvDEPTH(cv);
2915 if (CvDEPTH(cv) < 2)
2916 SvREFCNT_inc_simple_void_NN(cv);
2918 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2919 sub_crush_depth(cv);
2920 pad_push(padlist, CvDEPTH(cv));
2922 PL_curcop = cx->blk_oldcop;
2924 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2927 AV *const av = MUTABLE_AV(PAD_SVl(0));
2929 cx->blk_sub.savearray = GvAV(PL_defgv);
2930 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2931 CX_CURPAD_SAVE(cx->blk_sub);
2932 cx->blk_sub.argarray = av;
2934 if (items >= AvMAX(av) + 1) {
2935 SV **ary = AvALLOC(av);
2936 if (AvARRAY(av) != ary) {
2937 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2940 if (items >= AvMAX(av) + 1) {
2941 AvMAX(av) = items - 1;
2942 Renew(ary,items+1,SV*);
2948 Copy(mark,AvARRAY(av),items,SV*);
2949 AvFILLp(av) = items - 1;
2950 assert(!AvREAL(av));
2952 /* transfer 'ownership' of refcnts to new @_ */
2962 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2963 Perl_get_db_sub(aTHX_ NULL, cv);
2965 CV * const gotocv = get_cvs("DB::goto", 0);
2967 PUSHMARK( PL_stack_sp );
2968 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2973 RETURNOP(CvSTART(cv));
2977 label = SvPV_nolen_const(sv);
2978 if (!(do_dump || *label))
2979 DIE(aTHX_ must_have_label);
2982 else if (PL_op->op_flags & OPf_SPECIAL) {
2984 DIE(aTHX_ must_have_label);
2987 label = cPVOP->op_pv;
2991 if (label && *label) {
2992 OP *gotoprobe = NULL;
2993 bool leaving_eval = FALSE;
2994 bool in_block = FALSE;
2995 PERL_CONTEXT *last_eval_cx = NULL;
2999 PL_lastgotoprobe = NULL;
3001 for (ix = cxstack_ix; ix >= 0; ix--) {
3003 switch (CxTYPE(cx)) {
3005 leaving_eval = TRUE;
3006 if (!CxTRYBLOCK(cx)) {
3007 gotoprobe = (last_eval_cx ?
3008 last_eval_cx->blk_eval.old_eval_root :
3013 /* else fall through */
3014 case CXt_LOOP_LAZYIV:
3015 case CXt_LOOP_LAZYSV:
3017 case CXt_LOOP_PLAIN:
3020 gotoprobe = cx->blk_oldcop->op_sibling;
3026 gotoprobe = cx->blk_oldcop->op_sibling;
3029 gotoprobe = PL_main_root;
3032 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3033 gotoprobe = CvROOT(cx->blk_sub.cv);
3039 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3042 DIE(aTHX_ "panic: goto");
3043 gotoprobe = PL_main_root;
3047 retop = dofindlabel(gotoprobe, label,
3048 enterops, enterops + GOTO_DEPTH);
3051 if (gotoprobe->op_sibling &&
3052 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3053 gotoprobe->op_sibling->op_sibling) {
3054 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3055 label, enterops, enterops + GOTO_DEPTH);
3060 PL_lastgotoprobe = gotoprobe;
3063 DIE(aTHX_ "Can't find label %s", label);
3065 /* if we're leaving an eval, check before we pop any frames
3066 that we're not going to punt, otherwise the error
3069 if (leaving_eval && *enterops && enterops[1]) {
3071 for (i = 1; enterops[i]; i++)
3072 if (enterops[i]->op_type == OP_ENTERITER)
3073 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3076 if (*enterops && enterops[1]) {
3077 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3079 deprecate("\"goto\" to jump into a construct");
3082 /* pop unwanted frames */
3084 if (ix < cxstack_ix) {
3091 oldsave = PL_scopestack[PL_scopestack_ix];
3092 LEAVE_SCOPE(oldsave);
3095 /* push wanted frames */
3097 if (*enterops && enterops[1]) {
3098 OP * const oldop = PL_op;
3099 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3100 for (; enterops[ix]; ix++) {
3101 PL_op = enterops[ix];
3102 /* Eventually we may want to stack the needed arguments
3103 * for each op. For now, we punt on the hard ones. */
3104 if (PL_op->op_type == OP_ENTERITER)
3105 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3106 PL_op->op_ppaddr(aTHX);
3114 if (!retop) retop = PL_main_start;
3116 PL_restartop = retop;
3117 PL_do_undump = TRUE;
3121 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3122 PL_do_undump = FALSE;
3137 anum = 0; (void)POPs;
3142 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3144 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3147 PL_exit_flags |= PERL_EXIT_EXPECTED;
3149 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3150 if (anum || !(PL_minus_c && PL_madskills))
3155 PUSHs(&PL_sv_undef);
3162 S_save_lines(pTHX_ AV *array, SV *sv)
3164 const char *s = SvPVX_const(sv);
3165 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3168 PERL_ARGS_ASSERT_SAVE_LINES;
3170 while (s && s < send) {
3172 SV * const tmpstr = newSV_type(SVt_PVMG);
3174 t = (const char *)memchr(s, '\n', send - s);
3180 sv_setpvn(tmpstr, s, t - s);
3181 av_store(array, line++, tmpstr);
3189 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3191 0 is used as continue inside eval,
3193 3 is used for a die caught by an inner eval - continue inner loop
3195 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3196 establish a local jmpenv to handle exception traps.
3201 S_docatch(pTHX_ OP *o)
3205 OP * const oldop = PL_op;
3209 assert(CATCH_GET == TRUE);
3216 assert(cxstack_ix >= 0);
3217 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3218 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3223 /* die caught by an inner eval - continue inner loop */
3224 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3225 PL_restartjmpenv = NULL;
3226 PL_op = PL_restartop;
3242 /* James Bond: Do you expect me to talk?
3243 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3245 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3246 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3248 Currently it is not used outside the core code. Best if it stays that way.
3250 Hence it's now deprecated, and will be removed.
3253 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3254 /* sv Text to convert to OP tree. */
3255 /* startop op_free() this to undo. */
3256 /* code Short string id of the caller. */
3258 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3259 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3262 /* Don't use this. It will go away without warning once the regexp engine is
3263 refactored not to use it. */
3265 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3268 dVAR; dSP; /* Make POPBLOCK work. */
3274 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3275 char *tmpbuf = tbuf;
3278 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3282 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3284 ENTER_with_name("eval");
3285 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3287 /* switch to eval mode */
3289 if (IN_PERL_COMPILETIME) {
3290 SAVECOPSTASH_FREE(&PL_compiling);
3291 CopSTASH_set(&PL_compiling, PL_curstash);
3293 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3294 SV * const sv = sv_newmortal();
3295 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3296 code, (unsigned long)++PL_evalseq,
3297 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3302 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3303 (unsigned long)++PL_evalseq);
3304 SAVECOPFILE_FREE(&PL_compiling);
3305 CopFILE_set(&PL_compiling, tmpbuf+2);
3306 SAVECOPLINE(&PL_compiling);
3307 CopLINE_set(&PL_compiling, 1);
3308 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3309 deleting the eval's FILEGV from the stash before gv_check() runs
3310 (i.e. before run-time proper). To work around the coredump that
3311 ensues, we always turn GvMULTI_on for any globals that were
3312 introduced within evals. See force_ident(). GSAR 96-10-12 */
3313 safestr = savepvn(tmpbuf, len);
3314 SAVEDELETE(PL_defstash, safestr, len);
3316 #ifdef OP_IN_REGISTER
3322 /* we get here either during compilation, or via pp_regcomp at runtime */
3323 runtime = IN_PERL_RUNTIME;
3326 runcv = find_runcv(NULL);
3328 /* At run time, we have to fetch the hints from PL_curcop. */
3329 PL_hints = PL_curcop->cop_hints;
3330 if (PL_hints & HINT_LOCALIZE_HH) {
3331 /* SAVEHINTS created a new HV in PL_hintgv, which we
3333 SvREFCNT_dec(GvHV(PL_hintgv));
3335 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3336 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3338 SAVECOMPILEWARNINGS();
3339 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3340 cophh_free(CopHINTHASH_get(&PL_compiling));
3341 /* XXX Does this need to avoid copying a label? */
3342 PL_compiling.cop_hints_hash
3343 = cophh_copy(PL_curcop->cop_hints_hash);
3347 PL_op->op_type = OP_ENTEREVAL;
3348 PL_op->op_flags = 0; /* Avoid uninit warning. */
3349 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3351 need_catch = CATCH_GET;
3355 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3357 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3358 CATCH_SET(need_catch);
3359 POPBLOCK(cx,PL_curpm);
3362 (*startop)->op_type = OP_NULL;
3363 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3364 /* XXX DAPM do this properly one year */
3365 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3366 LEAVE_with_name("eval");
3367 if (IN_PERL_COMPILETIME)
3368 CopHINTS_set(&PL_compiling, PL_hints);
3369 #ifdef OP_IN_REGISTER
3372 PERL_UNUSED_VAR(newsp);
3373 PERL_UNUSED_VAR(optype);
3375 return PL_eval_start;
3380 =for apidoc find_runcv
3382 Locate the CV corresponding to the currently executing sub or eval.
3383 If db_seqp is non_null, skip CVs that are in the DB package and populate
3384 *db_seqp with the cop sequence number at the point that the DB:: code was
3385 entered. (allows debuggers to eval in the scope of the breakpoint rather
3386 than in the scope of the debugger itself).
3392 Perl_find_runcv(pTHX_ U32 *db_seqp)
3398 *db_seqp = PL_curcop->cop_seq;
3399 for (si = PL_curstackinfo; si; si = si->si_prev) {
3401 for (ix = si->si_cxix; ix >= 0; ix--) {
3402 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3403 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3404 CV * const cv = cx->blk_sub.cv;
3405 /* skip DB:: code */
3406 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3407 *db_seqp = cx->blk_oldcop->cop_seq;
3412 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3420 /* Run yyparse() in a setjmp wrapper. Returns:
3421 * 0: yyparse() successful
3422 * 1: yyparse() failed
3426 S_try_yyparse(pTHX_ int gramtype)
3431 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3435 ret = yyparse(gramtype) ? 1 : 0;
3449 /* Compile a require/do, an eval '', or a /(?{...})/.
3450 * In the last case, startop is non-null, and contains the address of
3451 * a pointer that should be set to the just-compiled code.
3452 * outside is the lexically enclosing CV (if any) that invoked us.
3453 * Returns a bool indicating whether the compile was successful; if so,
3454 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3455 * pushes undef (also croaks if startop != NULL).
3459 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3462 OP * const saveop = PL_op;
3463 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3466 PL_in_eval = (in_require
3467 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3472 SAVESPTR(PL_compcv);
3473 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3474 CvEVAL_on(PL_compcv);
3475 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3476 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3477 cxstack[cxstack_ix].blk_gimme = gimme;
3479 CvOUTSIDE_SEQ(PL_compcv) = seq;
3480 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3482 /* set up a scratch pad */
3484 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3485 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3489 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3491 /* make sure we compile in the right package */
3493 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3494 SAVEGENERICSV(PL_curstash);
3495 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3497 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3498 SAVESPTR(PL_beginav);
3499 PL_beginav = newAV();
3500 SAVEFREESV(PL_beginav);
3501 SAVESPTR(PL_unitcheckav);
3502 PL_unitcheckav = newAV();
3503 SAVEFREESV(PL_unitcheckav);
3506 SAVEBOOL(PL_madskills);
3510 /* try to compile it */
3512 PL_eval_root = NULL;
3513 PL_curcop = &PL_compiling;
3514 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3515 PL_in_eval |= EVAL_KEEPERR;
3519 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3521 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3522 * so honour CATCH_GET and trap it here if necessary */
3524 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3526 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3527 SV **newsp; /* Used by POPBLOCK. */
3529 I32 optype; /* Used by POPEVAL. */
3534 PERL_UNUSED_VAR(newsp);
3535 PERL_UNUSED_VAR(optype);
3537 /* note that if yystatus == 3, then the EVAL CX block has already
3538 * been popped, and various vars restored */
3540 if (yystatus != 3) {
3542 op_free(PL_eval_root);
3543 PL_eval_root = NULL;
3545 SP = PL_stack_base + POPMARK; /* pop original mark */
3547 POPBLOCK(cx,PL_curpm);
3549 namesv = cx->blk_eval.old_namesv;
3553 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3557 /* If cx is still NULL, it means that we didn't go in the
3558 * POPEVAL branch. */
3559 cx = &cxstack[cxstack_ix];
3560 assert(CxTYPE(cx) == CXt_EVAL);
3561 namesv = cx->blk_eval.old_namesv;
3563 (void)hv_store(GvHVn(PL_incgv),
3564 SvPVX_const(namesv),
3565 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3567 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3570 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3573 if (yystatus != 3) {
3574 POPBLOCK(cx,PL_curpm);
3577 Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3580 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3583 if (!*(SvPVx_nolen_const(ERRSV))) {
3584 sv_setpvs(ERRSV, "Compilation error");
3587 PUSHs(&PL_sv_undef);
3591 CopLINE_set(&PL_compiling, 0);
3593 *startop = PL_eval_root;
3595 SAVEFREEOP(PL_eval_root);
3597 DEBUG_x(dump_eval());
3599 /* Register with debugger: */
3600 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3601 CV * const cv = get_cvs("DB::postponed", 0);
3605 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3607 call_sv(MUTABLE_SV(cv), G_DISCARD);
3611 if (PL_unitcheckav) {
3612 OP *es = PL_eval_start;
3613 call_list(PL_scopestack_ix, PL_unitcheckav);
3617 /* compiled okay, so do it */
3619 CvDEPTH(PL_compcv) = 1;
3620 SP = PL_stack_base + POPMARK; /* pop original mark */
3621 PL_op = saveop; /* The caller may need it. */
3622 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3629 S_check_type_and_open(pTHX_ SV *name)
3632 const char *p = SvPV_nolen_const(name);
3633 const int st_rc = PerlLIO_stat(p, &st);
3635 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3637 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3641 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3642 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3644 return PerlIO_open(p, PERL_SCRIPT_MODE);
3648 #ifndef PERL_DISABLE_PMC
3650 S_doopen_pm(pTHX_ SV *name)
3653 const char *p = SvPV_const(name, namelen);
3655 PERL_ARGS_ASSERT_DOOPEN_PM;
3657 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3658 SV *const pmcsv = sv_newmortal();
3661 SvSetSV_nosteal(pmcsv,name);
3662 sv_catpvn(pmcsv, "c", 1);
3664 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3665 return check_type_and_open(pmcsv);
3667 return check_type_and_open(name);
3670 # define doopen_pm(name) check_type_and_open(name)
3671 #endif /* !PERL_DISABLE_PMC */
3676 register PERL_CONTEXT *cx;
3683 int vms_unixname = 0;
3685 const char *tryname = NULL;
3687 const I32 gimme = GIMME_V;
3688 int filter_has_file = 0;
3689 PerlIO *tryrsfp = NULL;
3690 SV *filter_cache = NULL;
3691 SV *filter_state = NULL;
3692 SV *filter_sub = NULL;
3698 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3699 sv = sv_2mortal(new_version(sv));
3700 if (!sv_derived_from(PL_patchlevel, "version"))
3701 upg_version(PL_patchlevel, TRUE);
3702 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3703 if ( vcmp(sv,PL_patchlevel) <= 0 )
3704 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3705 SVfARG(sv_2mortal(vnormal(sv))),
3706 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3710 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3713 SV * const req = SvRV(sv);
3714 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3716 /* get the left hand term */
3717 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3719 first = SvIV(*av_fetch(lav,0,0));
3720 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3721 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3722 || av_len(lav) > 1 /* FP with > 3 digits */
3723 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3725 DIE(aTHX_ "Perl %"SVf" required--this is only "
3727 SVfARG(sv_2mortal(vnormal(req))),
3728 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3731 else { /* probably 'use 5.10' or 'use 5.8' */
3736 second = SvIV(*av_fetch(lav,1,0));
3738 second /= second >= 600 ? 100 : 10;
3739 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3740 (int)first, (int)second);
3741 upg_version(hintsv, TRUE);
3743 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3744 "--this is only %"SVf", stopped",
3745 SVfARG(sv_2mortal(vnormal(req))),
3746 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3747 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3755 name = SvPV_const(sv, len);
3756 if (!(name && len > 0 && *name))
3757 DIE(aTHX_ "Null filename used");
3758 TAINT_PROPER("require");
3762 /* The key in the %ENV hash is in the syntax of file passed as the argument
3763 * usually this is in UNIX format, but sometimes in VMS format, which
3764 * can result in a module being pulled in more than once.
3765 * To prevent this, the key must be stored in UNIX format if the VMS
3766 * name can be translated to UNIX.
3768 if ((unixname = tounixspec(name, NULL)) != NULL) {
3769 unixlen = strlen(unixname);
3775 /* if not VMS or VMS name can not be translated to UNIX, pass it
3778 unixname = (char *) name;
3781 if (PL_op->op_type == OP_REQUIRE) {
3782 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3783 unixname, unixlen, 0);
3785 if (*svp != &PL_sv_undef)
3788 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3789 "Compilation failed in require", unixname);
3793 /* prepare to compile file */
3795 if (path_is_absolute(name)) {
3796 /* At this point, name is SvPVX(sv) */
3798 tryrsfp = doopen_pm(sv);
3801 AV * const ar = GvAVn(PL_incgv);
3807 namesv = newSV_type(SVt_PV);
3808 for (i = 0; i <= AvFILL(ar); i++) {
3809 SV * const dirsv = *av_fetch(ar, i, TRUE);
3811 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3818 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3819 && !sv_isobject(loader))
3821 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3824 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3825 PTR2UV(SvRV(dirsv)), name);
3826 tryname = SvPVX_const(namesv);
3829 ENTER_with_name("call_INC");
3837 if (sv_isobject(loader))
3838 count = call_method("INC", G_ARRAY);
3840 count = call_sv(loader, G_ARRAY);
3850 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3851 && !isGV_with_GP(SvRV(arg))) {
3852 filter_cache = SvRV(arg);
3853 SvREFCNT_inc_simple_void_NN(filter_cache);
3860 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3864 if (isGV_with_GP(arg)) {
3865 IO * const io = GvIO((const GV *)arg);
3870 tryrsfp = IoIFP(io);
3871 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3872 PerlIO_close(IoOFP(io));
3883 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3885 SvREFCNT_inc_simple_void_NN(filter_sub);
3888 filter_state = SP[i];
3889 SvREFCNT_inc_simple_void(filter_state);
3893 if (!tryrsfp && (filter_cache || filter_sub)) {
3894 tryrsfp = PerlIO_open(BIT_BUCKET,
3902 LEAVE_with_name("call_INC");
3904 /* Adjust file name if the hook has set an %INC entry.
3905 This needs to happen after the FREETMPS above. */
3906 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3908 tryname = SvPV_nolen_const(*svp);
3915 filter_has_file = 0;
3917 SvREFCNT_dec(filter_cache);
3918 filter_cache = NULL;
3921 SvREFCNT_dec(filter_state);
3922 filter_state = NULL;
3925 SvREFCNT_dec(filter_sub);
3930 if (!path_is_absolute(name)
3936 dir = SvPV_const(dirsv, dirlen);
3944 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3946 sv_setpv(namesv, unixdir);
3947 sv_catpv(namesv, unixname);
3949 # ifdef __SYMBIAN32__
3950 if (PL_origfilename[0] &&
3951 PL_origfilename[1] == ':' &&
3952 !(dir[0] && dir[1] == ':'))
3953 Perl_sv_setpvf(aTHX_ namesv,
3958 Perl_sv_setpvf(aTHX_ namesv,
3962 /* The equivalent of
3963 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3964 but without the need to parse the format string, or
3965 call strlen on either pointer, and with the correct
3966 allocation up front. */
3968 char *tmp = SvGROW(namesv, dirlen + len + 2);
3970 memcpy(tmp, dir, dirlen);
3973 /* name came from an SV, so it will have a '\0' at the
3974 end that we can copy as part of this memcpy(). */
3975 memcpy(tmp, name, len + 1);
3977 SvCUR_set(namesv, dirlen + len + 1);
3982 TAINT_PROPER("require");
3983 tryname = SvPVX_const(namesv);
3984 tryrsfp = doopen_pm(namesv);
3986 if (tryname[0] == '.' && tryname[1] == '/') {
3988 while (*++tryname == '/');
3992 else if (errno == EMFILE)
3993 /* no point in trying other paths if out of handles */
4002 if (PL_op->op_type == OP_REQUIRE) {
4003 if(errno == EMFILE) {
4004 /* diag_listed_as: Can't locate %s */
4005 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
4007 if (namesv) { /* did we lookup @INC? */
4008 AV * const ar = GvAVn(PL_incgv);
4010 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4011 for (i = 0; i <= AvFILL(ar); i++) {
4012 sv_catpvs(inc, " ");
4013 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4016 /* diag_listed_as: Can't locate %s */
4018 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4020 (memEQ(name + len - 2, ".h", 3)
4021 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4022 (memEQ(name + len - 3, ".ph", 4)
4023 ? " (did you run h2ph?)" : ""),
4028 DIE(aTHX_ "Can't locate %s", name);
4034 SETERRNO(0, SS_NORMAL);
4036 /* Assume success here to prevent recursive requirement. */
4037 /* name is never assigned to again, so len is still strlen(name) */
4038 /* Check whether a hook in @INC has already filled %INC */
4040 (void)hv_store(GvHVn(PL_incgv),
4041 unixname, unixlen, newSVpv(tryname,0),0);
4043 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4045 (void)hv_store(GvHVn(PL_incgv),
4046 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4049 ENTER_with_name("eval");
4051 SAVECOPFILE_FREE(&PL_compiling);
4052 CopFILE_set(&PL_compiling, tryname);
4053 lex_start(NULL, tryrsfp, 0);
4057 hv_clear(GvHV(PL_hintgv));
4059 SAVECOMPILEWARNINGS();
4060 if (PL_dowarn & G_WARN_ALL_ON)
4061 PL_compiling.cop_warnings = pWARN_ALL ;
4062 else if (PL_dowarn & G_WARN_ALL_OFF)
4063 PL_compiling.cop_warnings = pWARN_NONE ;
4065 PL_compiling.cop_warnings = pWARN_STD ;
4067 if (filter_sub || filter_cache) {
4068 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4069 than hanging another SV from it. In turn, filter_add() optionally
4070 takes the SV to use as the filter (or creates a new SV if passed
4071 NULL), so simply pass in whatever value filter_cache has. */
4072 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4073 IoLINES(datasv) = filter_has_file;
4074 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4075 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4078 /* switch to eval mode */
4079 PUSHBLOCK(cx, CXt_EVAL, SP);
4081 cx->blk_eval.retop = PL_op->op_next;
4083 SAVECOPLINE(&PL_compiling);
4084 CopLINE_set(&PL_compiling, 0);
4088 /* Store and reset encoding. */
4089 encoding = PL_encoding;
4092 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
4093 op = DOCATCH(PL_eval_start);
4095 op = PL_op->op_next;
4097 /* Restore encoding. */
4098 PL_encoding = encoding;
4103 /* This is a op added to hold the hints hash for
4104 pp_entereval. The hash can be modified by the code
4105 being eval'ed, so we return a copy instead. */
4111 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4119 register PERL_CONTEXT *cx;
4121 const I32 gimme = GIMME_V;
4122 const U32 was = PL_breakable_sub_gen;
4123 char tbuf[TYPE_DIGITS(long) + 12];
4124 bool saved_delete = FALSE;
4125 char *tmpbuf = tbuf;
4128 U32 seq, lex_flags = 0;
4129 HV *saved_hh = NULL;
4130 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4132 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4133 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4135 else if (PL_hints & HINT_LOCALIZE_HH || (
4136 PL_op->op_private & OPpEVAL_COPHH
4137 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4139 saved_hh = cop_hints_2hv(PL_curcop, 0);
4140 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4144 /* make sure we've got a plain PV (no overload etc) before testing
4145 * for taint. Making a copy here is probably overkill, but better
4146 * safe than sorry */
4148 const char * const p = SvPV_const(sv, len);
4150 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4151 lex_flags |= LEX_START_COPIED;
4153 if (bytes && SvUTF8(sv))
4154 SvPVbyte_force(sv, len);
4156 else if (bytes && SvUTF8(sv)) {
4157 /* Don’t modify someone else’s scalar */
4160 (void)sv_2mortal(sv);
4161 SvPVbyte_force(sv,len);
4162 lex_flags |= LEX_START_COPIED;
4165 TAINT_IF(SvTAINTED(sv));
4166 TAINT_PROPER("eval");
4168 ENTER_with_name("eval");
4169 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4170 ? LEX_IGNORE_UTF8_HINTS
4171 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4176 /* switch to eval mode */
4178 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4179 SV * const temp_sv = sv_newmortal();
4180 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4181 (unsigned long)++PL_evalseq,
4182 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4183 tmpbuf = SvPVX(temp_sv);
4184 len = SvCUR(temp_sv);
4187 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4188 SAVECOPFILE_FREE(&PL_compiling);
4189 CopFILE_set(&PL_compiling, tmpbuf+2);
4190 SAVECOPLINE(&PL_compiling);
4191 CopLINE_set(&PL_compiling, 1);
4193 PL_hints = PL_op->op_private & OPpEVAL_COPHH
4194 ? PL_curcop->cop_hints : PL_op->op_targ;
4196 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4197 SvREFCNT_dec(GvHV(PL_hintgv));
4198 GvHV(PL_hintgv) = saved_hh;
4200 SAVECOMPILEWARNINGS();
4201 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4202 cophh_free(CopHINTHASH_get(&PL_compiling));
4203 if (Perl_cop_fetch_label(aTHX_ PL_curcop, NULL, NULL)) {
4204 /* The label, if present, is the first entry on the chain. So rather
4205 than writing a blank label in front of it (which involves an
4206 allocation), just use the next entry in the chain. */
4207 PL_compiling.cop_hints_hash
4208 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4209 /* Check the assumption that this removed the label. */
4210 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4213 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4214 /* special case: an eval '' executed within the DB package gets lexically
4215 * placed in the first non-DB CV rather than the current CV - this
4216 * allows the debugger to execute code, find lexicals etc, in the
4217 * scope of the code being debugged. Passing &seq gets find_runcv
4218 * to do the dirty work for us */
4219 runcv = find_runcv(&seq);
4221 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4223 cx->blk_eval.retop = PL_op->op_next;
4225 /* prepare to compile string */
4227 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4228 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4230 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4231 deleting the eval's FILEGV from the stash before gv_check() runs
4232 (i.e. before run-time proper). To work around the coredump that
4233 ensues, we always turn GvMULTI_on for any globals that were
4234 introduced within evals. See force_ident(). GSAR 96-10-12 */
4235 char *const safestr = savepvn(tmpbuf, len);
4236 SAVEDELETE(PL_defstash, safestr, len);
4237 saved_delete = TRUE;
4242 if (doeval(gimme, NULL, runcv, seq)) {
4243 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4244 ? (PERLDB_LINE || PERLDB_SAVESRC)
4245 : PERLDB_SAVESRC_NOSUBS) {
4246 /* Retain the filegv we created. */
4247 } else if (!saved_delete) {
4248 char *const safestr = savepvn(tmpbuf, len);
4249 SAVEDELETE(PL_defstash, safestr, len);
4251 return DOCATCH(PL_eval_start);
4253 /* We have already left the scope set up earlier thanks to the LEAVE
4255 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4256 ? (PERLDB_LINE || PERLDB_SAVESRC)
4257 : PERLDB_SAVESRC_INVALID) {
4258 /* Retain the filegv we created. */
4259 } else if (!saved_delete) {
4260 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4262 return PL_op->op_next;
4272 register PERL_CONTEXT *cx;
4274 const U8 save_flags = PL_op -> op_flags;
4281 namesv = cx->blk_eval.old_namesv;
4282 retop = cx->blk_eval.retop;
4285 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4287 PL_curpm = newpm; /* Don't pop $1 et al till now */
4290 assert(CvDEPTH(PL_compcv) == 1);
4292 CvDEPTH(PL_compcv) = 0;
4294 if (optype == OP_REQUIRE &&
4295 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4297 /* Unassume the success we assumed earlier. */
4298 (void)hv_delete(GvHVn(PL_incgv),
4299 SvPVX_const(namesv),
4300 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4302 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4304 /* die_unwind() did LEAVE, or we won't be here */
4307 LEAVE_with_name("eval");
4308 if (!(save_flags & OPf_SPECIAL)) {
4316 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4317 close to the related Perl_create_eval_scope. */
4319 Perl_delete_eval_scope(pTHX)
4324 register PERL_CONTEXT *cx;
4330 LEAVE_with_name("eval_scope");
4331 PERL_UNUSED_VAR(newsp);
4332 PERL_UNUSED_VAR(gimme);
4333 PERL_UNUSED_VAR(optype);
4336 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4337 also needed by Perl_fold_constants. */
4339 Perl_create_eval_scope(pTHX_ U32 flags)
4342 const I32 gimme = GIMME_V;
4344 ENTER_with_name("eval_scope");
4347 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4350 PL_in_eval = EVAL_INEVAL;
4351 if (flags & G_KEEPERR)
4352 PL_in_eval |= EVAL_KEEPERR;
4355 if (flags & G_FAKINGEVAL) {
4356 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4364 PERL_CONTEXT * const cx = create_eval_scope(0);
4365 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4366 return DOCATCH(PL_op->op_next);
4375 register PERL_CONTEXT *cx;
4381 PERL_UNUSED_VAR(optype);
4384 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4385 PL_curpm = newpm; /* Don't pop $1 et al till now */
4387 LEAVE_with_name("eval_scope");
4395 register PERL_CONTEXT *cx;
4396 const I32 gimme = GIMME_V;
4398 ENTER_with_name("given");
4401 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4402 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4404 PUSHBLOCK(cx, CXt_GIVEN, SP);
4413 register PERL_CONTEXT *cx;
4417 PERL_UNUSED_CONTEXT;
4420 assert(CxTYPE(cx) == CXt_GIVEN);
4423 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4424 PL_curpm = newpm; /* Don't pop $1 et al till now */
4426 LEAVE_with_name("given");
4430 /* Helper routines used by pp_smartmatch */
4432 S_make_matcher(pTHX_ REGEXP *re)
4435 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4437 PERL_ARGS_ASSERT_MAKE_MATCHER;
4439 PM_SETRE(matcher, ReREFCNT_inc(re));
4441 SAVEFREEOP((OP *) matcher);
4442 ENTER_with_name("matcher"); SAVETMPS;
4448 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4453 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4455 PL_op = (OP *) matcher;
4458 (void) Perl_pp_match(aTHX);
4460 return (SvTRUEx(POPs));
4464 S_destroy_matcher(pTHX_ PMOP *matcher)
4468 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4469 PERL_UNUSED_ARG(matcher);
4472 LEAVE_with_name("matcher");
4475 /* Do a smart match */
4478 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4479 return do_smartmatch(NULL, NULL, 0);
4482 /* This version of do_smartmatch() implements the
4483 * table of smart matches that is found in perlsyn.
4486 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4491 bool object_on_left = FALSE;
4492 SV *e = TOPs; /* e is for 'expression' */
4493 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4495 /* Take care only to invoke mg_get() once for each argument.
4496 * Currently we do this by copying the SV if it's magical. */
4498 if (!copied && SvGMAGICAL(d))
4499 d = sv_mortalcopy(d);
4506 e = sv_mortalcopy(e);
4508 /* First of all, handle overload magic of the rightmost argument */
4511 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4512 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4514 tmpsv = amagic_call(d, e, smart_amg, 0);
4521 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4524 SP -= 2; /* Pop the values */
4529 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4536 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4537 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4538 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4540 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4541 object_on_left = TRUE;
4544 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4546 if (object_on_left) {
4547 goto sm_any_sub; /* Treat objects like scalars */
4549 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4550 /* Test sub truth for each key */
4552 bool andedresults = TRUE;
4553 HV *hv = (HV*) SvRV(d);
4554 I32 numkeys = hv_iterinit(hv);
4555 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4558 while ( (he = hv_iternext(hv)) ) {
4559 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4560 ENTER_with_name("smartmatch_hash_key_test");
4563 PUSHs(hv_iterkeysv(he));
4565 c = call_sv(e, G_SCALAR);
4568 andedresults = FALSE;
4570 andedresults = SvTRUEx(POPs) && andedresults;
4572 LEAVE_with_name("smartmatch_hash_key_test");
4579 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4580 /* Test sub truth for each element */
4582 bool andedresults = TRUE;
4583 AV *av = (AV*) SvRV(d);
4584 const I32 len = av_len(av);
4585 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4588 for (i = 0; i <= len; ++i) {
4589 SV * const * const svp = av_fetch(av, i, FALSE);
4590 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4591 ENTER_with_name("smartmatch_array_elem_test");
4597 c = call_sv(e, G_SCALAR);
4600 andedresults = FALSE;
4602 andedresults = SvTRUEx(POPs) && andedresults;
4604 LEAVE_with_name("smartmatch_array_elem_test");
4613 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4614 ENTER_with_name("smartmatch_coderef");
4619 c = call_sv(e, G_SCALAR);
4623 else if (SvTEMP(TOPs))
4624 SvREFCNT_inc_void(TOPs);
4626 LEAVE_with_name("smartmatch_coderef");
4631 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4632 if (object_on_left) {
4633 goto sm_any_hash; /* Treat objects like scalars */
4635 else if (!SvOK(d)) {
4636 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4639 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4640 /* Check that the key-sets are identical */
4642 HV *other_hv = MUTABLE_HV(SvRV(d));
4644 bool other_tied = FALSE;
4645 U32 this_key_count = 0,
4646 other_key_count = 0;
4647 HV *hv = MUTABLE_HV(SvRV(e));
4649 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4650 /* Tied hashes don't know how many keys they have. */
4651 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4654 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4655 HV * const temp = other_hv;
4660 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4663 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4666 /* The hashes have the same number of keys, so it suffices
4667 to check that one is a subset of the other. */
4668 (void) hv_iterinit(hv);
4669 while ( (he = hv_iternext(hv)) ) {
4670 SV *key = hv_iterkeysv(he);
4672 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4675 if(!hv_exists_ent(other_hv, key, 0)) {
4676 (void) hv_iterinit(hv); /* reset iterator */
4682 (void) hv_iterinit(other_hv);
4683 while ( hv_iternext(other_hv) )
4687 other_key_count = HvUSEDKEYS(other_hv);
4689 if (this_key_count != other_key_count)
4694 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4695 AV * const other_av = MUTABLE_AV(SvRV(d));
4696 const I32 other_len = av_len(other_av) + 1;
4698 HV *hv = MUTABLE_HV(SvRV(e));
4700 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4701 for (i = 0; i < other_len; ++i) {
4702 SV ** const svp = av_fetch(other_av, i, FALSE);
4703 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4704 if (svp) { /* ??? When can this not happen? */
4705 if (hv_exists_ent(hv, *svp, 0))
4711 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4712 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4715 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4717 HV *hv = MUTABLE_HV(SvRV(e));
4719 (void) hv_iterinit(hv);
4720 while ( (he = hv_iternext(hv)) ) {
4721 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4722 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4723 (void) hv_iterinit(hv);
4724 destroy_matcher(matcher);
4728 destroy_matcher(matcher);
4734 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4735 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4742 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4743 if (object_on_left) {
4744 goto sm_any_array; /* Treat objects like scalars */
4746 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4747 AV * const other_av = MUTABLE_AV(SvRV(e));
4748 const I32 other_len = av_len(other_av) + 1;
4751 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4752 for (i = 0; i < other_len; ++i) {
4753 SV ** const svp = av_fetch(other_av, i, FALSE);
4755 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4756 if (svp) { /* ??? When can this not happen? */
4757 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4763 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4764 AV *other_av = MUTABLE_AV(SvRV(d));
4765 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4766 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4770 const I32 other_len = av_len(other_av);
4772 if (NULL == seen_this) {
4773 seen_this = newHV();
4774 (void) sv_2mortal(MUTABLE_SV(seen_this));
4776 if (NULL == seen_other) {
4777 seen_other = newHV();
4778 (void) sv_2mortal(MUTABLE_SV(seen_other));
4780 for(i = 0; i <= other_len; ++i) {
4781 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4782 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4784 if (!this_elem || !other_elem) {
4785 if ((this_elem && SvOK(*this_elem))
4786 || (other_elem && SvOK(*other_elem)))
4789 else if (hv_exists_ent(seen_this,
4790 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4791 hv_exists_ent(seen_other,
4792 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4794 if (*this_elem != *other_elem)
4798 (void)hv_store_ent(seen_this,
4799 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4801 (void)hv_store_ent(seen_other,
4802 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4808 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4809 (void) do_smartmatch(seen_this, seen_other, 0);
4811 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4820 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4821 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4824 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4825 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4828 for(i = 0; i <= this_len; ++i) {
4829 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4830 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4831 if (svp && matcher_matches_sv(matcher, *svp)) {
4832 destroy_matcher(matcher);
4836 destroy_matcher(matcher);
4840 else if (!SvOK(d)) {
4841 /* undef ~~ array */
4842 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4845 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4846 for (i = 0; i <= this_len; ++i) {
4847 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4848 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4849 if (!svp || !SvOK(*svp))
4858 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4860 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4861 for (i = 0; i <= this_len; ++i) {
4862 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4869 /* infinite recursion isn't supposed to happen here */
4870 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4871 (void) do_smartmatch(NULL, NULL, 1);
4873 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4882 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4883 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4884 SV *t = d; d = e; e = t;
4885 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4888 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4889 SV *t = d; d = e; e = t;
4890 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4891 goto sm_regex_array;
4894 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4896 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4898 PUSHs(matcher_matches_sv(matcher, d)
4901 destroy_matcher(matcher);
4906 /* See if there is overload magic on left */
4907 else if (object_on_left && SvAMAGIC(d)) {
4909 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4910 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4913 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4921 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4924 else if (!SvOK(d)) {
4925 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4926 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4931 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4932 DEBUG_M(if (SvNIOK(e))
4933 Perl_deb(aTHX_ " applying rule Any-Num\n");
4935 Perl_deb(aTHX_ " applying rule Num-numish\n");
4937 /* numeric comparison */
4940 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4941 (void) Perl_pp_i_eq(aTHX);
4943 (void) Perl_pp_eq(aTHX);
4951 /* As a last resort, use string comparison */
4952 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4955 return Perl_pp_seq(aTHX);
4961 register PERL_CONTEXT *cx;
4962 const I32 gimme = GIMME_V;
4964 /* This is essentially an optimization: if the match
4965 fails, we don't want to push a context and then
4966 pop it again right away, so we skip straight
4967 to the op that follows the leavewhen.
4968 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4970 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4971 RETURNOP(cLOGOP->op_other->op_next);
4973 ENTER_with_name("when");
4976 PUSHBLOCK(cx, CXt_WHEN, SP);
4986 register PERL_CONTEXT *cx;
4991 cxix = dopoptogiven(cxstack_ix);
4993 DIE(aTHX_ "Can't use when() outside a topicalizer");
4996 assert(CxTYPE(cx) == CXt_WHEN);
4999 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
5000 PL_curpm = newpm; /* pop $1 et al */
5002 LEAVE_with_name("when");
5004 if (cxix < cxstack_ix)
5007 cx = &cxstack[cxix];
5009 if (CxFOREACH(cx)) {
5010 /* clear off anything above the scope we're re-entering */
5011 I32 inner = PL_scopestack_ix;
5014 if (PL_scopestack_ix < inner)
5015 leave_scope(PL_scopestack[PL_scopestack_ix]);
5016 PL_curcop = cx->blk_oldcop;
5018 return cx->blk_loop.my_op->op_nextop;
5021 RETURNOP(cx->blk_givwhen.leave_op);
5028 register PERL_CONTEXT *cx;
5033 PERL_UNUSED_VAR(gimme);
5035 cxix = dopoptowhen(cxstack_ix);
5037 DIE(aTHX_ "Can't \"continue\" outside a when block");
5039 if (cxix < cxstack_ix)
5043 assert(CxTYPE(cx) == CXt_WHEN);
5046 PL_curpm = newpm; /* pop $1 et al */
5048 LEAVE_with_name("when");
5049 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5056 register PERL_CONTEXT *cx;
5058 cxix = dopoptogiven(cxstack_ix);
5060 DIE(aTHX_ "Can't \"break\" outside a given block");
5062 cx = &cxstack[cxix];
5064 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5066 if (cxix < cxstack_ix)
5069 /* Restore the sp at the time we entered the given block */
5072 return cx->blk_givwhen.leave_op;
5076 S_doparseform(pTHX_ SV *sv)
5079 register char *s = SvPV(sv, len);
5080 register char *send;
5081 register char *base = NULL; /* start of current field */
5082 register I32 skipspaces = 0; /* number of contiguous spaces seen */
5083 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5084 bool repeat = FALSE; /* ~~ seen on this line */
5085 bool postspace = FALSE; /* a text field may need right padding */
5088 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5090 bool ischop; /* it's a ^ rather than a @ */
5091 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5092 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5096 PERL_ARGS_ASSERT_DOPARSEFORM;
5099 Perl_croak(aTHX_ "Null picture in formline");
5101 if (SvTYPE(sv) >= SVt_PVMG) {
5102 /* This might, of course, still return NULL. */
5103 mg = mg_find(sv, PERL_MAGIC_fm);
5105 sv_upgrade(sv, SVt_PVMG);
5109 /* still the same as previously-compiled string? */
5110 SV *old = mg->mg_obj;
5111 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5112 && len == SvCUR(old)
5113 && strnEQ(SvPVX(old), SvPVX(sv), len)
5115 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5119 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5120 Safefree(mg->mg_ptr);
5126 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5127 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5130 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5131 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5135 /* estimate the buffer size needed */
5136 for (base = s; s <= send; s++) {
5137 if (*s == '\n' || *s == '@' || *s == '^')
5143 Newx(fops, maxops, U32);
5148 *fpc++ = FF_LINEMARK;
5149 noblank = repeat = FALSE;
5167 case ' ': case '\t':
5174 } /* else FALL THROUGH */
5182 *fpc++ = FF_LITERAL;
5190 *fpc++ = (U32)skipspaces;
5194 *fpc++ = FF_NEWLINE;
5198 arg = fpc - linepc + 1;
5205 *fpc++ = FF_LINEMARK;
5206 noblank = repeat = FALSE;
5215 ischop = s[-1] == '^';
5221 arg = (s - base) - 1;
5223 *fpc++ = FF_LITERAL;
5229 if (*s == '*') { /* @* or ^* */
5231 *fpc++ = 2; /* skip the @* or ^* */
5233 *fpc++ = FF_LINESNGL;
5236 *fpc++ = FF_LINEGLOB;
5238 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5239 arg = ischop ? FORM_NUM_BLANK : 0;
5244 const char * const f = ++s;
5247 arg |= FORM_NUM_POINT + (s - f);
5249 *fpc++ = s - base; /* fieldsize for FETCH */
5250 *fpc++ = FF_DECIMAL;
5252 unchopnum |= ! ischop;
5254 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5255 arg = ischop ? FORM_NUM_BLANK : 0;
5257 s++; /* skip the '0' first */
5261 const char * const f = ++s;
5264 arg |= FORM_NUM_POINT + (s - f);
5266 *fpc++ = s - base; /* fieldsize for FETCH */
5267 *fpc++ = FF_0DECIMAL;
5269 unchopnum |= ! ischop;
5271 else { /* text field */
5273 bool ismore = FALSE;
5276 while (*++s == '>') ;
5277 prespace = FF_SPACE;
5279 else if (*s == '|') {
5280 while (*++s == '|') ;
5281 prespace = FF_HALFSPACE;
5286 while (*++s == '<') ;
5289 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5293 *fpc++ = s - base; /* fieldsize for FETCH */
5295 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5298 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5312 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5315 mg->mg_ptr = (char *) fops;
5316 mg->mg_len = arg * sizeof(U32);
5317 mg->mg_obj = sv_copy;
5318 mg->mg_flags |= MGf_REFCOUNTED;
5320 if (unchopnum && repeat)
5321 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5328 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5330 /* Can value be printed in fldsize chars, using %*.*f ? */
5334 int intsize = fldsize - (value < 0 ? 1 : 0);
5336 if (frcsize & FORM_NUM_POINT)
5338 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5341 while (intsize--) pwr *= 10.0;
5342 while (frcsize--) eps /= 10.0;
5345 if (value + eps >= pwr)
5348 if (value - eps <= -pwr)
5355 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5358 SV * const datasv = FILTER_DATA(idx);
5359 const int filter_has_file = IoLINES(datasv);
5360 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5361 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5366 char *prune_from = NULL;
5367 bool read_from_cache = FALSE;
5370 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5372 assert(maxlen >= 0);
5375 /* I was having segfault trouble under Linux 2.2.5 after a
5376 parse error occured. (Had to hack around it with a test
5377 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5378 not sure where the trouble is yet. XXX */
5381 SV *const cache = datasv;
5384 const char *cache_p = SvPV(cache, cache_len);
5388 /* Running in block mode and we have some cached data already.
5390 if (cache_len >= umaxlen) {
5391 /* In fact, so much data we don't even need to call
5396 const char *const first_nl =
5397 (const char *)memchr(cache_p, '\n', cache_len);
5399 take = first_nl + 1 - cache_p;
5403 sv_catpvn(buf_sv, cache_p, take);
5404 sv_chop(cache, cache_p + take);
5405 /* Definitely not EOF */
5409 sv_catsv(buf_sv, cache);
5411 umaxlen -= cache_len;
5414 read_from_cache = TRUE;
5418 /* Filter API says that the filter appends to the contents of the buffer.
5419 Usually the buffer is "", so the details don't matter. But if it's not,
5420 then clearly what it contains is already filtered by this filter, so we
5421 don't want to pass it in a second time.
5422 I'm going to use a mortal in case the upstream filter croaks. */
5423 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5424 ? sv_newmortal() : buf_sv;
5425 SvUPGRADE(upstream, SVt_PV);
5427 if (filter_has_file) {
5428 status = FILTER_READ(idx+1, upstream, 0);
5431 if (filter_sub && status >= 0) {
5435 ENTER_with_name("call_filter_sub");
5436 save_gp(PL_defgv, 0);
5437 GvINTRO_off(PL_defgv);
5438 SAVEGENERICSV(GvSV(PL_defgv));
5442 DEFSV_set(upstream);
5443 SvREFCNT_inc_simple_void_NN(upstream);
5447 PUSHs(filter_state);
5450 count = call_sv(filter_sub, G_SCALAR);
5462 LEAVE_with_name("call_filter_sub");
5465 if(SvOK(upstream)) {
5466 got_p = SvPV(upstream, got_len);
5468 if (got_len > umaxlen) {
5469 prune_from = got_p + umaxlen;
5472 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5473 if (first_nl && first_nl + 1 < got_p + got_len) {
5474 /* There's a second line here... */
5475 prune_from = first_nl + 1;
5480 /* Oh. Too long. Stuff some in our cache. */
5481 STRLEN cached_len = got_p + got_len - prune_from;
5482 SV *const cache = datasv;
5485 /* Cache should be empty. */
5486 assert(!SvCUR(cache));
5489 sv_setpvn(cache, prune_from, cached_len);
5490 /* If you ask for block mode, you may well split UTF-8 characters.
5491 "If it breaks, you get to keep both parts"
5492 (Your code is broken if you don't put them back together again
5493 before something notices.) */
5494 if (SvUTF8(upstream)) {
5497 SvCUR_set(upstream, got_len - cached_len);
5499 /* Can't yet be EOF */
5504 /* If they are at EOF but buf_sv has something in it, then they may never
5505 have touched the SV upstream, so it may be undefined. If we naively
5506 concatenate it then we get a warning about use of uninitialised value.
5508 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5509 sv_catsv(buf_sv, upstream);
5513 IoLINES(datasv) = 0;
5515 SvREFCNT_dec(filter_state);
5516 IoTOP_GV(datasv) = NULL;
5519 SvREFCNT_dec(filter_sub);
5520 IoBOTTOM_GV(datasv) = NULL;
5522 filter_del(S_run_user_filter);
5524 if (status == 0 && read_from_cache) {
5525 /* If we read some data from the cache (and by getting here it implies
5526 that we emptied the cache) then we aren't yet at EOF, and mustn't
5527 report that to our caller. */
5533 /* perhaps someone can come up with a better name for
5534 this? it is not really "absolute", per se ... */
5536 S_path_is_absolute(const char *name)
5538 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5540 if (PERL_FILE_IS_ABSOLUTE(name)
5542 || (*name == '.' && ((name[1] == '/' ||
5543 (name[1] == '.' && name[2] == '/'))
5544 || (name[1] == '\\' ||
5545 ( name[1] == '.' && name[2] == '\\')))
5548 || (*name == '.' && (name[1] == '/' ||
5549 (name[1] == '.' && name[2] == '/')))
5561 * c-indentation-style: bsd
5563 * indent-tabs-mode: t
5566 * ex: set ts=8 sts=4 sw=4 noet: