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. */
332 sv_force_normal_flags(targ, SV_COW_DROP_PV);
337 SvPV_set(targ, SvPVX(dstr));
338 SvCUR_set(targ, SvCUR(dstr));
339 SvLEN_set(targ, SvLEN(dstr));
342 SvPV_set(dstr, NULL);
344 mPUSHi(saviters - 1);
346 (void)SvPOK_only_UTF8(targ);
349 /* update the taint state of various various variables in
350 * preparation for final exit.
351 * See "how taint works" above pp_subst() */
353 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
354 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
355 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
357 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
359 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
360 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
362 SvTAINTED_on(TOPs); /* taint return value */
363 /* needed for mg_set below */
364 PL_tainted = cBOOL(cx->sb_rxtainted &
365 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
368 /* PL_tainted must be correctly set for this mg_set */
371 LEAVE_SCOPE(cx->sb_oldsave);
373 RETURNOP(pm->op_next);
376 cx->sb_iters = saviters;
378 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
381 cx->sb_orig = orig = RX_SUBBEG(rx);
383 cx->sb_strend = s + (cx->sb_strend - m);
385 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
387 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
388 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
390 sv_catpvn(dstr, s, m-s);
392 cx->sb_s = RX_OFFS(rx)[0].end + orig;
393 { /* Update the pos() information. */
395 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
397 SvUPGRADE(sv, SVt_PVMG);
398 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
399 #ifdef PERL_OLD_COPY_ON_WRITE
401 sv_force_normal_flags(sv, 0);
403 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
406 mg->mg_len = m - orig;
409 (void)ReREFCNT_inc(rx);
410 /* update the taint state of various various variables in preparation
411 * for calling the code block.
412 * See "how taint works" above pp_subst() */
414 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
415 cx->sb_rxtainted |= SUBST_TAINT_PAT;
417 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
418 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
419 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
421 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
423 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
424 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
425 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
426 ? cx->sb_dstr : cx->sb_targ);
429 rxres_save(&cx->sb_rxres, rx);
431 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
435 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
440 PERL_ARGS_ASSERT_RXRES_SAVE;
443 if (!p || p[1] < RX_NPARENS(rx)) {
444 #ifdef PERL_OLD_COPY_ON_WRITE
445 i = 7 + RX_NPARENS(rx) * 2;
447 i = 6 + RX_NPARENS(rx) * 2;
456 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
457 RX_MATCH_COPIED_off(rx);
459 #ifdef PERL_OLD_COPY_ON_WRITE
460 *p++ = PTR2UV(RX_SAVED_COPY(rx));
461 RX_SAVED_COPY(rx) = NULL;
464 *p++ = RX_NPARENS(rx);
466 *p++ = PTR2UV(RX_SUBBEG(rx));
467 *p++ = (UV)RX_SUBLEN(rx);
468 for (i = 0; i <= RX_NPARENS(rx); ++i) {
469 *p++ = (UV)RX_OFFS(rx)[i].start;
470 *p++ = (UV)RX_OFFS(rx)[i].end;
475 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
480 PERL_ARGS_ASSERT_RXRES_RESTORE;
483 RX_MATCH_COPY_FREE(rx);
484 RX_MATCH_COPIED_set(rx, *p);
487 #ifdef PERL_OLD_COPY_ON_WRITE
488 if (RX_SAVED_COPY(rx))
489 SvREFCNT_dec (RX_SAVED_COPY(rx));
490 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
494 RX_NPARENS(rx) = *p++;
496 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
497 RX_SUBLEN(rx) = (I32)(*p++);
498 for (i = 0; i <= RX_NPARENS(rx); ++i) {
499 RX_OFFS(rx)[i].start = (I32)(*p++);
500 RX_OFFS(rx)[i].end = (I32)(*p++);
505 S_rxres_free(pTHX_ void **rsp)
507 UV * const p = (UV*)*rsp;
509 PERL_ARGS_ASSERT_RXRES_FREE;
514 void *tmp = INT2PTR(char*,*p);
517 PoisonFree(*p, 1, sizeof(*p));
519 Safefree(INT2PTR(char*,*p));
521 #ifdef PERL_OLD_COPY_ON_WRITE
523 SvREFCNT_dec (INT2PTR(SV*,p[1]));
531 #define FORM_NUM_BLANK (1<<30)
532 #define FORM_NUM_POINT (1<<29)
536 dVAR; dSP; dMARK; dORIGMARK;
537 register SV * const tmpForm = *++MARK;
538 SV *formsv; /* contains text of original format */
539 register U32 *fpc; /* format ops program counter */
540 register char *t; /* current append position in target string */
541 const char *f; /* current position in format string */
543 register SV *sv = NULL; /* current item */
544 const char *item = NULL;/* string value of current item */
545 I32 itemsize = 0; /* length of current item, possibly truncated */
546 I32 fieldsize = 0; /* width of current field */
547 I32 lines = 0; /* number of lines that have been output */
548 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
549 const char *chophere = NULL; /* where to chop current item */
550 STRLEN linemark = 0; /* pos of start of line in output */
552 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
554 STRLEN linemax; /* estimate of output size in bytes */
555 bool item_is_utf8 = FALSE;
556 bool targ_is_utf8 = FALSE;
559 U8 *source; /* source of bytes to append */
560 STRLEN to_copy; /* how may bytes to append */
561 char trans; /* what chars to translate */
563 mg = doparseform(tmpForm);
565 fpc = (U32*)mg->mg_ptr;
566 /* the actual string the format was compiled from.
567 * with overload etc, this may not match tmpForm */
571 SvPV_force(PL_formtarget, len);
572 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
573 SvTAINTED_on(PL_formtarget);
574 if (DO_UTF8(PL_formtarget))
576 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
577 t = SvGROW(PL_formtarget, len + linemax + 1);
578 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
580 f = SvPV_const(formsv, len);
584 const char *name = "???";
587 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
588 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
589 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
590 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
591 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
593 case FF_CHECKNL: name = "CHECKNL"; break;
594 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
595 case FF_SPACE: name = "SPACE"; break;
596 case FF_HALFSPACE: name = "HALFSPACE"; break;
597 case FF_ITEM: name = "ITEM"; break;
598 case FF_CHOP: name = "CHOP"; break;
599 case FF_LINEGLOB: name = "LINEGLOB"; break;
600 case FF_NEWLINE: name = "NEWLINE"; break;
601 case FF_MORE: name = "MORE"; break;
602 case FF_LINEMARK: name = "LINEMARK"; break;
603 case FF_END: name = "END"; break;
604 case FF_0DECIMAL: name = "0DECIMAL"; break;
605 case FF_LINESNGL: name = "LINESNGL"; break;
608 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
610 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
614 linemark = t - SvPVX(PL_formtarget);
624 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
640 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
643 SvTAINTED_on(PL_formtarget);
649 const char *s = item = SvPV_const(sv, len);
652 itemsize = sv_len_utf8(sv);
653 if (itemsize != (I32)len) {
655 if (itemsize > fieldsize) {
656 itemsize = fieldsize;
657 itembytes = itemsize;
658 sv_pos_u2b(sv, &itembytes, 0);
662 send = chophere = s + itembytes;
672 sv_pos_b2u(sv, &itemsize);
676 item_is_utf8 = FALSE;
677 if (itemsize > fieldsize)
678 itemsize = fieldsize;
679 send = chophere = s + itemsize;
693 const char *s = item = SvPV_const(sv, len);
696 itemsize = sv_len_utf8(sv);
697 if (itemsize != (I32)len) {
699 if (itemsize <= fieldsize) {
700 const char *send = chophere = s + itemsize;
713 itemsize = fieldsize;
714 itembytes = itemsize;
715 sv_pos_u2b(sv, &itembytes, 0);
716 send = chophere = s + itembytes;
717 while (s < send || (s == send && isSPACE(*s))) {
727 if (strchr(PL_chopset, *s))
732 itemsize = chophere - item;
733 sv_pos_b2u(sv, &itemsize);
739 item_is_utf8 = FALSE;
740 if (itemsize <= fieldsize) {
741 const char *const send = chophere = s + itemsize;
754 itemsize = fieldsize;
755 send = chophere = s + itemsize;
756 while (s < send || (s == send && isSPACE(*s))) {
766 if (strchr(PL_chopset, *s))
771 itemsize = chophere - item;
777 arg = fieldsize - itemsize;
786 arg = fieldsize - itemsize;
800 /* convert to_copy from chars to bytes */
804 to_copy = s - source;
810 const char *s = chophere;
824 const bool oneline = fpc[-1] == FF_LINESNGL;
825 const char *s = item = SvPV_const(sv, len);
826 const char *const send = s + len;
828 item_is_utf8 = DO_UTF8(sv);
839 to_copy = s - SvPVX_const(sv) - 1;
853 /* append to_copy bytes from source to PL_formstring.
854 * item_is_utf8 implies source is utf8.
855 * if trans, translate certain characters during the copy */
860 SvCUR_set(PL_formtarget,
861 t - SvPVX_const(PL_formtarget));
863 if (targ_is_utf8 && !item_is_utf8) {
864 source = tmp = bytes_to_utf8(source, &to_copy);
866 if (item_is_utf8 && !targ_is_utf8) {
868 /* Upgrade targ to UTF8, and then we reduce it to
869 a problem we have a simple solution for.
870 Don't need get magic. */
871 sv_utf8_upgrade_nomg(PL_formtarget);
873 /* re-calculate linemark */
874 s = (U8*)SvPVX(PL_formtarget);
875 /* the bytes we initially allocated to append the
876 * whole line may have been gobbled up during the
877 * upgrade, so allocate a whole new line's worth
882 linemark = s - (U8*)SvPVX(PL_formtarget);
884 /* Easy. They agree. */
885 assert (item_is_utf8 == targ_is_utf8);
888 /* @* and ^* are the only things that can exceed
889 * the linemax, so grow by the output size, plus
890 * a whole new form's worth in case of any further
892 grow = linemax + to_copy;
894 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
895 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
897 Copy(source, t, to_copy, char);
899 /* blank out ~ or control chars, depending on trans.
900 * works on bytes not chars, so relies on not
901 * matching utf8 continuation bytes */
903 U8 *send = s + to_copy;
906 if (trans == '~' ? (ch == '~') :
919 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
927 #if defined(USE_LONG_DOUBLE)
929 ((arg & FORM_NUM_POINT) ?
930 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
933 ((arg & FORM_NUM_POINT) ?
934 "%#0*.*f" : "%0*.*f");
939 #if defined(USE_LONG_DOUBLE)
941 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
944 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
947 /* If the field is marked with ^ and the value is undefined,
949 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
957 /* overflow evidence */
958 if (num_overflow(value, fieldsize, arg)) {
964 /* Formats aren't yet marked for locales, so assume "yes". */
966 STORE_NUMERIC_STANDARD_SET_LOCAL();
967 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
968 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
969 RESTORE_NUMERIC_STANDARD();
976 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
984 if (arg) { /* repeat until fields exhausted? */
990 t = SvPVX(PL_formtarget) + linemark;
997 const char *s = chophere;
998 const char *send = item + len;
1000 while (isSPACE(*s) && (s < send))
1005 arg = fieldsize - itemsize;
1012 if (strnEQ(s1," ",3)) {
1013 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1024 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
1026 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1028 SvUTF8_on(PL_formtarget);
1029 FmLINES(PL_formtarget) += lines;
1031 if (fpc[-1] == FF_BLANK)
1032 RETURNOP(cLISTOP->op_first);
1044 if (PL_stack_base + *PL_markstack_ptr == SP) {
1046 if (GIMME_V == G_SCALAR)
1048 RETURNOP(PL_op->op_next->op_next);
1050 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1051 Perl_pp_pushmark(aTHX); /* push dst */
1052 Perl_pp_pushmark(aTHX); /* push src */
1053 ENTER_with_name("grep"); /* enter outer scope */
1056 if (PL_op->op_private & OPpGREP_LEX)
1057 SAVESPTR(PAD_SVl(PL_op->op_targ));
1060 ENTER_with_name("grep_item"); /* enter inner scope */
1063 src = PL_stack_base[*PL_markstack_ptr];
1065 if (PL_op->op_private & OPpGREP_LEX)
1066 PAD_SVl(PL_op->op_targ) = src;
1071 if (PL_op->op_type == OP_MAPSTART)
1072 Perl_pp_pushmark(aTHX); /* push top */
1073 return ((LOGOP*)PL_op->op_next)->op_other;
1079 const I32 gimme = GIMME_V;
1080 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1086 /* first, move source pointer to the next item in the source list */
1087 ++PL_markstack_ptr[-1];
1089 /* if there are new items, push them into the destination list */
1090 if (items && gimme != G_VOID) {
1091 /* might need to make room back there first */
1092 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1093 /* XXX this implementation is very pessimal because the stack
1094 * is repeatedly extended for every set of items. Is possible
1095 * to do this without any stack extension or copying at all
1096 * by maintaining a separate list over which the map iterates
1097 * (like foreach does). --gsar */
1099 /* everything in the stack after the destination list moves
1100 * towards the end the stack by the amount of room needed */
1101 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1103 /* items to shift up (accounting for the moved source pointer) */
1104 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1106 /* This optimization is by Ben Tilly and it does
1107 * things differently from what Sarathy (gsar)
1108 * is describing. The downside of this optimization is
1109 * that leaves "holes" (uninitialized and hopefully unused areas)
1110 * to the Perl stack, but on the other hand this
1111 * shouldn't be a problem. If Sarathy's idea gets
1112 * implemented, this optimization should become
1113 * irrelevant. --jhi */
1115 shift = count; /* Avoid shifting too often --Ben Tilly */
1119 dst = (SP += shift);
1120 PL_markstack_ptr[-1] += shift;
1121 *PL_markstack_ptr += shift;
1125 /* copy the new items down to the destination list */
1126 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1127 if (gimme == G_ARRAY) {
1128 /* add returned items to the collection (making mortal copies
1129 * if necessary), then clear the current temps stack frame
1130 * *except* for those items. We do this splicing the items
1131 * into the start of the tmps frame (so some items may be on
1132 * the tmps stack twice), then moving PL_tmps_floor above
1133 * them, then freeing the frame. That way, the only tmps that
1134 * accumulate over iterations are the return values for map.
1135 * We have to do to this way so that everything gets correctly
1136 * freed if we die during the map.
1140 /* make space for the slice */
1141 EXTEND_MORTAL(items);
1142 tmpsbase = PL_tmps_floor + 1;
1143 Move(PL_tmps_stack + tmpsbase,
1144 PL_tmps_stack + tmpsbase + items,
1145 PL_tmps_ix - PL_tmps_floor,
1147 PL_tmps_ix += items;
1152 sv = sv_mortalcopy(sv);
1154 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1156 /* clear the stack frame except for the items */
1157 PL_tmps_floor += items;
1159 /* FREETMPS may have cleared the TEMP flag on some of the items */
1162 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1165 /* scalar context: we don't care about which values map returns
1166 * (we use undef here). And so we certainly don't want to do mortal
1167 * copies of meaningless values. */
1168 while (items-- > 0) {
1170 *dst-- = &PL_sv_undef;
1178 LEAVE_with_name("grep_item"); /* exit inner scope */
1181 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1183 (void)POPMARK; /* pop top */
1184 LEAVE_with_name("grep"); /* exit outer scope */
1185 (void)POPMARK; /* pop src */
1186 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1187 (void)POPMARK; /* pop dst */
1188 SP = PL_stack_base + POPMARK; /* pop original mark */
1189 if (gimme == G_SCALAR) {
1190 if (PL_op->op_private & OPpGREP_LEX) {
1191 SV* sv = sv_newmortal();
1192 sv_setiv(sv, items);
1200 else if (gimme == G_ARRAY)
1207 ENTER_with_name("grep_item"); /* enter inner scope */
1210 /* set $_ to the new source item */
1211 src = PL_stack_base[PL_markstack_ptr[-1]];
1213 if (PL_op->op_private & OPpGREP_LEX)
1214 PAD_SVl(PL_op->op_targ) = src;
1218 RETURNOP(cLOGOP->op_other);
1227 if (GIMME == G_ARRAY)
1229 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1230 return cLOGOP->op_other;
1240 if (GIMME == G_ARRAY) {
1241 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1245 SV * const targ = PAD_SV(PL_op->op_targ);
1248 if (PL_op->op_private & OPpFLIP_LINENUM) {
1249 if (GvIO(PL_last_in_gv)) {
1250 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1253 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1255 flip = SvIV(sv) == SvIV(GvSV(gv));
1261 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1262 if (PL_op->op_flags & OPf_SPECIAL) {
1270 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1273 sv_setpvs(TARG, "");
1279 /* This code tries to decide if "$left .. $right" should use the
1280 magical string increment, or if the range is numeric (we make
1281 an exception for .."0" [#18165]). AMS 20021031. */
1283 #define RANGE_IS_NUMERIC(left,right) ( \
1284 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1285 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1286 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1287 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1288 && (!SvOK(right) || looks_like_number(right))))
1294 if (GIMME == G_ARRAY) {
1300 if (RANGE_IS_NUMERIC(left,right)) {
1303 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1304 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1305 DIE(aTHX_ "Range iterator outside integer range");
1306 i = SvIV_nomg(left);
1307 max = SvIV_nomg(right);
1316 SV * const sv = sv_2mortal(newSViv(i++));
1322 const char * const lpv = SvPV_nomg_const(left, llen);
1323 const char * const tmps = SvPV_nomg_const(right, len);
1325 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1326 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1328 if (strEQ(SvPVX_const(sv),tmps))
1330 sv = sv_2mortal(newSVsv(sv));
1337 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1341 if (PL_op->op_private & OPpFLIP_LINENUM) {
1342 if (GvIO(PL_last_in_gv)) {
1343 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1346 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1347 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1355 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1356 sv_catpvs(targ, "E0");
1366 static const char * const context_name[] = {
1368 NULL, /* CXt_WHEN never actually needs "block" */
1369 NULL, /* CXt_BLOCK never actually needs "block" */
1370 NULL, /* CXt_GIVEN never actually needs "block" */
1371 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1372 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1373 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1374 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1382 S_dopoptolabel(pTHX_ const char *label)
1387 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1389 for (i = cxstack_ix; i >= 0; i--) {
1390 register const PERL_CONTEXT * const cx = &cxstack[i];
1391 switch (CxTYPE(cx)) {
1397 /* diag_listed_as: Exiting subroutine via %s */
1398 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1399 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1400 if (CxTYPE(cx) == CXt_NULL)
1403 case CXt_LOOP_LAZYIV:
1404 case CXt_LOOP_LAZYSV:
1406 case CXt_LOOP_PLAIN:
1408 const char *cx_label = CxLABEL(cx);
1409 if (!cx_label || strNE(label, cx_label) ) {
1410 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1411 (long)i, cx_label));
1414 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1425 Perl_dowantarray(pTHX)
1428 const I32 gimme = block_gimme();
1429 return (gimme == G_VOID) ? G_SCALAR : gimme;
1433 Perl_block_gimme(pTHX)
1436 const I32 cxix = dopoptosub(cxstack_ix);
1440 switch (cxstack[cxix].blk_gimme) {
1448 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1455 Perl_is_lvalue_sub(pTHX)
1458 const I32 cxix = dopoptosub(cxstack_ix);
1459 assert(cxix >= 0); /* We should only be called from inside subs */
1461 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1462 return CxLVAL(cxstack + cxix);
1467 /* only used by PUSHSUB */
1469 Perl_was_lvalue_sub(pTHX)
1472 const I32 cxix = dopoptosub(cxstack_ix-1);
1473 assert(cxix >= 0); /* We should only be called from inside subs */
1475 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1476 return CxLVAL(cxstack + cxix);
1482 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1487 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1489 for (i = startingblock; i >= 0; i--) {
1490 register const PERL_CONTEXT * const cx = &cxstk[i];
1491 switch (CxTYPE(cx)) {
1497 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1505 S_dopoptoeval(pTHX_ I32 startingblock)
1509 for (i = startingblock; i >= 0; i--) {
1510 register const PERL_CONTEXT *cx = &cxstack[i];
1511 switch (CxTYPE(cx)) {
1515 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1523 S_dopoptoloop(pTHX_ I32 startingblock)
1527 for (i = startingblock; i >= 0; i--) {
1528 register const PERL_CONTEXT * const cx = &cxstack[i];
1529 switch (CxTYPE(cx)) {
1535 /* diag_listed_as: Exiting subroutine via %s */
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 = */
2400 /* diag_listed_as: Can't return %s from lvalue subroutine */
2402 "Can't return a %s from lvalue subroutine",
2403 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2409 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2412 PL_stack_sp = newsp;
2418 register PERL_CONTEXT *cx;
2419 bool popsub2 = FALSE;
2420 bool clear_errsv = FALSE;
2430 const I32 cxix = dopoptosub(cxstack_ix);
2433 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2434 * sort block, which is a CXt_NULL
2437 PL_stack_base[1] = *PL_stack_sp;
2438 PL_stack_sp = PL_stack_base + 1;
2442 DIE(aTHX_ "Can't return outside a subroutine");
2444 if (cxix < cxstack_ix)
2447 if (CxMULTICALL(&cxstack[cxix])) {
2448 gimme = cxstack[cxix].blk_gimme;
2449 if (gimme == G_VOID)
2450 PL_stack_sp = PL_stack_base;
2451 else if (gimme == G_SCALAR) {
2452 PL_stack_base[1] = *PL_stack_sp;
2453 PL_stack_sp = PL_stack_base + 1;
2459 switch (CxTYPE(cx)) {
2462 lval = !!CvLVALUE(cx->blk_sub.cv);
2463 retop = cx->blk_sub.retop;
2464 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2467 if (!(PL_in_eval & EVAL_KEEPERR))
2470 namesv = cx->blk_eval.old_namesv;
2471 retop = cx->blk_eval.retop;
2474 if (optype == OP_REQUIRE &&
2475 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2477 /* Unassume the success we assumed earlier. */
2478 (void)hv_delete(GvHVn(PL_incgv),
2479 SvPVX_const(namesv),
2480 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2482 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2487 retop = cx->blk_sub.retop;
2490 DIE(aTHX_ "panic: return");
2494 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2496 if (gimme == G_SCALAR) {
2499 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2500 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2501 && !SvMAGICAL(TOPs)) {
2502 *++newsp = SvREFCNT_inc(*SP);
2507 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2509 *++newsp = sv_mortalcopy(sv);
2513 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2514 && !SvMAGICAL(*SP)) {
2518 *++newsp = sv_mortalcopy(*SP);
2521 *++newsp = sv_mortalcopy(*SP);
2524 *++newsp = &PL_sv_undef;
2526 else if (gimme == G_ARRAY) {
2527 while (++MARK <= SP) {
2528 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2529 && !SvGMAGICAL(*MARK)
2530 ? *MARK : sv_mortalcopy(*MARK);
2531 TAINT_NOT; /* Each item is independent */
2534 PL_stack_sp = newsp;
2538 /* Stack values are safe: */
2541 POPSUB(cx,sv); /* release CV and @_ ... */
2545 PL_curpm = newpm; /* ... and pop $1 et al */
2554 /* This duplicates parts of pp_leavesub, so that it can share code with
2562 register PERL_CONTEXT *cx;
2565 if (CxMULTICALL(&cxstack[cxstack_ix]))
2569 cxstack_ix++; /* temporarily protect top context */
2573 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2577 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2578 PL_curpm = newpm; /* ... and pop $1 et al */
2581 return cx->blk_sub.retop;
2588 register PERL_CONTEXT *cx;
2599 if (PL_op->op_flags & OPf_SPECIAL) {
2600 cxix = dopoptoloop(cxstack_ix);
2602 DIE(aTHX_ "Can't \"last\" outside a loop block");
2605 cxix = dopoptolabel(cPVOP->op_pv);
2607 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2609 if (cxix < cxstack_ix)
2613 cxstack_ix++; /* temporarily protect top context */
2615 switch (CxTYPE(cx)) {
2616 case CXt_LOOP_LAZYIV:
2617 case CXt_LOOP_LAZYSV:
2619 case CXt_LOOP_PLAIN:
2621 newsp = PL_stack_base + cx->blk_loop.resetsp;
2622 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2626 nextop = cx->blk_sub.retop;
2630 nextop = cx->blk_eval.retop;
2634 nextop = cx->blk_sub.retop;
2637 DIE(aTHX_ "panic: last");
2641 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2642 pop2 == CXt_SUB ? SVs_TEMP : 0);
2647 /* Stack values are safe: */
2649 case CXt_LOOP_LAZYIV:
2650 case CXt_LOOP_PLAIN:
2651 case CXt_LOOP_LAZYSV:
2653 POPLOOP(cx); /* release loop vars ... */
2657 POPSUB(cx,sv); /* release CV and @_ ... */
2660 PL_curpm = newpm; /* ... and pop $1 et al */
2663 PERL_UNUSED_VAR(optype);
2664 PERL_UNUSED_VAR(gimme);
2672 register PERL_CONTEXT *cx;
2675 if (PL_op->op_flags & OPf_SPECIAL) {
2676 cxix = dopoptoloop(cxstack_ix);
2678 DIE(aTHX_ "Can't \"next\" outside a loop block");
2681 cxix = dopoptolabel(cPVOP->op_pv);
2683 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2685 if (cxix < cxstack_ix)
2688 /* clear off anything above the scope we're re-entering, but
2689 * save the rest until after a possible continue block */
2690 inner = PL_scopestack_ix;
2692 if (PL_scopestack_ix < inner)
2693 leave_scope(PL_scopestack[PL_scopestack_ix]);
2694 PL_curcop = cx->blk_oldcop;
2695 return (cx)->blk_loop.my_op->op_nextop;
2702 register PERL_CONTEXT *cx;
2706 if (PL_op->op_flags & OPf_SPECIAL) {
2707 cxix = dopoptoloop(cxstack_ix);
2709 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2712 cxix = dopoptolabel(cPVOP->op_pv);
2714 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2716 if (cxix < cxstack_ix)
2719 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2720 if (redo_op->op_type == OP_ENTER) {
2721 /* pop one less context to avoid $x being freed in while (my $x..) */
2723 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2724 redo_op = redo_op->op_next;
2728 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2729 LEAVE_SCOPE(oldsave);
2731 PL_curcop = cx->blk_oldcop;
2736 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2740 static const char too_deep[] = "Target of goto is too deeply nested";
2742 PERL_ARGS_ASSERT_DOFINDLABEL;
2745 Perl_croak(aTHX_ too_deep);
2746 if (o->op_type == OP_LEAVE ||
2747 o->op_type == OP_SCOPE ||
2748 o->op_type == OP_LEAVELOOP ||
2749 o->op_type == OP_LEAVESUB ||
2750 o->op_type == OP_LEAVETRY)
2752 *ops++ = cUNOPo->op_first;
2754 Perl_croak(aTHX_ too_deep);
2757 if (o->op_flags & OPf_KIDS) {
2759 /* First try all the kids at this level, since that's likeliest. */
2760 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2761 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2762 const char *kid_label = CopLABEL(kCOP);
2763 if (kid_label && strEQ(kid_label, label))
2767 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2768 if (kid == PL_lastgotoprobe)
2770 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2773 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2774 ops[-1]->op_type == OP_DBSTATE)
2779 if ((o = dofindlabel(kid, label, ops, oplimit)))
2792 register PERL_CONTEXT *cx;
2793 #define GOTO_DEPTH 64
2794 OP *enterops[GOTO_DEPTH];
2795 const char *label = NULL;
2796 const bool do_dump = (PL_op->op_type == OP_DUMP);
2797 static const char must_have_label[] = "goto must have label";
2799 if (PL_op->op_flags & OPf_STACKED) {
2800 SV * const sv = POPs;
2802 /* This egregious kludge implements goto &subroutine */
2803 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2805 register PERL_CONTEXT *cx;
2806 CV *cv = MUTABLE_CV(SvRV(sv));
2813 if (!CvROOT(cv) && !CvXSUB(cv)) {
2814 const GV * const gv = CvGV(cv);
2818 /* autoloaded stub? */
2819 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2821 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2823 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2824 if (autogv && (cv = GvCV(autogv)))
2826 tmpstr = sv_newmortal();
2827 gv_efullname3(tmpstr, gv, NULL);
2828 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2830 DIE(aTHX_ "Goto undefined subroutine");
2833 /* First do some returnish stuff. */
2834 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2836 cxix = dopoptosub(cxstack_ix);
2838 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2839 if (cxix < cxstack_ix)
2843 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2844 if (CxTYPE(cx) == CXt_EVAL) {
2846 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2847 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2849 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2850 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2852 else if (CxMULTICALL(cx))
2853 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2854 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2855 /* put @_ back onto stack */
2856 AV* av = cx->blk_sub.argarray;
2858 items = AvFILLp(av) + 1;
2859 EXTEND(SP, items+1); /* @_ could have been extended. */
2860 Copy(AvARRAY(av), SP + 1, items, SV*);
2861 SvREFCNT_dec(GvAV(PL_defgv));
2862 GvAV(PL_defgv) = cx->blk_sub.savearray;
2864 /* abandon @_ if it got reified */
2869 av_extend(av, items-1);
2871 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2874 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2875 AV* const av = GvAV(PL_defgv);
2876 items = AvFILLp(av) + 1;
2877 EXTEND(SP, items+1); /* @_ could have been extended. */
2878 Copy(AvARRAY(av), SP + 1, items, SV*);
2882 if (CxTYPE(cx) == CXt_SUB &&
2883 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2884 SvREFCNT_dec(cx->blk_sub.cv);
2885 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2886 LEAVE_SCOPE(oldsave);
2888 /* A destructor called during LEAVE_SCOPE could have undefined
2889 * our precious cv. See bug #99850. */
2890 if (!CvROOT(cv) && !CvXSUB(cv)) {
2891 const GV * const gv = CvGV(cv);
2893 SV * const tmpstr = sv_newmortal();
2894 gv_efullname3(tmpstr, gv, NULL);
2895 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2898 DIE(aTHX_ "Goto undefined subroutine");
2901 /* Now do some callish stuff. */
2903 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2905 OP* const retop = cx->blk_sub.retop;
2906 SV **newsp PERL_UNUSED_DECL;
2907 I32 gimme PERL_UNUSED_DECL;
2910 for (index=0; index<items; index++)
2911 sv_2mortal(SP[-index]);
2914 /* XS subs don't have a CxSUB, so pop it */
2915 POPBLOCK(cx, PL_curpm);
2916 /* Push a mark for the start of arglist */
2919 (void)(*CvXSUB(cv))(aTHX_ cv);
2924 AV* const padlist = CvPADLIST(cv);
2925 if (CxTYPE(cx) == CXt_EVAL) {
2926 PL_in_eval = CxOLD_IN_EVAL(cx);
2927 PL_eval_root = cx->blk_eval.old_eval_root;
2928 cx->cx_type = CXt_SUB;
2930 cx->blk_sub.cv = cv;
2931 cx->blk_sub.olddepth = CvDEPTH(cv);
2934 if (CvDEPTH(cv) < 2)
2935 SvREFCNT_inc_simple_void_NN(cv);
2937 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2938 sub_crush_depth(cv);
2939 pad_push(padlist, CvDEPTH(cv));
2941 PL_curcop = cx->blk_oldcop;
2943 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2946 AV *const av = MUTABLE_AV(PAD_SVl(0));
2948 cx->blk_sub.savearray = GvAV(PL_defgv);
2949 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2950 CX_CURPAD_SAVE(cx->blk_sub);
2951 cx->blk_sub.argarray = av;
2953 if (items >= AvMAX(av) + 1) {
2954 SV **ary = AvALLOC(av);
2955 if (AvARRAY(av) != ary) {
2956 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2959 if (items >= AvMAX(av) + 1) {
2960 AvMAX(av) = items - 1;
2961 Renew(ary,items+1,SV*);
2967 Copy(mark,AvARRAY(av),items,SV*);
2968 AvFILLp(av) = items - 1;
2969 assert(!AvREAL(av));
2971 /* transfer 'ownership' of refcnts to new @_ */
2981 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2982 Perl_get_db_sub(aTHX_ NULL, cv);
2984 CV * const gotocv = get_cvs("DB::goto", 0);
2986 PUSHMARK( PL_stack_sp );
2987 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2992 RETURNOP(CvSTART(cv));
2996 label = SvPV_nolen_const(sv);
2997 if (!(do_dump || *label))
2998 DIE(aTHX_ must_have_label);
3001 else if (PL_op->op_flags & OPf_SPECIAL) {
3003 DIE(aTHX_ must_have_label);
3006 label = cPVOP->op_pv;
3010 if (label && *label) {
3011 OP *gotoprobe = NULL;
3012 bool leaving_eval = FALSE;
3013 bool in_block = FALSE;
3014 PERL_CONTEXT *last_eval_cx = NULL;
3018 PL_lastgotoprobe = NULL;
3020 for (ix = cxstack_ix; ix >= 0; ix--) {
3022 switch (CxTYPE(cx)) {
3024 leaving_eval = TRUE;
3025 if (!CxTRYBLOCK(cx)) {
3026 gotoprobe = (last_eval_cx ?
3027 last_eval_cx->blk_eval.old_eval_root :
3032 /* else fall through */
3033 case CXt_LOOP_LAZYIV:
3034 case CXt_LOOP_LAZYSV:
3036 case CXt_LOOP_PLAIN:
3039 gotoprobe = cx->blk_oldcop->op_sibling;
3045 gotoprobe = cx->blk_oldcop->op_sibling;
3048 gotoprobe = PL_main_root;
3051 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3052 gotoprobe = CvROOT(cx->blk_sub.cv);
3058 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3061 DIE(aTHX_ "panic: goto");
3062 gotoprobe = PL_main_root;
3066 retop = dofindlabel(gotoprobe, label,
3067 enterops, enterops + GOTO_DEPTH);
3070 if (gotoprobe->op_sibling &&
3071 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3072 gotoprobe->op_sibling->op_sibling) {
3073 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3074 label, enterops, enterops + GOTO_DEPTH);
3079 PL_lastgotoprobe = gotoprobe;
3082 DIE(aTHX_ "Can't find label %s", label);
3084 /* if we're leaving an eval, check before we pop any frames
3085 that we're not going to punt, otherwise the error
3088 if (leaving_eval && *enterops && enterops[1]) {
3090 for (i = 1; enterops[i]; i++)
3091 if (enterops[i]->op_type == OP_ENTERITER)
3092 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3095 if (*enterops && enterops[1]) {
3096 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3098 deprecate("\"goto\" to jump into a construct");
3101 /* pop unwanted frames */
3103 if (ix < cxstack_ix) {
3110 oldsave = PL_scopestack[PL_scopestack_ix];
3111 LEAVE_SCOPE(oldsave);
3114 /* push wanted frames */
3116 if (*enterops && enterops[1]) {
3117 OP * const oldop = PL_op;
3118 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3119 for (; enterops[ix]; ix++) {
3120 PL_op = enterops[ix];
3121 /* Eventually we may want to stack the needed arguments
3122 * for each op. For now, we punt on the hard ones. */
3123 if (PL_op->op_type == OP_ENTERITER)
3124 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3125 PL_op->op_ppaddr(aTHX);
3133 if (!retop) retop = PL_main_start;
3135 PL_restartop = retop;
3136 PL_do_undump = TRUE;
3140 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3141 PL_do_undump = FALSE;
3156 anum = 0; (void)POPs;
3161 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3163 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3166 PL_exit_flags |= PERL_EXIT_EXPECTED;
3168 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3169 if (anum || !(PL_minus_c && PL_madskills))
3174 PUSHs(&PL_sv_undef);
3181 S_save_lines(pTHX_ AV *array, SV *sv)
3183 const char *s = SvPVX_const(sv);
3184 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3187 PERL_ARGS_ASSERT_SAVE_LINES;
3189 while (s && s < send) {
3191 SV * const tmpstr = newSV_type(SVt_PVMG);
3193 t = (const char *)memchr(s, '\n', send - s);
3199 sv_setpvn(tmpstr, s, t - s);
3200 av_store(array, line++, tmpstr);
3208 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3210 0 is used as continue inside eval,
3212 3 is used for a die caught by an inner eval - continue inner loop
3214 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3215 establish a local jmpenv to handle exception traps.
3220 S_docatch(pTHX_ OP *o)
3224 OP * const oldop = PL_op;
3228 assert(CATCH_GET == TRUE);
3235 assert(cxstack_ix >= 0);
3236 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3237 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3242 /* die caught by an inner eval - continue inner loop */
3243 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3244 PL_restartjmpenv = NULL;
3245 PL_op = PL_restartop;
3261 /* James Bond: Do you expect me to talk?
3262 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3264 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3265 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3267 Currently it is not used outside the core code. Best if it stays that way.
3269 Hence it's now deprecated, and will be removed.
3272 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3273 /* sv Text to convert to OP tree. */
3274 /* startop op_free() this to undo. */
3275 /* code Short string id of the caller. */
3277 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3278 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3281 /* Don't use this. It will go away without warning once the regexp engine is
3282 refactored not to use it. */
3284 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3287 dVAR; dSP; /* Make POPBLOCK work. */
3293 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3294 char *tmpbuf = tbuf;
3297 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3301 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3303 ENTER_with_name("eval");
3304 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3306 /* switch to eval mode */
3308 if (IN_PERL_COMPILETIME) {
3309 SAVECOPSTASH_FREE(&PL_compiling);
3310 CopSTASH_set(&PL_compiling, PL_curstash);
3312 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3313 SV * const sv = sv_newmortal();
3314 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3315 code, (unsigned long)++PL_evalseq,
3316 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3321 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3322 (unsigned long)++PL_evalseq);
3323 SAVECOPFILE_FREE(&PL_compiling);
3324 CopFILE_set(&PL_compiling, tmpbuf+2);
3325 SAVECOPLINE(&PL_compiling);
3326 CopLINE_set(&PL_compiling, 1);
3327 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3328 deleting the eval's FILEGV from the stash before gv_check() runs
3329 (i.e. before run-time proper). To work around the coredump that
3330 ensues, we always turn GvMULTI_on for any globals that were
3331 introduced within evals. See force_ident(). GSAR 96-10-12 */
3332 safestr = savepvn(tmpbuf, len);
3333 SAVEDELETE(PL_defstash, safestr, len);
3335 #ifdef OP_IN_REGISTER
3341 /* we get here either during compilation, or via pp_regcomp at runtime */
3342 runtime = IN_PERL_RUNTIME;
3345 runcv = find_runcv(NULL);
3347 /* At run time, we have to fetch the hints from PL_curcop. */
3348 PL_hints = PL_curcop->cop_hints;
3349 if (PL_hints & HINT_LOCALIZE_HH) {
3350 /* SAVEHINTS created a new HV in PL_hintgv, which we
3352 SvREFCNT_dec(GvHV(PL_hintgv));
3354 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3355 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3357 SAVECOMPILEWARNINGS();
3358 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3359 cophh_free(CopHINTHASH_get(&PL_compiling));
3360 /* XXX Does this need to avoid copying a label? */
3361 PL_compiling.cop_hints_hash
3362 = cophh_copy(PL_curcop->cop_hints_hash);
3366 PL_op->op_type = OP_ENTEREVAL;
3367 PL_op->op_flags = 0; /* Avoid uninit warning. */
3368 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3370 need_catch = CATCH_GET;
3374 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3376 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3377 CATCH_SET(need_catch);
3378 POPBLOCK(cx,PL_curpm);
3381 (*startop)->op_type = OP_NULL;
3382 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3383 /* XXX DAPM do this properly one year */
3384 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3385 LEAVE_with_name("eval");
3386 if (IN_PERL_COMPILETIME)
3387 CopHINTS_set(&PL_compiling, PL_hints);
3388 #ifdef OP_IN_REGISTER
3391 PERL_UNUSED_VAR(newsp);
3392 PERL_UNUSED_VAR(optype);
3394 return PL_eval_start;
3399 =for apidoc find_runcv
3401 Locate the CV corresponding to the currently executing sub or eval.
3402 If db_seqp is non_null, skip CVs that are in the DB package and populate
3403 *db_seqp with the cop sequence number at the point that the DB:: code was
3404 entered. (allows debuggers to eval in the scope of the breakpoint rather
3405 than in the scope of the debugger itself).
3411 Perl_find_runcv(pTHX_ U32 *db_seqp)
3417 *db_seqp = PL_curcop->cop_seq;
3418 for (si = PL_curstackinfo; si; si = si->si_prev) {
3420 for (ix = si->si_cxix; ix >= 0; ix--) {
3421 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3422 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3423 CV * const cv = cx->blk_sub.cv;
3424 /* skip DB:: code */
3425 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3426 *db_seqp = cx->blk_oldcop->cop_seq;
3431 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3432 return cx->blk_eval.cv;
3439 /* Run yyparse() in a setjmp wrapper. Returns:
3440 * 0: yyparse() successful
3441 * 1: yyparse() failed
3445 S_try_yyparse(pTHX_ int gramtype)
3450 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3454 ret = yyparse(gramtype) ? 1 : 0;
3468 /* Compile a require/do, an eval '', or a /(?{...})/.
3469 * In the last case, startop is non-null, and contains the address of
3470 * a pointer that should be set to the just-compiled code.
3471 * outside is the lexically enclosing CV (if any) that invoked us.
3472 * Returns a bool indicating whether the compile was successful; if so,
3473 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3474 * pushes undef (also croaks if startop != NULL).
3477 /* This function is called from three places, sv_compile_2op, pp_return
3478 * and pp_entereval. These can be distinguished as follows:
3479 * sv_compile_2op - startop is non-null
3480 * pp_require - startop is null; in_require is true
3481 * pp_entereval - stortop is null; in_require is false
3485 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3488 OP * const saveop = PL_op;
3489 COP * const oldcurcop = PL_curcop;
3490 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3494 PL_in_eval = (in_require
3495 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3500 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3502 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3503 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3504 cxstack[cxstack_ix].blk_gimme = gimme;
3506 CvOUTSIDE_SEQ(evalcv) = seq;
3507 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3509 /* set up a scratch pad */
3511 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3512 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3516 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3518 /* make sure we compile in the right package */
3520 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3521 SAVEGENERICSV(PL_curstash);
3522 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3524 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3525 SAVESPTR(PL_beginav);
3526 PL_beginav = newAV();
3527 SAVEFREESV(PL_beginav);
3528 SAVESPTR(PL_unitcheckav);
3529 PL_unitcheckav = newAV();
3530 SAVEFREESV(PL_unitcheckav);
3533 SAVEBOOL(PL_madskills);
3537 if (!startop) ENTER_with_name("evalcomp");
3538 SAVESPTR(PL_compcv);
3541 /* try to compile it */
3543 PL_eval_root = NULL;
3544 PL_curcop = &PL_compiling;
3545 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3546 PL_in_eval |= EVAL_KEEPERR;
3554 hv_clear(GvHV(PL_hintgv));
3557 PL_hints = saveop->op_private & OPpEVAL_COPHH
3558 ? oldcurcop->cop_hints : saveop->op_targ;
3560 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3561 SvREFCNT_dec(GvHV(PL_hintgv));
3562 GvHV(PL_hintgv) = hh;
3565 SAVECOMPILEWARNINGS();
3567 if (PL_dowarn & G_WARN_ALL_ON)
3568 PL_compiling.cop_warnings = pWARN_ALL ;
3569 else if (PL_dowarn & G_WARN_ALL_OFF)
3570 PL_compiling.cop_warnings = pWARN_NONE ;
3572 PL_compiling.cop_warnings = pWARN_STD ;
3575 PL_compiling.cop_warnings =
3576 DUP_WARNINGS(oldcurcop->cop_warnings);
3577 cophh_free(CopHINTHASH_get(&PL_compiling));
3578 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3579 /* The label, if present, is the first entry on the chain. So rather
3580 than writing a blank label in front of it (which involves an
3581 allocation), just use the next entry in the chain. */
3582 PL_compiling.cop_hints_hash
3583 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3584 /* Check the assumption that this removed the label. */
3585 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3588 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3592 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3594 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3595 * so honour CATCH_GET and trap it here if necessary */
3597 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3599 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3600 SV **newsp; /* Used by POPBLOCK. */
3602 I32 optype; /* Used by POPEVAL. */
3607 PERL_UNUSED_VAR(newsp);
3608 PERL_UNUSED_VAR(optype);
3610 /* note that if yystatus == 3, then the EVAL CX block has already
3611 * been popped, and various vars restored */
3613 if (yystatus != 3) {
3615 op_free(PL_eval_root);
3616 PL_eval_root = NULL;
3618 SP = PL_stack_base + POPMARK; /* pop original mark */
3620 POPBLOCK(cx,PL_curpm);
3622 namesv = cx->blk_eval.old_namesv;
3624 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3625 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3630 /* If cx is still NULL, it means that we didn't go in the
3631 * POPEVAL branch. */
3632 cx = &cxstack[cxstack_ix];
3633 assert(CxTYPE(cx) == CXt_EVAL);
3634 namesv = cx->blk_eval.old_namesv;
3636 (void)hv_store(GvHVn(PL_incgv),
3637 SvPVX_const(namesv),
3638 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3640 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3643 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3646 if (yystatus != 3) {
3647 POPBLOCK(cx,PL_curpm);
3650 Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3653 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3656 if (!*(SvPVx_nolen_const(ERRSV))) {
3657 sv_setpvs(ERRSV, "Compilation error");
3660 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3664 else if (!startop) LEAVE_with_name("evalcomp");
3665 CopLINE_set(&PL_compiling, 0);
3667 *startop = PL_eval_root;
3669 SAVEFREEOP(PL_eval_root);
3671 DEBUG_x(dump_eval());
3673 /* Register with debugger: */
3674 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3675 CV * const cv = get_cvs("DB::postponed", 0);
3679 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3681 call_sv(MUTABLE_SV(cv), G_DISCARD);
3685 if (PL_unitcheckav) {
3686 OP *es = PL_eval_start;
3687 call_list(PL_scopestack_ix, PL_unitcheckav);
3691 /* compiled okay, so do it */
3693 CvDEPTH(evalcv) = 1;
3694 SP = PL_stack_base + POPMARK; /* pop original mark */
3695 PL_op = saveop; /* The caller may need it. */
3696 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3703 S_check_type_and_open(pTHX_ SV *name)
3706 const char *p = SvPV_nolen_const(name);
3707 const int st_rc = PerlLIO_stat(p, &st);
3709 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3711 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3715 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3716 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3718 return PerlIO_open(p, PERL_SCRIPT_MODE);
3722 #ifndef PERL_DISABLE_PMC
3724 S_doopen_pm(pTHX_ SV *name)
3727 const char *p = SvPV_const(name, namelen);
3729 PERL_ARGS_ASSERT_DOOPEN_PM;
3731 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3732 SV *const pmcsv = sv_newmortal();
3735 SvSetSV_nosteal(pmcsv,name);
3736 sv_catpvn(pmcsv, "c", 1);
3738 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3739 return check_type_and_open(pmcsv);
3741 return check_type_and_open(name);
3744 # define doopen_pm(name) check_type_and_open(name)
3745 #endif /* !PERL_DISABLE_PMC */
3750 register PERL_CONTEXT *cx;
3757 int vms_unixname = 0;
3759 const char *tryname = NULL;
3761 const I32 gimme = GIMME_V;
3762 int filter_has_file = 0;
3763 PerlIO *tryrsfp = NULL;
3764 SV *filter_cache = NULL;
3765 SV *filter_state = NULL;
3766 SV *filter_sub = NULL;
3772 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3773 sv = sv_2mortal(new_version(sv));
3774 if (!sv_derived_from(PL_patchlevel, "version"))
3775 upg_version(PL_patchlevel, TRUE);
3776 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3777 if ( vcmp(sv,PL_patchlevel) <= 0 )
3778 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3779 SVfARG(sv_2mortal(vnormal(sv))),
3780 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3784 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3787 SV * const req = SvRV(sv);
3788 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3790 /* get the left hand term */
3791 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3793 first = SvIV(*av_fetch(lav,0,0));
3794 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3795 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3796 || av_len(lav) > 1 /* FP with > 3 digits */
3797 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3799 DIE(aTHX_ "Perl %"SVf" required--this is only "
3801 SVfARG(sv_2mortal(vnormal(req))),
3802 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3805 else { /* probably 'use 5.10' or 'use 5.8' */
3810 second = SvIV(*av_fetch(lav,1,0));
3812 second /= second >= 600 ? 100 : 10;
3813 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3814 (int)first, (int)second);
3815 upg_version(hintsv, TRUE);
3817 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3818 "--this is only %"SVf", stopped",
3819 SVfARG(sv_2mortal(vnormal(req))),
3820 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3821 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3829 name = SvPV_const(sv, len);
3830 if (!(name && len > 0 && *name))
3831 DIE(aTHX_ "Null filename used");
3832 TAINT_PROPER("require");
3836 /* The key in the %ENV hash is in the syntax of file passed as the argument
3837 * usually this is in UNIX format, but sometimes in VMS format, which
3838 * can result in a module being pulled in more than once.
3839 * To prevent this, the key must be stored in UNIX format if the VMS
3840 * name can be translated to UNIX.
3842 if ((unixname = tounixspec(name, NULL)) != NULL) {
3843 unixlen = strlen(unixname);
3849 /* if not VMS or VMS name can not be translated to UNIX, pass it
3852 unixname = (char *) name;
3855 if (PL_op->op_type == OP_REQUIRE) {
3856 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3857 unixname, unixlen, 0);
3859 if (*svp != &PL_sv_undef)
3862 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3863 "Compilation failed in require", unixname);
3867 /* prepare to compile file */
3869 if (path_is_absolute(name)) {
3870 /* At this point, name is SvPVX(sv) */
3872 tryrsfp = doopen_pm(sv);
3875 AV * const ar = GvAVn(PL_incgv);
3881 namesv = newSV_type(SVt_PV);
3882 for (i = 0; i <= AvFILL(ar); i++) {
3883 SV * const dirsv = *av_fetch(ar, i, TRUE);
3885 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3892 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3893 && !sv_isobject(loader))
3895 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3898 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3899 PTR2UV(SvRV(dirsv)), name);
3900 tryname = SvPVX_const(namesv);
3903 ENTER_with_name("call_INC");
3911 if (sv_isobject(loader))
3912 count = call_method("INC", G_ARRAY);
3914 count = call_sv(loader, G_ARRAY);
3924 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3925 && !isGV_with_GP(SvRV(arg))) {
3926 filter_cache = SvRV(arg);
3927 SvREFCNT_inc_simple_void_NN(filter_cache);
3934 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3938 if (isGV_with_GP(arg)) {
3939 IO * const io = GvIO((const GV *)arg);
3944 tryrsfp = IoIFP(io);
3945 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3946 PerlIO_close(IoOFP(io));
3957 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3959 SvREFCNT_inc_simple_void_NN(filter_sub);
3962 filter_state = SP[i];
3963 SvREFCNT_inc_simple_void(filter_state);
3967 if (!tryrsfp && (filter_cache || filter_sub)) {
3968 tryrsfp = PerlIO_open(BIT_BUCKET,
3976 LEAVE_with_name("call_INC");
3978 /* Adjust file name if the hook has set an %INC entry.
3979 This needs to happen after the FREETMPS above. */
3980 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3982 tryname = SvPV_nolen_const(*svp);
3989 filter_has_file = 0;
3991 SvREFCNT_dec(filter_cache);
3992 filter_cache = NULL;
3995 SvREFCNT_dec(filter_state);
3996 filter_state = NULL;
3999 SvREFCNT_dec(filter_sub);
4004 if (!path_is_absolute(name)
4010 dir = SvPV_const(dirsv, dirlen);
4018 if ((unixdir = tounixpath(dir, NULL)) == NULL)
4020 sv_setpv(namesv, unixdir);
4021 sv_catpv(namesv, unixname);
4023 # ifdef __SYMBIAN32__
4024 if (PL_origfilename[0] &&
4025 PL_origfilename[1] == ':' &&
4026 !(dir[0] && dir[1] == ':'))
4027 Perl_sv_setpvf(aTHX_ namesv,
4032 Perl_sv_setpvf(aTHX_ namesv,
4036 /* The equivalent of
4037 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4038 but without the need to parse the format string, or
4039 call strlen on either pointer, and with the correct
4040 allocation up front. */
4042 char *tmp = SvGROW(namesv, dirlen + len + 2);
4044 memcpy(tmp, dir, dirlen);
4047 /* name came from an SV, so it will have a '\0' at the
4048 end that we can copy as part of this memcpy(). */
4049 memcpy(tmp, name, len + 1);
4051 SvCUR_set(namesv, dirlen + len + 1);
4056 TAINT_PROPER("require");
4057 tryname = SvPVX_const(namesv);
4058 tryrsfp = doopen_pm(namesv);
4060 if (tryname[0] == '.' && tryname[1] == '/') {
4062 while (*++tryname == '/');
4066 else if (errno == EMFILE)
4067 /* no point in trying other paths if out of handles */
4076 if (PL_op->op_type == OP_REQUIRE) {
4077 if(errno == EMFILE) {
4078 /* diag_listed_as: Can't locate %s */
4079 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
4081 if (namesv) { /* did we lookup @INC? */
4082 AV * const ar = GvAVn(PL_incgv);
4084 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4085 for (i = 0; i <= AvFILL(ar); i++) {
4086 sv_catpvs(inc, " ");
4087 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4090 /* diag_listed_as: Can't locate %s */
4092 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4094 (memEQ(name + len - 2, ".h", 3)
4095 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4096 (memEQ(name + len - 3, ".ph", 4)
4097 ? " (did you run h2ph?)" : ""),
4102 DIE(aTHX_ "Can't locate %s", name);
4108 SETERRNO(0, SS_NORMAL);
4110 /* Assume success here to prevent recursive requirement. */
4111 /* name is never assigned to again, so len is still strlen(name) */
4112 /* Check whether a hook in @INC has already filled %INC */
4114 (void)hv_store(GvHVn(PL_incgv),
4115 unixname, unixlen, newSVpv(tryname,0),0);
4117 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4119 (void)hv_store(GvHVn(PL_incgv),
4120 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4123 ENTER_with_name("eval");
4125 SAVECOPFILE_FREE(&PL_compiling);
4126 CopFILE_set(&PL_compiling, tryname);
4127 lex_start(NULL, tryrsfp, 0);
4129 if (filter_sub || filter_cache) {
4130 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4131 than hanging another SV from it. In turn, filter_add() optionally
4132 takes the SV to use as the filter (or creates a new SV if passed
4133 NULL), so simply pass in whatever value filter_cache has. */
4134 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4135 IoLINES(datasv) = filter_has_file;
4136 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4137 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4140 /* switch to eval mode */
4141 PUSHBLOCK(cx, CXt_EVAL, SP);
4143 cx->blk_eval.retop = PL_op->op_next;
4145 SAVECOPLINE(&PL_compiling);
4146 CopLINE_set(&PL_compiling, 0);
4150 /* Store and reset encoding. */
4151 encoding = PL_encoding;
4154 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4155 op = DOCATCH(PL_eval_start);
4157 op = PL_op->op_next;
4159 /* Restore encoding. */
4160 PL_encoding = encoding;
4165 /* This is a op added to hold the hints hash for
4166 pp_entereval. The hash can be modified by the code
4167 being eval'ed, so we return a copy instead. */
4173 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4181 register PERL_CONTEXT *cx;
4183 const I32 gimme = GIMME_V;
4184 const U32 was = PL_breakable_sub_gen;
4185 char tbuf[TYPE_DIGITS(long) + 12];
4186 bool saved_delete = FALSE;
4187 char *tmpbuf = tbuf;
4190 U32 seq, lex_flags = 0;
4191 HV *saved_hh = NULL;
4192 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4194 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4195 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4197 else if (PL_hints & HINT_LOCALIZE_HH || (
4198 PL_op->op_private & OPpEVAL_COPHH
4199 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4201 saved_hh = cop_hints_2hv(PL_curcop, 0);
4202 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4206 /* make sure we've got a plain PV (no overload etc) before testing
4207 * for taint. Making a copy here is probably overkill, but better
4208 * safe than sorry */
4210 const char * const p = SvPV_const(sv, len);
4212 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4213 lex_flags |= LEX_START_COPIED;
4215 if (bytes && SvUTF8(sv))
4216 SvPVbyte_force(sv, len);
4218 else if (bytes && SvUTF8(sv)) {
4219 /* Don't modify someone else's scalar */
4222 (void)sv_2mortal(sv);
4223 SvPVbyte_force(sv,len);
4224 lex_flags |= LEX_START_COPIED;
4227 TAINT_IF(SvTAINTED(sv));
4228 TAINT_PROPER("eval");
4230 ENTER_with_name("eval");
4231 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4232 ? LEX_IGNORE_UTF8_HINTS
4233 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4238 /* switch to eval mode */
4240 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4241 SV * const temp_sv = sv_newmortal();
4242 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4243 (unsigned long)++PL_evalseq,
4244 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4245 tmpbuf = SvPVX(temp_sv);
4246 len = SvCUR(temp_sv);
4249 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4250 SAVECOPFILE_FREE(&PL_compiling);
4251 CopFILE_set(&PL_compiling, tmpbuf+2);
4252 SAVECOPLINE(&PL_compiling);
4253 CopLINE_set(&PL_compiling, 1);
4254 /* special case: an eval '' executed within the DB package gets lexically
4255 * placed in the first non-DB CV rather than the current CV - this
4256 * allows the debugger to execute code, find lexicals etc, in the
4257 * scope of the code being debugged. Passing &seq gets find_runcv
4258 * to do the dirty work for us */
4259 runcv = find_runcv(&seq);
4261 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4263 cx->blk_eval.retop = PL_op->op_next;
4265 /* prepare to compile string */
4267 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4268 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4270 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4271 deleting the eval's FILEGV from the stash before gv_check() runs
4272 (i.e. before run-time proper). To work around the coredump that
4273 ensues, we always turn GvMULTI_on for any globals that were
4274 introduced within evals. See force_ident(). GSAR 96-10-12 */
4275 char *const safestr = savepvn(tmpbuf, len);
4276 SAVEDELETE(PL_defstash, safestr, len);
4277 saved_delete = TRUE;
4282 if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4283 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4284 ? (PERLDB_LINE || PERLDB_SAVESRC)
4285 : PERLDB_SAVESRC_NOSUBS) {
4286 /* Retain the filegv we created. */
4287 } else if (!saved_delete) {
4288 char *const safestr = savepvn(tmpbuf, len);
4289 SAVEDELETE(PL_defstash, safestr, len);
4291 return DOCATCH(PL_eval_start);
4293 /* We have already left the scope set up earlier thanks to the LEAVE
4295 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4296 ? (PERLDB_LINE || PERLDB_SAVESRC)
4297 : PERLDB_SAVESRC_INVALID) {
4298 /* Retain the filegv we created. */
4299 } else if (!saved_delete) {
4300 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4302 return PL_op->op_next;
4312 register PERL_CONTEXT *cx;
4314 const U8 save_flags = PL_op -> op_flags;
4322 namesv = cx->blk_eval.old_namesv;
4323 retop = cx->blk_eval.retop;
4324 evalcv = cx->blk_eval.cv;
4327 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4329 PL_curpm = newpm; /* Don't pop $1 et al till now */
4332 assert(CvDEPTH(evalcv) == 1);
4334 CvDEPTH(evalcv) = 0;
4336 if (optype == OP_REQUIRE &&
4337 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4339 /* Unassume the success we assumed earlier. */
4340 (void)hv_delete(GvHVn(PL_incgv),
4341 SvPVX_const(namesv),
4342 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4344 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4346 /* die_unwind() did LEAVE, or we won't be here */
4349 LEAVE_with_name("eval");
4350 if (!(save_flags & OPf_SPECIAL)) {
4358 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4359 close to the related Perl_create_eval_scope. */
4361 Perl_delete_eval_scope(pTHX)
4366 register PERL_CONTEXT *cx;
4372 LEAVE_with_name("eval_scope");
4373 PERL_UNUSED_VAR(newsp);
4374 PERL_UNUSED_VAR(gimme);
4375 PERL_UNUSED_VAR(optype);
4378 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4379 also needed by Perl_fold_constants. */
4381 Perl_create_eval_scope(pTHX_ U32 flags)
4384 const I32 gimme = GIMME_V;
4386 ENTER_with_name("eval_scope");
4389 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4392 PL_in_eval = EVAL_INEVAL;
4393 if (flags & G_KEEPERR)
4394 PL_in_eval |= EVAL_KEEPERR;
4397 if (flags & G_FAKINGEVAL) {
4398 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4406 PERL_CONTEXT * const cx = create_eval_scope(0);
4407 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4408 return DOCATCH(PL_op->op_next);
4417 register PERL_CONTEXT *cx;
4423 PERL_UNUSED_VAR(optype);
4426 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4427 PL_curpm = newpm; /* Don't pop $1 et al till now */
4429 LEAVE_with_name("eval_scope");
4437 register PERL_CONTEXT *cx;
4438 const I32 gimme = GIMME_V;
4440 ENTER_with_name("given");
4443 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4444 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4446 PUSHBLOCK(cx, CXt_GIVEN, SP);
4455 register PERL_CONTEXT *cx;
4459 PERL_UNUSED_CONTEXT;
4462 assert(CxTYPE(cx) == CXt_GIVEN);
4465 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4466 PL_curpm = newpm; /* Don't pop $1 et al till now */
4468 LEAVE_with_name("given");
4472 /* Helper routines used by pp_smartmatch */
4474 S_make_matcher(pTHX_ REGEXP *re)
4477 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4479 PERL_ARGS_ASSERT_MAKE_MATCHER;
4481 PM_SETRE(matcher, ReREFCNT_inc(re));
4483 SAVEFREEOP((OP *) matcher);
4484 ENTER_with_name("matcher"); SAVETMPS;
4490 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4495 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4497 PL_op = (OP *) matcher;
4500 (void) Perl_pp_match(aTHX);
4502 return (SvTRUEx(POPs));
4506 S_destroy_matcher(pTHX_ PMOP *matcher)
4510 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4511 PERL_UNUSED_ARG(matcher);
4514 LEAVE_with_name("matcher");
4517 /* Do a smart match */
4520 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4521 return do_smartmatch(NULL, NULL, 0);
4524 /* This version of do_smartmatch() implements the
4525 * table of smart matches that is found in perlsyn.
4528 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4533 bool object_on_left = FALSE;
4534 SV *e = TOPs; /* e is for 'expression' */
4535 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4537 /* Take care only to invoke mg_get() once for each argument.
4538 * Currently we do this by copying the SV if it's magical. */
4540 if (!copied && SvGMAGICAL(d))
4541 d = sv_mortalcopy(d);
4548 e = sv_mortalcopy(e);
4550 /* First of all, handle overload magic of the rightmost argument */
4553 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4554 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4556 tmpsv = amagic_call(d, e, smart_amg, 0);
4563 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4566 SP -= 2; /* Pop the values */
4571 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4578 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4579 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4580 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4582 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4583 object_on_left = TRUE;
4586 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4588 if (object_on_left) {
4589 goto sm_any_sub; /* Treat objects like scalars */
4591 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4592 /* Test sub truth for each key */
4594 bool andedresults = TRUE;
4595 HV *hv = (HV*) SvRV(d);
4596 I32 numkeys = hv_iterinit(hv);
4597 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4600 while ( (he = hv_iternext(hv)) ) {
4601 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4602 ENTER_with_name("smartmatch_hash_key_test");
4605 PUSHs(hv_iterkeysv(he));
4607 c = call_sv(e, G_SCALAR);
4610 andedresults = FALSE;
4612 andedresults = SvTRUEx(POPs) && andedresults;
4614 LEAVE_with_name("smartmatch_hash_key_test");
4621 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4622 /* Test sub truth for each element */
4624 bool andedresults = TRUE;
4625 AV *av = (AV*) SvRV(d);
4626 const I32 len = av_len(av);
4627 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4630 for (i = 0; i <= len; ++i) {
4631 SV * const * const svp = av_fetch(av, i, FALSE);
4632 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4633 ENTER_with_name("smartmatch_array_elem_test");
4639 c = call_sv(e, G_SCALAR);
4642 andedresults = FALSE;
4644 andedresults = SvTRUEx(POPs) && andedresults;
4646 LEAVE_with_name("smartmatch_array_elem_test");
4655 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4656 ENTER_with_name("smartmatch_coderef");
4661 c = call_sv(e, G_SCALAR);
4665 else if (SvTEMP(TOPs))
4666 SvREFCNT_inc_void(TOPs);
4668 LEAVE_with_name("smartmatch_coderef");
4673 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4674 if (object_on_left) {
4675 goto sm_any_hash; /* Treat objects like scalars */
4677 else if (!SvOK(d)) {
4678 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4681 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4682 /* Check that the key-sets are identical */
4684 HV *other_hv = MUTABLE_HV(SvRV(d));
4686 bool other_tied = FALSE;
4687 U32 this_key_count = 0,
4688 other_key_count = 0;
4689 HV *hv = MUTABLE_HV(SvRV(e));
4691 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4692 /* Tied hashes don't know how many keys they have. */
4693 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4696 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4697 HV * const temp = other_hv;
4702 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4705 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4708 /* The hashes have the same number of keys, so it suffices
4709 to check that one is a subset of the other. */
4710 (void) hv_iterinit(hv);
4711 while ( (he = hv_iternext(hv)) ) {
4712 SV *key = hv_iterkeysv(he);
4714 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4717 if(!hv_exists_ent(other_hv, key, 0)) {
4718 (void) hv_iterinit(hv); /* reset iterator */
4724 (void) hv_iterinit(other_hv);
4725 while ( hv_iternext(other_hv) )
4729 other_key_count = HvUSEDKEYS(other_hv);
4731 if (this_key_count != other_key_count)
4736 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4737 AV * const other_av = MUTABLE_AV(SvRV(d));
4738 const I32 other_len = av_len(other_av) + 1;
4740 HV *hv = MUTABLE_HV(SvRV(e));
4742 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4743 for (i = 0; i < other_len; ++i) {
4744 SV ** const svp = av_fetch(other_av, i, FALSE);
4745 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4746 if (svp) { /* ??? When can this not happen? */
4747 if (hv_exists_ent(hv, *svp, 0))
4753 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4754 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4757 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4759 HV *hv = MUTABLE_HV(SvRV(e));
4761 (void) hv_iterinit(hv);
4762 while ( (he = hv_iternext(hv)) ) {
4763 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4764 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4765 (void) hv_iterinit(hv);
4766 destroy_matcher(matcher);
4770 destroy_matcher(matcher);
4776 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4777 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4784 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4785 if (object_on_left) {
4786 goto sm_any_array; /* Treat objects like scalars */
4788 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4789 AV * const other_av = MUTABLE_AV(SvRV(e));
4790 const I32 other_len = av_len(other_av) + 1;
4793 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4794 for (i = 0; i < other_len; ++i) {
4795 SV ** const svp = av_fetch(other_av, i, FALSE);
4797 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4798 if (svp) { /* ??? When can this not happen? */
4799 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4805 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4806 AV *other_av = MUTABLE_AV(SvRV(d));
4807 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4808 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4812 const I32 other_len = av_len(other_av);
4814 if (NULL == seen_this) {
4815 seen_this = newHV();
4816 (void) sv_2mortal(MUTABLE_SV(seen_this));
4818 if (NULL == seen_other) {
4819 seen_other = newHV();
4820 (void) sv_2mortal(MUTABLE_SV(seen_other));
4822 for(i = 0; i <= other_len; ++i) {
4823 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4824 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4826 if (!this_elem || !other_elem) {
4827 if ((this_elem && SvOK(*this_elem))
4828 || (other_elem && SvOK(*other_elem)))
4831 else if (hv_exists_ent(seen_this,
4832 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4833 hv_exists_ent(seen_other,
4834 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4836 if (*this_elem != *other_elem)
4840 (void)hv_store_ent(seen_this,
4841 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4843 (void)hv_store_ent(seen_other,
4844 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4850 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4851 (void) do_smartmatch(seen_this, seen_other, 0);
4853 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4862 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4863 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4866 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4867 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4870 for(i = 0; i <= this_len; ++i) {
4871 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4872 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4873 if (svp && matcher_matches_sv(matcher, *svp)) {
4874 destroy_matcher(matcher);
4878 destroy_matcher(matcher);
4882 else if (!SvOK(d)) {
4883 /* undef ~~ array */
4884 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4887 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4888 for (i = 0; i <= this_len; ++i) {
4889 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4890 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4891 if (!svp || !SvOK(*svp))
4900 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4902 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4903 for (i = 0; i <= this_len; ++i) {
4904 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4911 /* infinite recursion isn't supposed to happen here */
4912 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4913 (void) do_smartmatch(NULL, NULL, 1);
4915 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4924 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4925 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4926 SV *t = d; d = e; e = t;
4927 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4930 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4931 SV *t = d; d = e; e = t;
4932 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4933 goto sm_regex_array;
4936 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4938 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4940 PUSHs(matcher_matches_sv(matcher, d)
4943 destroy_matcher(matcher);
4948 /* See if there is overload magic on left */
4949 else if (object_on_left && SvAMAGIC(d)) {
4951 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4952 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4955 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4963 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4966 else if (!SvOK(d)) {
4967 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4968 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4973 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4974 DEBUG_M(if (SvNIOK(e))
4975 Perl_deb(aTHX_ " applying rule Any-Num\n");
4977 Perl_deb(aTHX_ " applying rule Num-numish\n");
4979 /* numeric comparison */
4982 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4983 (void) Perl_pp_i_eq(aTHX);
4985 (void) Perl_pp_eq(aTHX);
4993 /* As a last resort, use string comparison */
4994 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4997 return Perl_pp_seq(aTHX);
5003 register PERL_CONTEXT *cx;
5004 const I32 gimme = GIMME_V;
5006 /* This is essentially an optimization: if the match
5007 fails, we don't want to push a context and then
5008 pop it again right away, so we skip straight
5009 to the op that follows the leavewhen.
5010 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5012 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5013 RETURNOP(cLOGOP->op_other->op_next);
5015 ENTER_with_name("when");
5018 PUSHBLOCK(cx, CXt_WHEN, SP);
5028 register PERL_CONTEXT *cx;
5033 cxix = dopoptogiven(cxstack_ix);
5035 /* diag_listed_as: Can't "when" outside a topicalizer */
5036 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5037 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5040 assert(CxTYPE(cx) == CXt_WHEN);
5043 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
5044 PL_curpm = newpm; /* pop $1 et al */
5046 LEAVE_with_name("when");
5048 if (cxix < cxstack_ix)
5051 cx = &cxstack[cxix];
5053 if (CxFOREACH(cx)) {
5054 /* clear off anything above the scope we're re-entering */
5055 I32 inner = PL_scopestack_ix;
5058 if (PL_scopestack_ix < inner)
5059 leave_scope(PL_scopestack[PL_scopestack_ix]);
5060 PL_curcop = cx->blk_oldcop;
5062 return cx->blk_loop.my_op->op_nextop;
5065 RETURNOP(cx->blk_givwhen.leave_op);
5072 register PERL_CONTEXT *cx;
5077 PERL_UNUSED_VAR(gimme);
5079 cxix = dopoptowhen(cxstack_ix);
5081 DIE(aTHX_ "Can't \"continue\" outside a when block");
5083 if (cxix < cxstack_ix)
5087 assert(CxTYPE(cx) == CXt_WHEN);
5090 PL_curpm = newpm; /* pop $1 et al */
5092 LEAVE_with_name("when");
5093 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5100 register PERL_CONTEXT *cx;
5102 cxix = dopoptogiven(cxstack_ix);
5104 DIE(aTHX_ "Can't \"break\" outside a given block");
5106 cx = &cxstack[cxix];
5108 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5110 if (cxix < cxstack_ix)
5113 /* Restore the sp at the time we entered the given block */
5116 return cx->blk_givwhen.leave_op;
5120 S_doparseform(pTHX_ SV *sv)
5123 register char *s = SvPV(sv, len);
5124 register char *send;
5125 register char *base = NULL; /* start of current field */
5126 register I32 skipspaces = 0; /* number of contiguous spaces seen */
5127 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5128 bool repeat = FALSE; /* ~~ seen on this line */
5129 bool postspace = FALSE; /* a text field may need right padding */
5132 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5134 bool ischop; /* it's a ^ rather than a @ */
5135 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5136 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5140 PERL_ARGS_ASSERT_DOPARSEFORM;
5143 Perl_croak(aTHX_ "Null picture in formline");
5145 if (SvTYPE(sv) >= SVt_PVMG) {
5146 /* This might, of course, still return NULL. */
5147 mg = mg_find(sv, PERL_MAGIC_fm);
5149 sv_upgrade(sv, SVt_PVMG);
5153 /* still the same as previously-compiled string? */
5154 SV *old = mg->mg_obj;
5155 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5156 && len == SvCUR(old)
5157 && strnEQ(SvPVX(old), SvPVX(sv), len)
5159 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5163 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5164 Safefree(mg->mg_ptr);
5170 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5171 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5174 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5175 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5179 /* estimate the buffer size needed */
5180 for (base = s; s <= send; s++) {
5181 if (*s == '\n' || *s == '@' || *s == '^')
5187 Newx(fops, maxops, U32);
5192 *fpc++ = FF_LINEMARK;
5193 noblank = repeat = FALSE;
5211 case ' ': case '\t':
5218 } /* else FALL THROUGH */
5226 *fpc++ = FF_LITERAL;
5234 *fpc++ = (U32)skipspaces;
5238 *fpc++ = FF_NEWLINE;
5242 arg = fpc - linepc + 1;
5249 *fpc++ = FF_LINEMARK;
5250 noblank = repeat = FALSE;
5259 ischop = s[-1] == '^';
5265 arg = (s - base) - 1;
5267 *fpc++ = FF_LITERAL;
5273 if (*s == '*') { /* @* or ^* */
5275 *fpc++ = 2; /* skip the @* or ^* */
5277 *fpc++ = FF_LINESNGL;
5280 *fpc++ = FF_LINEGLOB;
5282 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5283 arg = ischop ? FORM_NUM_BLANK : 0;
5288 const char * const f = ++s;
5291 arg |= FORM_NUM_POINT + (s - f);
5293 *fpc++ = s - base; /* fieldsize for FETCH */
5294 *fpc++ = FF_DECIMAL;
5296 unchopnum |= ! ischop;
5298 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5299 arg = ischop ? FORM_NUM_BLANK : 0;
5301 s++; /* skip the '0' first */
5305 const char * const f = ++s;
5308 arg |= FORM_NUM_POINT + (s - f);
5310 *fpc++ = s - base; /* fieldsize for FETCH */
5311 *fpc++ = FF_0DECIMAL;
5313 unchopnum |= ! ischop;
5315 else { /* text field */
5317 bool ismore = FALSE;
5320 while (*++s == '>') ;
5321 prespace = FF_SPACE;
5323 else if (*s == '|') {
5324 while (*++s == '|') ;
5325 prespace = FF_HALFSPACE;
5330 while (*++s == '<') ;
5333 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5337 *fpc++ = s - base; /* fieldsize for FETCH */
5339 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5342 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5356 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5359 mg->mg_ptr = (char *) fops;
5360 mg->mg_len = arg * sizeof(U32);
5361 mg->mg_obj = sv_copy;
5362 mg->mg_flags |= MGf_REFCOUNTED;
5364 if (unchopnum && repeat)
5365 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5372 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5374 /* Can value be printed in fldsize chars, using %*.*f ? */
5378 int intsize = fldsize - (value < 0 ? 1 : 0);
5380 if (frcsize & FORM_NUM_POINT)
5382 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5385 while (intsize--) pwr *= 10.0;
5386 while (frcsize--) eps /= 10.0;
5389 if (value + eps >= pwr)
5392 if (value - eps <= -pwr)
5399 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5402 SV * const datasv = FILTER_DATA(idx);
5403 const int filter_has_file = IoLINES(datasv);
5404 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5405 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5410 char *prune_from = NULL;
5411 bool read_from_cache = FALSE;
5414 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5416 assert(maxlen >= 0);
5419 /* I was having segfault trouble under Linux 2.2.5 after a
5420 parse error occured. (Had to hack around it with a test
5421 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5422 not sure where the trouble is yet. XXX */
5425 SV *const cache = datasv;
5428 const char *cache_p = SvPV(cache, cache_len);
5432 /* Running in block mode and we have some cached data already.
5434 if (cache_len >= umaxlen) {
5435 /* In fact, so much data we don't even need to call
5440 const char *const first_nl =
5441 (const char *)memchr(cache_p, '\n', cache_len);
5443 take = first_nl + 1 - cache_p;
5447 sv_catpvn(buf_sv, cache_p, take);
5448 sv_chop(cache, cache_p + take);
5449 /* Definitely not EOF */
5453 sv_catsv(buf_sv, cache);
5455 umaxlen -= cache_len;
5458 read_from_cache = TRUE;
5462 /* Filter API says that the filter appends to the contents of the buffer.
5463 Usually the buffer is "", so the details don't matter. But if it's not,
5464 then clearly what it contains is already filtered by this filter, so we
5465 don't want to pass it in a second time.
5466 I'm going to use a mortal in case the upstream filter croaks. */
5467 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5468 ? sv_newmortal() : buf_sv;
5469 SvUPGRADE(upstream, SVt_PV);
5471 if (filter_has_file) {
5472 status = FILTER_READ(idx+1, upstream, 0);
5475 if (filter_sub && status >= 0) {
5479 ENTER_with_name("call_filter_sub");
5484 DEFSV_set(upstream);
5488 PUSHs(filter_state);
5491 count = call_sv(filter_sub, G_SCALAR);
5503 LEAVE_with_name("call_filter_sub");
5506 if(SvOK(upstream)) {
5507 got_p = SvPV(upstream, got_len);
5509 if (got_len > umaxlen) {
5510 prune_from = got_p + umaxlen;
5513 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5514 if (first_nl && first_nl + 1 < got_p + got_len) {
5515 /* There's a second line here... */
5516 prune_from = first_nl + 1;
5521 /* Oh. Too long. Stuff some in our cache. */
5522 STRLEN cached_len = got_p + got_len - prune_from;
5523 SV *const cache = datasv;
5526 /* Cache should be empty. */
5527 assert(!SvCUR(cache));
5530 sv_setpvn(cache, prune_from, cached_len);
5531 /* If you ask for block mode, you may well split UTF-8 characters.
5532 "If it breaks, you get to keep both parts"
5533 (Your code is broken if you don't put them back together again
5534 before something notices.) */
5535 if (SvUTF8(upstream)) {
5538 SvCUR_set(upstream, got_len - cached_len);
5540 /* Can't yet be EOF */
5545 /* If they are at EOF but buf_sv has something in it, then they may never
5546 have touched the SV upstream, so it may be undefined. If we naively
5547 concatenate it then we get a warning about use of uninitialised value.
5549 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5550 sv_catsv(buf_sv, upstream);
5554 IoLINES(datasv) = 0;
5556 SvREFCNT_dec(filter_state);
5557 IoTOP_GV(datasv) = NULL;
5560 SvREFCNT_dec(filter_sub);
5561 IoBOTTOM_GV(datasv) = NULL;
5563 filter_del(S_run_user_filter);
5565 if (status == 0 && read_from_cache) {
5566 /* If we read some data from the cache (and by getting here it implies
5567 that we emptied the cache) then we aren't yet at EOF, and mustn't
5568 report that to our caller. */
5574 /* perhaps someone can come up with a better name for
5575 this? it is not really "absolute", per se ... */
5577 S_path_is_absolute(const char *name)
5579 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5581 if (PERL_FILE_IS_ABSOLUTE(name)
5583 || (*name == '.' && ((name[1] == '/' ||
5584 (name[1] == '.' && name[2] == '/'))
5585 || (name[1] == '\\' ||
5586 ( name[1] == '.' && name[2] == '\\')))
5589 || (*name == '.' && (name[1] == '/' ||
5590 (name[1] == '.' && name[2] == '/')))
5602 * c-indentation-style: bsd
5604 * indent-tabs-mode: t
5607 * ex: set ts=8 sts=4 sw=4 noet: