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;
88 const regexp_engine *eng;
91 if (PL_op->op_flags & OPf_STACKED) {
101 /* prevent recompiling under /o and ithreads. */
102 #if defined(USE_ITHREADS)
103 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
110 assert (re != (REGEXP*) &PL_sv_undef);
111 eng = re ? RX_ENGINE(re) : current_re_engine();
113 if (PL_op->op_flags & OPf_SPECIAL)
114 PL_reginterp_cnt = (I32_MAX>>1); /* Mark as safe. */
116 new_re = (eng->op_comp
118 : &Perl_re_op_compile
119 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
121 (pm->op_pmflags & RXf_PMf_COMPILETIME),
123 if (pm->op_pmflags & PMf_HAS_CV)
124 ((struct regexp *)SvANY(new_re))->qr_anoncv
125 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
129 /* The match's LHS's get-magic might need to access this op's regexp
130 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
131 get-magic now before we replace the regexp. Hopefully this hack can
132 be replaced with the approach described at
133 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
135 if (pm->op_type == OP_MATCH) {
137 const bool was_tainted = PL_tainted;
138 if (pm->op_flags & OPf_STACKED)
140 else if (pm->op_private & OPpTARGET_MY)
141 lhs = PAD_SV(pm->op_targ);
144 /* Restore the previous value of PL_tainted (which may have been
145 modified by get-magic), to avoid incorrectly setting the
146 RXf_TAINTED flag further down. */
147 PL_tainted = was_tainted;
149 tmp = reg_temp_copy(NULL, new_re);
150 ReREFCNT_dec(new_re);
155 PM_SETRE(pm, new_re);
158 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
159 inside tie/overload accessors. */
160 #ifndef INCOMPLETE_TAINTS
161 if (PL_tainting && PL_tainted) {
162 SvTAINTED_on((SV*)new_re);
163 RX_EXTFLAGS(new_re) |= RXf_TAINTED;
167 #if !defined(USE_ITHREADS)
168 /* can't change the optree at runtime either */
169 /* PMf_KEEP is handled differently under threads to avoid these problems */
170 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
172 if (pm->op_pmflags & PMf_KEEP) {
173 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
174 cLOGOP->op_first->op_next = PL_op->op_next;
187 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
188 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
189 register SV * const dstr = cx->sb_dstr;
190 register char *s = cx->sb_s;
191 register char *m = cx->sb_m;
192 char *orig = cx->sb_orig;
193 register REGEXP * const rx = cx->sb_rx;
195 REGEXP *old = PM_GETRE(pm);
202 PM_SETRE(pm,ReREFCNT_inc(rx));
205 rxres_restore(&cx->sb_rxres, rx);
206 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
208 if (cx->sb_iters++) {
209 const I32 saviters = cx->sb_iters;
210 if (cx->sb_iters > cx->sb_maxiters)
211 DIE(aTHX_ "Substitution loop");
213 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
215 /* See "how taint works" above pp_subst() */
217 cx->sb_rxtainted |= SUBST_TAINT_REPL;
218 sv_catsv_nomg(dstr, POPs);
219 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
223 if (CxONCE(cx) || s < orig ||
224 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
226 ((cx->sb_rflags & REXEC_COPY_STR)
227 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
228 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
230 SV *targ = cx->sb_targ;
232 assert(cx->sb_strend >= s);
233 if(cx->sb_strend > s) {
234 if (DO_UTF8(dstr) && !SvUTF8(targ))
235 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
237 sv_catpvn(dstr, s, cx->sb_strend - s);
239 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
240 cx->sb_rxtainted |= SUBST_TAINT_PAT;
242 if (pm->op_pmflags & PMf_NONDESTRUCT) {
244 /* From here on down we're using the copy, and leaving the
245 original untouched. */
250 sv_force_normal_flags(targ, SV_COW_DROP_PV);
255 SvPV_set(targ, SvPVX(dstr));
256 SvCUR_set(targ, SvCUR(dstr));
257 SvLEN_set(targ, SvLEN(dstr));
260 SvPV_set(dstr, NULL);
262 mPUSHi(saviters - 1);
264 (void)SvPOK_only_UTF8(targ);
267 /* update the taint state of various various variables in
268 * preparation for final exit.
269 * See "how taint works" above pp_subst() */
271 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
272 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
273 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
275 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
277 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
278 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
280 SvTAINTED_on(TOPs); /* taint return value */
281 /* needed for mg_set below */
282 PL_tainted = cBOOL(cx->sb_rxtainted &
283 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
286 /* PL_tainted must be correctly set for this mg_set */
289 LEAVE_SCOPE(cx->sb_oldsave);
291 RETURNOP(pm->op_next);
294 cx->sb_iters = saviters;
296 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
299 cx->sb_orig = orig = RX_SUBBEG(rx);
301 cx->sb_strend = s + (cx->sb_strend - m);
303 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
305 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
306 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
308 sv_catpvn(dstr, s, m-s);
310 cx->sb_s = RX_OFFS(rx)[0].end + orig;
311 { /* Update the pos() information. */
313 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
315 SvUPGRADE(sv, SVt_PVMG);
316 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
317 #ifdef PERL_OLD_COPY_ON_WRITE
319 sv_force_normal_flags(sv, 0);
321 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
324 mg->mg_len = m - orig;
327 (void)ReREFCNT_inc(rx);
328 /* update the taint state of various various variables in preparation
329 * for calling the code block.
330 * See "how taint works" above pp_subst() */
332 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
333 cx->sb_rxtainted |= SUBST_TAINT_PAT;
335 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
336 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
337 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
339 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
341 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
342 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
343 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
344 ? cx->sb_dstr : cx->sb_targ);
347 rxres_save(&cx->sb_rxres, rx);
349 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
353 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
358 PERL_ARGS_ASSERT_RXRES_SAVE;
361 if (!p || p[1] < RX_NPARENS(rx)) {
362 #ifdef PERL_OLD_COPY_ON_WRITE
363 i = 7 + RX_NPARENS(rx) * 2;
365 i = 6 + RX_NPARENS(rx) * 2;
374 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
375 RX_MATCH_COPIED_off(rx);
377 #ifdef PERL_OLD_COPY_ON_WRITE
378 *p++ = PTR2UV(RX_SAVED_COPY(rx));
379 RX_SAVED_COPY(rx) = NULL;
382 *p++ = RX_NPARENS(rx);
384 *p++ = PTR2UV(RX_SUBBEG(rx));
385 *p++ = (UV)RX_SUBLEN(rx);
386 for (i = 0; i <= RX_NPARENS(rx); ++i) {
387 *p++ = (UV)RX_OFFS(rx)[i].start;
388 *p++ = (UV)RX_OFFS(rx)[i].end;
393 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
398 PERL_ARGS_ASSERT_RXRES_RESTORE;
401 RX_MATCH_COPY_FREE(rx);
402 RX_MATCH_COPIED_set(rx, *p);
405 #ifdef PERL_OLD_COPY_ON_WRITE
406 if (RX_SAVED_COPY(rx))
407 SvREFCNT_dec (RX_SAVED_COPY(rx));
408 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
412 RX_NPARENS(rx) = *p++;
414 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
415 RX_SUBLEN(rx) = (I32)(*p++);
416 for (i = 0; i <= RX_NPARENS(rx); ++i) {
417 RX_OFFS(rx)[i].start = (I32)(*p++);
418 RX_OFFS(rx)[i].end = (I32)(*p++);
423 S_rxres_free(pTHX_ void **rsp)
425 UV * const p = (UV*)*rsp;
427 PERL_ARGS_ASSERT_RXRES_FREE;
432 void *tmp = INT2PTR(char*,*p);
435 PoisonFree(*p, 1, sizeof(*p));
437 Safefree(INT2PTR(char*,*p));
439 #ifdef PERL_OLD_COPY_ON_WRITE
441 SvREFCNT_dec (INT2PTR(SV*,p[1]));
449 #define FORM_NUM_BLANK (1<<30)
450 #define FORM_NUM_POINT (1<<29)
454 dVAR; dSP; dMARK; dORIGMARK;
455 register SV * const tmpForm = *++MARK;
456 SV *formsv; /* contains text of original format */
457 register U32 *fpc; /* format ops program counter */
458 register char *t; /* current append position in target string */
459 const char *f; /* current position in format string */
461 register SV *sv = NULL; /* current item */
462 const char *item = NULL;/* string value of current item */
463 I32 itemsize = 0; /* length of current item, possibly truncated */
464 I32 fieldsize = 0; /* width of current field */
465 I32 lines = 0; /* number of lines that have been output */
466 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
467 const char *chophere = NULL; /* where to chop current item */
468 STRLEN linemark = 0; /* pos of start of line in output */
470 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
472 STRLEN linemax; /* estimate of output size in bytes */
473 bool item_is_utf8 = FALSE;
474 bool targ_is_utf8 = FALSE;
477 U8 *source; /* source of bytes to append */
478 STRLEN to_copy; /* how may bytes to append */
479 char trans; /* what chars to translate */
481 mg = doparseform(tmpForm);
483 fpc = (U32*)mg->mg_ptr;
484 /* the actual string the format was compiled from.
485 * with overload etc, this may not match tmpForm */
489 SvPV_force(PL_formtarget, len);
490 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
491 SvTAINTED_on(PL_formtarget);
492 if (DO_UTF8(PL_formtarget))
494 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
495 t = SvGROW(PL_formtarget, len + linemax + 1);
496 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
498 f = SvPV_const(formsv, len);
502 const char *name = "???";
505 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
506 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
507 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
508 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
509 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
511 case FF_CHECKNL: name = "CHECKNL"; break;
512 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
513 case FF_SPACE: name = "SPACE"; break;
514 case FF_HALFSPACE: name = "HALFSPACE"; break;
515 case FF_ITEM: name = "ITEM"; break;
516 case FF_CHOP: name = "CHOP"; break;
517 case FF_LINEGLOB: name = "LINEGLOB"; break;
518 case FF_NEWLINE: name = "NEWLINE"; break;
519 case FF_MORE: name = "MORE"; break;
520 case FF_LINEMARK: name = "LINEMARK"; break;
521 case FF_END: name = "END"; break;
522 case FF_0DECIMAL: name = "0DECIMAL"; break;
523 case FF_LINESNGL: name = "LINESNGL"; break;
526 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
528 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
532 linemark = t - SvPVX(PL_formtarget);
542 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
558 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
561 SvTAINTED_on(PL_formtarget);
567 const char *s = item = SvPV_const(sv, len);
570 itemsize = sv_len_utf8(sv);
571 if (itemsize != (I32)len) {
573 if (itemsize > fieldsize) {
574 itemsize = fieldsize;
575 itembytes = itemsize;
576 sv_pos_u2b(sv, &itembytes, 0);
580 send = chophere = s + itembytes;
590 sv_pos_b2u(sv, &itemsize);
594 item_is_utf8 = FALSE;
595 if (itemsize > fieldsize)
596 itemsize = fieldsize;
597 send = chophere = s + itemsize;
611 const char *s = item = SvPV_const(sv, len);
614 itemsize = sv_len_utf8(sv);
615 if (itemsize != (I32)len) {
617 if (itemsize <= fieldsize) {
618 const char *send = chophere = s + itemsize;
631 itemsize = fieldsize;
632 itembytes = itemsize;
633 sv_pos_u2b(sv, &itembytes, 0);
634 send = chophere = s + itembytes;
635 while (s < send || (s == send && isSPACE(*s))) {
645 if (strchr(PL_chopset, *s))
650 itemsize = chophere - item;
651 sv_pos_b2u(sv, &itemsize);
657 item_is_utf8 = FALSE;
658 if (itemsize <= fieldsize) {
659 const char *const send = chophere = s + itemsize;
672 itemsize = fieldsize;
673 send = chophere = s + itemsize;
674 while (s < send || (s == send && isSPACE(*s))) {
684 if (strchr(PL_chopset, *s))
689 itemsize = chophere - item;
695 arg = fieldsize - itemsize;
704 arg = fieldsize - itemsize;
718 /* convert to_copy from chars to bytes */
722 to_copy = s - source;
728 const char *s = chophere;
742 const bool oneline = fpc[-1] == FF_LINESNGL;
743 const char *s = item = SvPV_const(sv, len);
744 const char *const send = s + len;
746 item_is_utf8 = DO_UTF8(sv);
757 to_copy = s - SvPVX_const(sv) - 1;
771 /* append to_copy bytes from source to PL_formstring.
772 * item_is_utf8 implies source is utf8.
773 * if trans, translate certain characters during the copy */
778 SvCUR_set(PL_formtarget,
779 t - SvPVX_const(PL_formtarget));
781 if (targ_is_utf8 && !item_is_utf8) {
782 source = tmp = bytes_to_utf8(source, &to_copy);
784 if (item_is_utf8 && !targ_is_utf8) {
786 /* Upgrade targ to UTF8, and then we reduce it to
787 a problem we have a simple solution for.
788 Don't need get magic. */
789 sv_utf8_upgrade_nomg(PL_formtarget);
791 /* re-calculate linemark */
792 s = (U8*)SvPVX(PL_formtarget);
793 /* the bytes we initially allocated to append the
794 * whole line may have been gobbled up during the
795 * upgrade, so allocate a whole new line's worth
800 linemark = s - (U8*)SvPVX(PL_formtarget);
802 /* Easy. They agree. */
803 assert (item_is_utf8 == targ_is_utf8);
806 /* @* and ^* are the only things that can exceed
807 * the linemax, so grow by the output size, plus
808 * a whole new form's worth in case of any further
810 grow = linemax + to_copy;
812 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
813 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
815 Copy(source, t, to_copy, char);
817 /* blank out ~ or control chars, depending on trans.
818 * works on bytes not chars, so relies on not
819 * matching utf8 continuation bytes */
821 U8 *send = s + to_copy;
824 if (trans == '~' ? (ch == '~') :
837 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
845 #if defined(USE_LONG_DOUBLE)
847 ((arg & FORM_NUM_POINT) ?
848 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
851 ((arg & FORM_NUM_POINT) ?
852 "%#0*.*f" : "%0*.*f");
857 #if defined(USE_LONG_DOUBLE)
859 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
862 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
865 /* If the field is marked with ^ and the value is undefined,
867 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
875 /* overflow evidence */
876 if (num_overflow(value, fieldsize, arg)) {
882 /* Formats aren't yet marked for locales, so assume "yes". */
884 STORE_NUMERIC_STANDARD_SET_LOCAL();
885 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
886 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
887 RESTORE_NUMERIC_STANDARD();
894 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
902 if (arg) { /* repeat until fields exhausted? */
908 t = SvPVX(PL_formtarget) + linemark;
915 const char *s = chophere;
916 const char *send = item + len;
918 while (isSPACE(*s) && (s < send))
923 arg = fieldsize - itemsize;
930 if (strnEQ(s1," ",3)) {
931 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
942 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
944 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
946 SvUTF8_on(PL_formtarget);
947 FmLINES(PL_formtarget) += lines;
949 if (fpc[-1] == FF_BLANK)
950 RETURNOP(cLISTOP->op_first);
962 if (PL_stack_base + *PL_markstack_ptr == SP) {
964 if (GIMME_V == G_SCALAR)
966 RETURNOP(PL_op->op_next->op_next);
968 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
969 Perl_pp_pushmark(aTHX); /* push dst */
970 Perl_pp_pushmark(aTHX); /* push src */
971 ENTER_with_name("grep"); /* enter outer scope */
974 if (PL_op->op_private & OPpGREP_LEX)
975 SAVESPTR(PAD_SVl(PL_op->op_targ));
978 ENTER_with_name("grep_item"); /* enter inner scope */
981 src = PL_stack_base[*PL_markstack_ptr];
983 if (PL_op->op_private & OPpGREP_LEX)
984 PAD_SVl(PL_op->op_targ) = src;
989 if (PL_op->op_type == OP_MAPSTART)
990 Perl_pp_pushmark(aTHX); /* push top */
991 return ((LOGOP*)PL_op->op_next)->op_other;
997 const I32 gimme = GIMME_V;
998 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1004 /* first, move source pointer to the next item in the source list */
1005 ++PL_markstack_ptr[-1];
1007 /* if there are new items, push them into the destination list */
1008 if (items && gimme != G_VOID) {
1009 /* might need to make room back there first */
1010 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1011 /* XXX this implementation is very pessimal because the stack
1012 * is repeatedly extended for every set of items. Is possible
1013 * to do this without any stack extension or copying at all
1014 * by maintaining a separate list over which the map iterates
1015 * (like foreach does). --gsar */
1017 /* everything in the stack after the destination list moves
1018 * towards the end the stack by the amount of room needed */
1019 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1021 /* items to shift up (accounting for the moved source pointer) */
1022 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1024 /* This optimization is by Ben Tilly and it does
1025 * things differently from what Sarathy (gsar)
1026 * is describing. The downside of this optimization is
1027 * that leaves "holes" (uninitialized and hopefully unused areas)
1028 * to the Perl stack, but on the other hand this
1029 * shouldn't be a problem. If Sarathy's idea gets
1030 * implemented, this optimization should become
1031 * irrelevant. --jhi */
1033 shift = count; /* Avoid shifting too often --Ben Tilly */
1037 dst = (SP += shift);
1038 PL_markstack_ptr[-1] += shift;
1039 *PL_markstack_ptr += shift;
1043 /* copy the new items down to the destination list */
1044 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1045 if (gimme == G_ARRAY) {
1046 /* add returned items to the collection (making mortal copies
1047 * if necessary), then clear the current temps stack frame
1048 * *except* for those items. We do this splicing the items
1049 * into the start of the tmps frame (so some items may be on
1050 * the tmps stack twice), then moving PL_tmps_floor above
1051 * them, then freeing the frame. That way, the only tmps that
1052 * accumulate over iterations are the return values for map.
1053 * We have to do to this way so that everything gets correctly
1054 * freed if we die during the map.
1058 /* make space for the slice */
1059 EXTEND_MORTAL(items);
1060 tmpsbase = PL_tmps_floor + 1;
1061 Move(PL_tmps_stack + tmpsbase,
1062 PL_tmps_stack + tmpsbase + items,
1063 PL_tmps_ix - PL_tmps_floor,
1065 PL_tmps_ix += items;
1070 sv = sv_mortalcopy(sv);
1072 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1074 /* clear the stack frame except for the items */
1075 PL_tmps_floor += items;
1077 /* FREETMPS may have cleared the TEMP flag on some of the items */
1080 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1083 /* scalar context: we don't care about which values map returns
1084 * (we use undef here). And so we certainly don't want to do mortal
1085 * copies of meaningless values. */
1086 while (items-- > 0) {
1088 *dst-- = &PL_sv_undef;
1096 LEAVE_with_name("grep_item"); /* exit inner scope */
1099 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1101 (void)POPMARK; /* pop top */
1102 LEAVE_with_name("grep"); /* exit outer scope */
1103 (void)POPMARK; /* pop src */
1104 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1105 (void)POPMARK; /* pop dst */
1106 SP = PL_stack_base + POPMARK; /* pop original mark */
1107 if (gimme == G_SCALAR) {
1108 if (PL_op->op_private & OPpGREP_LEX) {
1109 SV* sv = sv_newmortal();
1110 sv_setiv(sv, items);
1118 else if (gimme == G_ARRAY)
1125 ENTER_with_name("grep_item"); /* enter inner scope */
1128 /* set $_ to the new source item */
1129 src = PL_stack_base[PL_markstack_ptr[-1]];
1131 if (PL_op->op_private & OPpGREP_LEX)
1132 PAD_SVl(PL_op->op_targ) = src;
1136 RETURNOP(cLOGOP->op_other);
1145 if (GIMME == G_ARRAY)
1147 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1148 return cLOGOP->op_other;
1158 if (GIMME == G_ARRAY) {
1159 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1163 SV * const targ = PAD_SV(PL_op->op_targ);
1166 if (PL_op->op_private & OPpFLIP_LINENUM) {
1167 if (GvIO(PL_last_in_gv)) {
1168 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1171 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1173 flip = SvIV(sv) == SvIV(GvSV(gv));
1179 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1180 if (PL_op->op_flags & OPf_SPECIAL) {
1188 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1191 sv_setpvs(TARG, "");
1197 /* This code tries to decide if "$left .. $right" should use the
1198 magical string increment, or if the range is numeric (we make
1199 an exception for .."0" [#18165]). AMS 20021031. */
1201 #define RANGE_IS_NUMERIC(left,right) ( \
1202 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1203 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1204 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1205 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1206 && (!SvOK(right) || looks_like_number(right))))
1212 if (GIMME == G_ARRAY) {
1218 if (RANGE_IS_NUMERIC(left,right)) {
1221 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1222 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1223 DIE(aTHX_ "Range iterator outside integer range");
1224 i = SvIV_nomg(left);
1225 max = SvIV_nomg(right);
1234 SV * const sv = sv_2mortal(newSViv(i++));
1240 const char * const lpv = SvPV_nomg_const(left, llen);
1241 const char * const tmps = SvPV_nomg_const(right, len);
1243 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1244 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1246 if (strEQ(SvPVX_const(sv),tmps))
1248 sv = sv_2mortal(newSVsv(sv));
1255 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1259 if (PL_op->op_private & OPpFLIP_LINENUM) {
1260 if (GvIO(PL_last_in_gv)) {
1261 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1264 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1265 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1273 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1274 sv_catpvs(targ, "E0");
1284 static const char * const context_name[] = {
1286 NULL, /* CXt_WHEN never actually needs "block" */
1287 NULL, /* CXt_BLOCK never actually needs "block" */
1288 NULL, /* CXt_GIVEN never actually needs "block" */
1289 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1290 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1291 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1292 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1300 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1305 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1307 for (i = cxstack_ix; i >= 0; i--) {
1308 register const PERL_CONTEXT * const cx = &cxstack[i];
1309 switch (CxTYPE(cx)) {
1315 /* diag_listed_as: Exiting subroutine via %s */
1316 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1317 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1318 if (CxTYPE(cx) == CXt_NULL)
1321 case CXt_LOOP_LAZYIV:
1322 case CXt_LOOP_LAZYSV:
1324 case CXt_LOOP_PLAIN:
1326 STRLEN cx_label_len = 0;
1327 U32 cx_label_flags = 0;
1328 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1330 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1333 (const U8*)cx_label, cx_label_len,
1334 (const U8*)label, len) == 0)
1336 (const U8*)label, len,
1337 (const U8*)cx_label, cx_label_len) == 0)
1338 : (len == cx_label_len && ((cx_label == label)
1339 || memEQ(cx_label, label, len))) )) {
1340 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1341 (long)i, cx_label));
1344 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1355 Perl_dowantarray(pTHX)
1358 const I32 gimme = block_gimme();
1359 return (gimme == G_VOID) ? G_SCALAR : gimme;
1363 Perl_block_gimme(pTHX)
1366 const I32 cxix = dopoptosub(cxstack_ix);
1370 switch (cxstack[cxix].blk_gimme) {
1378 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1385 Perl_is_lvalue_sub(pTHX)
1388 const I32 cxix = dopoptosub(cxstack_ix);
1389 assert(cxix >= 0); /* We should only be called from inside subs */
1391 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1392 return CxLVAL(cxstack + cxix);
1397 /* only used by PUSHSUB */
1399 Perl_was_lvalue_sub(pTHX)
1402 const I32 cxix = dopoptosub(cxstack_ix-1);
1403 assert(cxix >= 0); /* We should only be called from inside subs */
1405 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1406 return CxLVAL(cxstack + cxix);
1412 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1417 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1419 for (i = startingblock; i >= 0; i--) {
1420 register const PERL_CONTEXT * const cx = &cxstk[i];
1421 switch (CxTYPE(cx)) {
1427 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1435 S_dopoptoeval(pTHX_ I32 startingblock)
1439 for (i = startingblock; i >= 0; i--) {
1440 register const PERL_CONTEXT *cx = &cxstack[i];
1441 switch (CxTYPE(cx)) {
1445 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1453 S_dopoptoloop(pTHX_ I32 startingblock)
1457 for (i = startingblock; i >= 0; i--) {
1458 register const PERL_CONTEXT * const cx = &cxstack[i];
1459 switch (CxTYPE(cx)) {
1465 /* diag_listed_as: Exiting subroutine via %s */
1466 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1467 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1468 if ((CxTYPE(cx)) == CXt_NULL)
1471 case CXt_LOOP_LAZYIV:
1472 case CXt_LOOP_LAZYSV:
1474 case CXt_LOOP_PLAIN:
1475 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1483 S_dopoptogiven(pTHX_ I32 startingblock)
1487 for (i = startingblock; i >= 0; i--) {
1488 register const PERL_CONTEXT *cx = &cxstack[i];
1489 switch (CxTYPE(cx)) {
1493 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1495 case CXt_LOOP_PLAIN:
1496 assert(!CxFOREACHDEF(cx));
1498 case CXt_LOOP_LAZYIV:
1499 case CXt_LOOP_LAZYSV:
1501 if (CxFOREACHDEF(cx)) {
1502 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1511 S_dopoptowhen(pTHX_ I32 startingblock)
1515 for (i = startingblock; i >= 0; i--) {
1516 register const PERL_CONTEXT *cx = &cxstack[i];
1517 switch (CxTYPE(cx)) {
1521 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1529 Perl_dounwind(pTHX_ I32 cxix)
1534 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1537 while (cxstack_ix > cxix) {
1539 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1540 DEBUG_CX("UNWIND"); \
1541 /* Note: we don't need to restore the base context info till the end. */
1542 switch (CxTYPE(cx)) {
1545 continue; /* not break */
1553 case CXt_LOOP_LAZYIV:
1554 case CXt_LOOP_LAZYSV:
1556 case CXt_LOOP_PLAIN:
1567 PERL_UNUSED_VAR(optype);
1571 Perl_qerror(pTHX_ SV *err)
1575 PERL_ARGS_ASSERT_QERROR;
1578 if (PL_in_eval & EVAL_KEEPERR) {
1579 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1583 sv_catsv(ERRSV, err);
1586 sv_catsv(PL_errors, err);
1588 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1590 ++PL_parser->error_count;
1594 Perl_die_unwind(pTHX_ SV *msv)
1597 SV *exceptsv = sv_mortalcopy(msv);
1598 U8 in_eval = PL_in_eval;
1599 PERL_ARGS_ASSERT_DIE_UNWIND;
1606 * Historically, perl used to set ERRSV ($@) early in the die
1607 * process and rely on it not getting clobbered during unwinding.
1608 * That sucked, because it was liable to get clobbered, so the
1609 * setting of ERRSV used to emit the exception from eval{} has
1610 * been moved to much later, after unwinding (see just before
1611 * JMPENV_JUMP below). However, some modules were relying on the
1612 * early setting, by examining $@ during unwinding to use it as
1613 * a flag indicating whether the current unwinding was caused by
1614 * an exception. It was never a reliable flag for that purpose,
1615 * being totally open to false positives even without actual
1616 * clobberage, but was useful enough for production code to
1617 * semantically rely on it.
1619 * We'd like to have a proper introspective interface that
1620 * explicitly describes the reason for whatever unwinding
1621 * operations are currently in progress, so that those modules
1622 * work reliably and $@ isn't further overloaded. But we don't
1623 * have one yet. In its absence, as a stopgap measure, ERRSV is
1624 * now *additionally* set here, before unwinding, to serve as the
1625 * (unreliable) flag that it used to.
1627 * This behaviour is temporary, and should be removed when a
1628 * proper way to detect exceptional unwinding has been developed.
1629 * As of 2010-12, the authors of modules relying on the hack
1630 * are aware of the issue, because the modules failed on
1631 * perls 5.13.{1..7} which had late setting of $@ without this
1632 * early-setting hack.
1634 if (!(in_eval & EVAL_KEEPERR)) {
1635 SvTEMP_off(exceptsv);
1636 sv_setsv(ERRSV, exceptsv);
1639 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1640 && PL_curstackinfo->si_prev)
1649 register PERL_CONTEXT *cx;
1652 JMPENV *restartjmpenv;
1655 if (cxix < cxstack_ix)
1658 POPBLOCK(cx,PL_curpm);
1659 if (CxTYPE(cx) != CXt_EVAL) {
1661 const char* message = SvPVx_const(exceptsv, msglen);
1662 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1663 PerlIO_write(Perl_error_log, message, msglen);
1667 namesv = cx->blk_eval.old_namesv;
1668 oldcop = cx->blk_oldcop;
1669 restartjmpenv = cx->blk_eval.cur_top_env;
1670 restartop = cx->blk_eval.retop;
1672 if (gimme == G_SCALAR)
1673 *++newsp = &PL_sv_undef;
1674 PL_stack_sp = newsp;
1678 /* LEAVE could clobber PL_curcop (see save_re_context())
1679 * XXX it might be better to find a way to avoid messing with
1680 * PL_curcop in save_re_context() instead, but this is a more
1681 * minimal fix --GSAR */
1684 if (optype == OP_REQUIRE) {
1685 (void)hv_store(GvHVn(PL_incgv),
1686 SvPVX_const(namesv),
1687 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1689 /* note that unlike pp_entereval, pp_require isn't
1690 * supposed to trap errors. So now that we've popped the
1691 * EVAL that pp_require pushed, and processed the error
1692 * message, rethrow the error */
1693 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1694 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1697 if (in_eval & EVAL_KEEPERR) {
1698 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1702 sv_setsv(ERRSV, exceptsv);
1704 PL_restartjmpenv = restartjmpenv;
1705 PL_restartop = restartop;
1711 write_to_stderr(exceptsv);
1718 dVAR; dSP; dPOPTOPssrl;
1719 if (SvTRUE(left) != SvTRUE(right))
1726 =for apidoc caller_cx
1728 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1729 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1730 information returned to Perl by C<caller>. Note that XSUBs don't get a
1731 stack frame, so C<caller_cx(0, NULL)> will return information for the
1732 immediately-surrounding Perl code.
1734 This function skips over the automatic calls to C<&DB::sub> made on the
1735 behalf of the debugger. If the stack frame requested was a sub called by
1736 C<DB::sub>, the return value will be the frame for the call to
1737 C<DB::sub>, since that has the correct line number/etc. for the call
1738 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1739 frame for the sub call itself.
1744 const PERL_CONTEXT *
1745 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1747 register I32 cxix = dopoptosub(cxstack_ix);
1748 register const PERL_CONTEXT *cx;
1749 register const PERL_CONTEXT *ccstack = cxstack;
1750 const PERL_SI *top_si = PL_curstackinfo;
1753 /* we may be in a higher stacklevel, so dig down deeper */
1754 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1755 top_si = top_si->si_prev;
1756 ccstack = top_si->si_cxstack;
1757 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1761 /* caller() should not report the automatic calls to &DB::sub */
1762 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1763 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1767 cxix = dopoptosub_at(ccstack, cxix - 1);
1770 cx = &ccstack[cxix];
1771 if (dbcxp) *dbcxp = cx;
1773 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1774 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1775 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1776 field below is defined for any cx. */
1777 /* caller() should not report the automatic calls to &DB::sub */
1778 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1779 cx = &ccstack[dbcxix];
1789 register const PERL_CONTEXT *cx;
1790 const PERL_CONTEXT *dbcx;
1792 const HEK *stash_hek;
1794 bool has_arg = MAXARG && TOPs;
1802 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1804 if (GIMME != G_ARRAY) {
1812 assert(CopSTASH(cx->blk_oldcop));
1813 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1814 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1816 if (GIMME != G_ARRAY) {
1819 PUSHs(&PL_sv_undef);
1822 sv_sethek(TARG, stash_hek);
1831 PUSHs(&PL_sv_undef);
1834 sv_sethek(TARG, stash_hek);
1837 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1838 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1841 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1842 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1843 /* So is ccstack[dbcxix]. */
1845 SV * const sv = newSV(0);
1846 gv_efullname3(sv, cvgv, NULL);
1848 PUSHs(boolSV(CxHASARGS(cx)));
1851 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1852 PUSHs(boolSV(CxHASARGS(cx)));
1856 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1859 gimme = (I32)cx->blk_gimme;
1860 if (gimme == G_VOID)
1861 PUSHs(&PL_sv_undef);
1863 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1864 if (CxTYPE(cx) == CXt_EVAL) {
1866 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1867 PUSHs(cx->blk_eval.cur_text);
1871 else if (cx->blk_eval.old_namesv) {
1872 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1875 /* eval BLOCK (try blocks have old_namesv == 0) */
1877 PUSHs(&PL_sv_undef);
1878 PUSHs(&PL_sv_undef);
1882 PUSHs(&PL_sv_undef);
1883 PUSHs(&PL_sv_undef);
1885 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1886 && CopSTASH_eq(PL_curcop, PL_debstash))
1888 AV * const ary = cx->blk_sub.argarray;
1889 const int off = AvARRAY(ary) - AvALLOC(ary);
1891 Perl_init_dbargs(aTHX);
1893 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1894 av_extend(PL_dbargs, AvFILLp(ary) + off);
1895 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1896 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1898 /* XXX only hints propagated via op_private are currently
1899 * visible (others are not easily accessible, since they
1900 * use the global PL_hints) */
1901 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1904 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1906 if (old_warnings == pWARN_NONE ||
1907 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1908 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1909 else if (old_warnings == pWARN_ALL ||
1910 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1911 /* Get the bit mask for $warnings::Bits{all}, because
1912 * it could have been extended by warnings::register */
1914 HV * const bits = get_hv("warnings::Bits", 0);
1915 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1916 mask = newSVsv(*bits_all);
1919 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1923 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1927 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1928 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1937 const char * const tmps =
1938 (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
1939 sv_reset(tmps, CopSTASH(PL_curcop));
1944 /* like pp_nextstate, but used instead when the debugger is active */
1949 PL_curcop = (COP*)PL_op;
1950 TAINT_NOT; /* Each statement is presumed innocent */
1951 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1956 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1957 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1960 register PERL_CONTEXT *cx;
1961 const I32 gimme = G_ARRAY;
1963 GV * const gv = PL_DBgv;
1964 register CV * const cv = GvCV(gv);
1967 DIE(aTHX_ "No DB::DB routine defined");
1969 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1970 /* don't do recursive DB::DB call */
1985 (void)(*CvXSUB(cv))(aTHX_ cv);
1992 PUSHBLOCK(cx, CXt_SUB, SP);
1994 cx->blk_sub.retop = PL_op->op_next;
1997 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1998 RETURNOP(CvSTART(cv));
2006 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2009 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2011 if (flags & SVs_PADTMP) {
2012 flags &= ~SVs_PADTMP;
2015 if (gimme == G_SCALAR) {
2017 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2018 ? *SP : sv_mortalcopy(*SP);
2020 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2023 *++MARK = &PL_sv_undef;
2027 else if (gimme == G_ARRAY) {
2028 /* in case LEAVE wipes old return values */
2029 while (++MARK <= SP) {
2030 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2033 *++newsp = sv_mortalcopy(*MARK);
2034 TAINT_NOT; /* Each item is independent */
2037 /* When this function was called with MARK == newsp, we reach this
2038 * point with SP == newsp. */
2047 register PERL_CONTEXT *cx;
2048 I32 gimme = GIMME_V;
2050 ENTER_with_name("block");
2053 PUSHBLOCK(cx, CXt_BLOCK, SP);
2061 register PERL_CONTEXT *cx;
2066 if (PL_op->op_flags & OPf_SPECIAL) {
2067 cx = &cxstack[cxstack_ix];
2068 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2073 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2076 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2077 PL_curpm = newpm; /* Don't pop $1 et al till now */
2079 LEAVE_with_name("block");
2087 register PERL_CONTEXT *cx;
2088 const I32 gimme = GIMME_V;
2089 void *itervar; /* location of the iteration variable */
2090 U8 cxtype = CXt_LOOP_FOR;
2092 ENTER_with_name("loop1");
2095 if (PL_op->op_targ) { /* "my" variable */
2096 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2097 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2098 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2099 SVs_PADSTALE, SVs_PADSTALE);
2101 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2103 itervar = PL_comppad;
2105 itervar = &PAD_SVl(PL_op->op_targ);
2108 else { /* symbol table variable */
2109 GV * const gv = MUTABLE_GV(POPs);
2110 SV** svp = &GvSV(gv);
2111 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2113 itervar = (void *)gv;
2116 if (PL_op->op_private & OPpITER_DEF)
2117 cxtype |= CXp_FOR_DEF;
2119 ENTER_with_name("loop2");
2121 PUSHBLOCK(cx, cxtype, SP);
2122 PUSHLOOP_FOR(cx, itervar, MARK);
2123 if (PL_op->op_flags & OPf_STACKED) {
2124 SV *maybe_ary = POPs;
2125 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2127 SV * const right = maybe_ary;
2130 if (RANGE_IS_NUMERIC(sv,right)) {
2131 cx->cx_type &= ~CXTYPEMASK;
2132 cx->cx_type |= CXt_LOOP_LAZYIV;
2133 /* Make sure that no-one re-orders cop.h and breaks our
2135 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2136 #ifdef NV_PRESERVES_UV
2137 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2138 (SvNV_nomg(sv) > (NV)IV_MAX)))
2140 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2141 (SvNV_nomg(right) < (NV)IV_MIN))))
2143 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2145 ((SvNV_nomg(sv) > 0) &&
2146 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2147 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2149 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2151 ((SvNV_nomg(right) > 0) &&
2152 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2153 (SvNV_nomg(right) > (NV)UV_MAX))
2156 DIE(aTHX_ "Range iterator outside integer range");
2157 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2158 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2160 /* for correct -Dstv display */
2161 cx->blk_oldsp = sp - PL_stack_base;
2165 cx->cx_type &= ~CXTYPEMASK;
2166 cx->cx_type |= CXt_LOOP_LAZYSV;
2167 /* Make sure that no-one re-orders cop.h and breaks our
2169 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2170 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2171 cx->blk_loop.state_u.lazysv.end = right;
2172 SvREFCNT_inc(right);
2173 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2174 /* This will do the upgrade to SVt_PV, and warn if the value
2175 is uninitialised. */
2176 (void) SvPV_nolen_const(right);
2177 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2178 to replace !SvOK() with a pointer to "". */
2180 SvREFCNT_dec(right);
2181 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2185 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2186 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2187 SvREFCNT_inc(maybe_ary);
2188 cx->blk_loop.state_u.ary.ix =
2189 (PL_op->op_private & OPpITER_REVERSED) ?
2190 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2194 else { /* iterating over items on the stack */
2195 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2196 if (PL_op->op_private & OPpITER_REVERSED) {
2197 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2200 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2210 register PERL_CONTEXT *cx;
2211 const I32 gimme = GIMME_V;
2213 ENTER_with_name("loop1");
2215 ENTER_with_name("loop2");
2217 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2218 PUSHLOOP_PLAIN(cx, SP);
2226 register PERL_CONTEXT *cx;
2233 assert(CxTYPE_is_LOOP(cx));
2235 newsp = PL_stack_base + cx->blk_loop.resetsp;
2238 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2241 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2242 PL_curpm = newpm; /* ... and pop $1 et al */
2244 LEAVE_with_name("loop2");
2245 LEAVE_with_name("loop1");
2251 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2252 PERL_CONTEXT *cx, PMOP *newpm)
2254 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2255 if (gimme == G_SCALAR) {
2256 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2258 const char *what = NULL;
2260 assert(MARK+1 == SP);
2261 if ((SvPADTMP(TOPs) ||
2262 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2265 !SvSMAGICAL(TOPs)) {
2267 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2268 : "a readonly value" : "a temporary";
2273 /* sub:lvalue{} will take us here. */
2282 "Can't return %s from lvalue subroutine", what
2287 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2288 if (!SvPADTMP(*SP)) {
2289 *++newsp = SvREFCNT_inc(*SP);
2294 /* FREETMPS could clobber it */
2295 SV *sv = SvREFCNT_inc(*SP);
2297 *++newsp = sv_mortalcopy(sv);
2304 ? sv_mortalcopy(*SP)
2306 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2311 *++newsp = &PL_sv_undef;
2313 if (CxLVAL(cx) & OPpDEREF) {
2316 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2320 else if (gimme == G_ARRAY) {
2321 assert (!(CxLVAL(cx) & OPpDEREF));
2322 if (ref || !CxLVAL(cx))
2323 while (++MARK <= SP)
2325 SvFLAGS(*MARK) & SVs_PADTMP
2326 ? sv_mortalcopy(*MARK)
2329 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2330 else while (++MARK <= SP) {
2331 if (*MARK != &PL_sv_undef
2333 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2338 /* Might be flattened array after $#array = */
2345 /* diag_listed_as: Can't return %s from lvalue subroutine */
2347 "Can't return a %s from lvalue subroutine",
2348 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2354 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2357 PL_stack_sp = newsp;
2363 register PERL_CONTEXT *cx;
2364 bool popsub2 = FALSE;
2365 bool clear_errsv = FALSE;
2375 const I32 cxix = dopoptosub(cxstack_ix);
2378 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2379 * sort block, which is a CXt_NULL
2382 PL_stack_base[1] = *PL_stack_sp;
2383 PL_stack_sp = PL_stack_base + 1;
2387 DIE(aTHX_ "Can't return outside a subroutine");
2389 if (cxix < cxstack_ix)
2392 if (CxMULTICALL(&cxstack[cxix])) {
2393 gimme = cxstack[cxix].blk_gimme;
2394 if (gimme == G_VOID)
2395 PL_stack_sp = PL_stack_base;
2396 else if (gimme == G_SCALAR) {
2397 PL_stack_base[1] = *PL_stack_sp;
2398 PL_stack_sp = PL_stack_base + 1;
2404 switch (CxTYPE(cx)) {
2407 lval = !!CvLVALUE(cx->blk_sub.cv);
2408 retop = cx->blk_sub.retop;
2409 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2412 if (!(PL_in_eval & EVAL_KEEPERR))
2415 namesv = cx->blk_eval.old_namesv;
2416 retop = cx->blk_eval.retop;
2419 if (optype == OP_REQUIRE &&
2420 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2422 /* Unassume the success we assumed earlier. */
2423 (void)hv_delete(GvHVn(PL_incgv),
2424 SvPVX_const(namesv),
2425 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2427 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2432 retop = cx->blk_sub.retop;
2435 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2439 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2441 if (gimme == G_SCALAR) {
2444 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2445 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2446 && !SvMAGICAL(TOPs)) {
2447 *++newsp = SvREFCNT_inc(*SP);
2452 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2454 *++newsp = sv_mortalcopy(sv);
2458 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2459 && !SvMAGICAL(*SP)) {
2463 *++newsp = sv_mortalcopy(*SP);
2466 *++newsp = sv_mortalcopy(*SP);
2469 *++newsp = &PL_sv_undef;
2471 else if (gimme == G_ARRAY) {
2472 while (++MARK <= SP) {
2473 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2474 && !SvGMAGICAL(*MARK)
2475 ? *MARK : sv_mortalcopy(*MARK);
2476 TAINT_NOT; /* Each item is independent */
2479 PL_stack_sp = newsp;
2483 /* Stack values are safe: */
2486 POPSUB(cx,sv); /* release CV and @_ ... */
2490 PL_curpm = newpm; /* ... and pop $1 et al */
2499 /* This duplicates parts of pp_leavesub, so that it can share code with
2507 register PERL_CONTEXT *cx;
2510 if (CxMULTICALL(&cxstack[cxstack_ix]))
2514 cxstack_ix++; /* temporarily protect top context */
2518 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2522 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2523 PL_curpm = newpm; /* ... and pop $1 et al */
2526 return cx->blk_sub.retop;
2533 register PERL_CONTEXT *cx;
2544 if (PL_op->op_flags & OPf_SPECIAL) {
2545 cxix = dopoptoloop(cxstack_ix);
2547 DIE(aTHX_ "Can't \"last\" outside a loop block");
2550 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2551 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2553 DIE(aTHX_ "Label not found for \"last %"SVf"\"",
2554 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2555 strlen(cPVOP->op_pv),
2556 ((cPVOP->op_private & OPpPV_IS_UTF8)
2557 ? SVf_UTF8 : 0) | SVs_TEMP)));
2559 if (cxix < cxstack_ix)
2563 cxstack_ix++; /* temporarily protect top context */
2565 switch (CxTYPE(cx)) {
2566 case CXt_LOOP_LAZYIV:
2567 case CXt_LOOP_LAZYSV:
2569 case CXt_LOOP_PLAIN:
2571 newsp = PL_stack_base + cx->blk_loop.resetsp;
2572 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2576 nextop = cx->blk_sub.retop;
2580 nextop = cx->blk_eval.retop;
2584 nextop = cx->blk_sub.retop;
2587 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2591 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme,
2592 pop2 == CXt_SUB ? SVs_TEMP : 0);
2597 /* Stack values are safe: */
2599 case CXt_LOOP_LAZYIV:
2600 case CXt_LOOP_PLAIN:
2601 case CXt_LOOP_LAZYSV:
2603 POPLOOP(cx); /* release loop vars ... */
2607 POPSUB(cx,sv); /* release CV and @_ ... */
2610 PL_curpm = newpm; /* ... and pop $1 et al */
2613 PERL_UNUSED_VAR(optype);
2614 PERL_UNUSED_VAR(gimme);
2622 register PERL_CONTEXT *cx;
2625 if (PL_op->op_flags & OPf_SPECIAL) {
2626 cxix = dopoptoloop(cxstack_ix);
2628 DIE(aTHX_ "Can't \"next\" outside a loop block");
2631 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2632 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2634 DIE(aTHX_ "Label not found for \"next %"SVf"\"",
2635 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2636 strlen(cPVOP->op_pv),
2637 ((cPVOP->op_private & OPpPV_IS_UTF8)
2638 ? SVf_UTF8 : 0) | SVs_TEMP)));
2640 if (cxix < cxstack_ix)
2643 /* clear off anything above the scope we're re-entering, but
2644 * save the rest until after a possible continue block */
2645 inner = PL_scopestack_ix;
2647 if (PL_scopestack_ix < inner)
2648 leave_scope(PL_scopestack[PL_scopestack_ix]);
2649 PL_curcop = cx->blk_oldcop;
2650 return (cx)->blk_loop.my_op->op_nextop;
2657 register PERL_CONTEXT *cx;
2661 if (PL_op->op_flags & OPf_SPECIAL) {
2662 cxix = dopoptoloop(cxstack_ix);
2664 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2667 cxix = dopoptolabel(cPVOP->op_pv, strlen(cPVOP->op_pv),
2668 (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0);
2670 DIE(aTHX_ "Label not found for \"redo %"SVf"\"",
2671 SVfARG(newSVpvn_flags(cPVOP->op_pv,
2672 strlen(cPVOP->op_pv),
2673 ((cPVOP->op_private & OPpPV_IS_UTF8)
2674 ? SVf_UTF8 : 0) | SVs_TEMP)));
2676 if (cxix < cxstack_ix)
2679 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2680 if (redo_op->op_type == OP_ENTER) {
2681 /* pop one less context to avoid $x being freed in while (my $x..) */
2683 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2684 redo_op = redo_op->op_next;
2688 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2689 LEAVE_SCOPE(oldsave);
2691 PL_curcop = cx->blk_oldcop;
2696 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2700 static const char too_deep[] = "Target of goto is too deeply nested";
2702 PERL_ARGS_ASSERT_DOFINDLABEL;
2705 Perl_croak(aTHX_ too_deep);
2706 if (o->op_type == OP_LEAVE ||
2707 o->op_type == OP_SCOPE ||
2708 o->op_type == OP_LEAVELOOP ||
2709 o->op_type == OP_LEAVESUB ||
2710 o->op_type == OP_LEAVETRY)
2712 *ops++ = cUNOPo->op_first;
2714 Perl_croak(aTHX_ too_deep);
2717 if (o->op_flags & OPf_KIDS) {
2719 /* First try all the kids at this level, since that's likeliest. */
2720 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2721 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2722 STRLEN kid_label_len;
2723 U32 kid_label_flags;
2724 const char *kid_label = CopLABEL_len_flags(kCOP,
2725 &kid_label_len, &kid_label_flags);
2727 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2730 (const U8*)kid_label, kid_label_len,
2731 (const U8*)label, len) == 0)
2733 (const U8*)label, len,
2734 (const U8*)kid_label, kid_label_len) == 0)
2735 : ( len == kid_label_len && ((kid_label == label)
2736 || memEQ(kid_label, label, len)))))
2740 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2741 if (kid == PL_lastgotoprobe)
2743 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2746 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2747 ops[-1]->op_type == OP_DBSTATE)
2752 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2765 register PERL_CONTEXT *cx;
2766 #define GOTO_DEPTH 64
2767 OP *enterops[GOTO_DEPTH];
2768 const char *label = NULL;
2769 STRLEN label_len = 0;
2770 U32 label_flags = 0;
2771 const bool do_dump = (PL_op->op_type == OP_DUMP);
2772 static const char must_have_label[] = "goto must have label";
2774 if (PL_op->op_flags & OPf_STACKED) {
2775 SV * const sv = POPs;
2777 /* This egregious kludge implements goto &subroutine */
2778 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2780 register PERL_CONTEXT *cx;
2781 CV *cv = MUTABLE_CV(SvRV(sv));
2788 if (!CvROOT(cv) && !CvXSUB(cv)) {
2789 const GV * const gv = CvGV(cv);
2793 /* autoloaded stub? */
2794 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2796 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2798 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2799 if (autogv && (cv = GvCV(autogv)))
2801 tmpstr = sv_newmortal();
2802 gv_efullname3(tmpstr, gv, NULL);
2803 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2805 DIE(aTHX_ "Goto undefined subroutine");
2808 /* First do some returnish stuff. */
2809 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2811 cxix = dopoptosub(cxstack_ix);
2813 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2814 if (cxix < cxstack_ix)
2818 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2819 if (CxTYPE(cx) == CXt_EVAL) {
2821 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2822 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2824 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2825 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2827 else if (CxMULTICALL(cx))
2828 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2829 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2830 /* put @_ back onto stack */
2831 AV* av = cx->blk_sub.argarray;
2833 items = AvFILLp(av) + 1;
2834 EXTEND(SP, items+1); /* @_ could have been extended. */
2835 Copy(AvARRAY(av), SP + 1, items, SV*);
2836 SvREFCNT_dec(GvAV(PL_defgv));
2837 GvAV(PL_defgv) = cx->blk_sub.savearray;
2839 /* abandon @_ if it got reified */
2844 av_extend(av, items-1);
2846 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2849 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2850 AV* const av = GvAV(PL_defgv);
2851 items = AvFILLp(av) + 1;
2852 EXTEND(SP, items+1); /* @_ could have been extended. */
2853 Copy(AvARRAY(av), SP + 1, items, SV*);
2857 if (CxTYPE(cx) == CXt_SUB &&
2858 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2859 SvREFCNT_dec(cx->blk_sub.cv);
2860 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2861 LEAVE_SCOPE(oldsave);
2863 /* A destructor called during LEAVE_SCOPE could have undefined
2864 * our precious cv. See bug #99850. */
2865 if (!CvROOT(cv) && !CvXSUB(cv)) {
2866 const GV * const gv = CvGV(cv);
2868 SV * const tmpstr = sv_newmortal();
2869 gv_efullname3(tmpstr, gv, NULL);
2870 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2873 DIE(aTHX_ "Goto undefined subroutine");
2876 /* Now do some callish stuff. */
2878 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2880 OP* const retop = cx->blk_sub.retop;
2881 SV **newsp PERL_UNUSED_DECL;
2882 I32 gimme PERL_UNUSED_DECL;
2885 for (index=0; index<items; index++)
2886 sv_2mortal(SP[-index]);
2889 /* XS subs don't have a CxSUB, so pop it */
2890 POPBLOCK(cx, PL_curpm);
2891 /* Push a mark for the start of arglist */
2894 (void)(*CvXSUB(cv))(aTHX_ cv);
2899 AV* const padlist = CvPADLIST(cv);
2900 if (CxTYPE(cx) == CXt_EVAL) {
2901 PL_in_eval = CxOLD_IN_EVAL(cx);
2902 PL_eval_root = cx->blk_eval.old_eval_root;
2903 cx->cx_type = CXt_SUB;
2905 cx->blk_sub.cv = cv;
2906 cx->blk_sub.olddepth = CvDEPTH(cv);
2909 if (CvDEPTH(cv) < 2)
2910 SvREFCNT_inc_simple_void_NN(cv);
2912 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2913 sub_crush_depth(cv);
2914 pad_push(padlist, CvDEPTH(cv));
2916 PL_curcop = cx->blk_oldcop;
2918 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2921 AV *const av = MUTABLE_AV(PAD_SVl(0));
2923 cx->blk_sub.savearray = GvAV(PL_defgv);
2924 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2925 CX_CURPAD_SAVE(cx->blk_sub);
2926 cx->blk_sub.argarray = av;
2928 if (items >= AvMAX(av) + 1) {
2929 SV **ary = AvALLOC(av);
2930 if (AvARRAY(av) != ary) {
2931 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2934 if (items >= AvMAX(av) + 1) {
2935 AvMAX(av) = items - 1;
2936 Renew(ary,items+1,SV*);
2942 Copy(mark,AvARRAY(av),items,SV*);
2943 AvFILLp(av) = items - 1;
2944 assert(!AvREAL(av));
2946 /* transfer 'ownership' of refcnts to new @_ */
2956 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2957 Perl_get_db_sub(aTHX_ NULL, cv);
2959 CV * const gotocv = get_cvs("DB::goto", 0);
2961 PUSHMARK( PL_stack_sp );
2962 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2967 RETURNOP(CvSTART(cv));
2971 label = SvPV_const(sv, label_len);
2972 label_flags = SvUTF8(sv);
2975 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2976 label = cPVOP->op_pv;
2977 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2978 label_len = strlen(label);
2980 if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
2985 OP *gotoprobe = NULL;
2986 bool leaving_eval = FALSE;
2987 bool in_block = FALSE;
2988 PERL_CONTEXT *last_eval_cx = NULL;
2992 PL_lastgotoprobe = NULL;
2994 for (ix = cxstack_ix; ix >= 0; ix--) {
2996 switch (CxTYPE(cx)) {
2998 leaving_eval = TRUE;
2999 if (!CxTRYBLOCK(cx)) {
3000 gotoprobe = (last_eval_cx ?
3001 last_eval_cx->blk_eval.old_eval_root :
3006 /* else fall through */
3007 case CXt_LOOP_LAZYIV:
3008 case CXt_LOOP_LAZYSV:
3010 case CXt_LOOP_PLAIN:
3013 gotoprobe = cx->blk_oldcop->op_sibling;
3019 gotoprobe = cx->blk_oldcop->op_sibling;
3022 gotoprobe = PL_main_root;
3025 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3026 gotoprobe = CvROOT(cx->blk_sub.cv);
3032 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3035 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3036 CxTYPE(cx), (long) ix);
3037 gotoprobe = PL_main_root;
3041 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3042 enterops, enterops + GOTO_DEPTH);
3045 if (gotoprobe->op_sibling &&
3046 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3047 gotoprobe->op_sibling->op_sibling) {
3048 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3049 label, label_len, label_flags, enterops,
3050 enterops + GOTO_DEPTH);
3055 PL_lastgotoprobe = gotoprobe;
3058 DIE(aTHX_ "Can't find label %"SVf,
3059 SVfARG(newSVpvn_flags(label, label_len,
3060 SVs_TEMP | label_flags)));
3062 /* if we're leaving an eval, check before we pop any frames
3063 that we're not going to punt, otherwise the error
3066 if (leaving_eval && *enterops && enterops[1]) {
3068 for (i = 1; enterops[i]; i++)
3069 if (enterops[i]->op_type == OP_ENTERITER)
3070 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3073 if (*enterops && enterops[1]) {
3074 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3076 deprecate("\"goto\" to jump into a construct");
3079 /* pop unwanted frames */
3081 if (ix < cxstack_ix) {
3088 oldsave = PL_scopestack[PL_scopestack_ix];
3089 LEAVE_SCOPE(oldsave);
3092 /* push wanted frames */
3094 if (*enterops && enterops[1]) {
3095 OP * const oldop = PL_op;
3096 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3097 for (; enterops[ix]; ix++) {
3098 PL_op = enterops[ix];
3099 /* Eventually we may want to stack the needed arguments
3100 * for each op. For now, we punt on the hard ones. */
3101 if (PL_op->op_type == OP_ENTERITER)
3102 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3103 PL_op->op_ppaddr(aTHX);
3111 if (!retop) retop = PL_main_start;
3113 PL_restartop = retop;
3114 PL_do_undump = TRUE;
3118 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3119 PL_do_undump = FALSE;
3134 anum = 0; (void)POPs;
3139 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3141 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3144 PL_exit_flags |= PERL_EXIT_EXPECTED;
3146 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3147 if (anum || !(PL_minus_c && PL_madskills))
3152 PUSHs(&PL_sv_undef);
3159 S_save_lines(pTHX_ AV *array, SV *sv)
3161 const char *s = SvPVX_const(sv);
3162 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3165 PERL_ARGS_ASSERT_SAVE_LINES;
3167 while (s && s < send) {
3169 SV * const tmpstr = newSV_type(SVt_PVMG);
3171 t = (const char *)memchr(s, '\n', send - s);
3177 sv_setpvn(tmpstr, s, t - s);
3178 av_store(array, line++, tmpstr);
3186 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3188 0 is used as continue inside eval,
3190 3 is used for a die caught by an inner eval - continue inner loop
3192 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3193 establish a local jmpenv to handle exception traps.
3198 S_docatch(pTHX_ OP *o)
3202 OP * const oldop = PL_op;
3206 assert(CATCH_GET == TRUE);
3213 assert(cxstack_ix >= 0);
3214 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3215 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3220 /* die caught by an inner eval - continue inner loop */
3221 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3222 PL_restartjmpenv = NULL;
3223 PL_op = PL_restartop;
3239 /* James Bond: Do you expect me to talk?
3240 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3242 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3243 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3245 Currently it is not used outside the core code. Best if it stays that way.
3247 Hence it's now deprecated, and will be removed.
3250 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3251 /* sv Text to convert to OP tree. */
3252 /* startop op_free() this to undo. */
3253 /* code Short string id of the caller. */
3255 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3256 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3259 /* Don't use this. It will go away without warning once the regexp engine is
3260 refactored not to use it. */
3262 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3265 dVAR; dSP; /* Make POPBLOCK work. */
3271 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3272 char *tmpbuf = tbuf;
3275 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3279 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3281 ENTER_with_name("eval");
3282 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3284 /* switch to eval mode */
3286 if (IN_PERL_COMPILETIME) {
3287 SAVECOPSTASH_FREE(&PL_compiling);
3288 CopSTASH_set(&PL_compiling, PL_curstash);
3290 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3291 SV * const sv = sv_newmortal();
3292 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3293 code, (unsigned long)++PL_evalseq,
3294 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3299 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3300 (unsigned long)++PL_evalseq);
3301 SAVECOPFILE_FREE(&PL_compiling);
3302 CopFILE_set(&PL_compiling, tmpbuf+2);
3303 SAVECOPLINE(&PL_compiling);
3304 CopLINE_set(&PL_compiling, 1);
3305 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3306 deleting the eval's FILEGV from the stash before gv_check() runs
3307 (i.e. before run-time proper). To work around the coredump that
3308 ensues, we always turn GvMULTI_on for any globals that were
3309 introduced within evals. See force_ident(). GSAR 96-10-12 */
3310 safestr = savepvn(tmpbuf, len);
3311 SAVEDELETE(PL_defstash, safestr, len);
3313 #ifdef OP_IN_REGISTER
3319 /* we get here either during compilation, or via pp_regcomp at runtime */
3320 runtime = IN_PERL_RUNTIME;
3323 runcv = find_runcv(NULL);
3325 /* At run time, we have to fetch the hints from PL_curcop. */
3326 PL_hints = PL_curcop->cop_hints;
3327 if (PL_hints & HINT_LOCALIZE_HH) {
3328 /* SAVEHINTS created a new HV in PL_hintgv, which we
3330 SvREFCNT_dec(GvHV(PL_hintgv));
3332 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3333 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3335 SAVECOMPILEWARNINGS();
3336 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3337 cophh_free(CopHINTHASH_get(&PL_compiling));
3338 /* XXX Does this need to avoid copying a label? */
3339 PL_compiling.cop_hints_hash
3340 = cophh_copy(PL_curcop->cop_hints_hash);
3344 PL_op->op_type = OP_ENTEREVAL;
3345 PL_op->op_flags = 0; /* Avoid uninit warning. */
3346 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3348 need_catch = CATCH_GET;
3352 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq, NULL);
3354 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax, NULL);
3355 CATCH_SET(need_catch);
3356 POPBLOCK(cx,PL_curpm);
3359 (*startop)->op_type = OP_NULL;
3360 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3361 /* XXX DAPM do this properly one year */
3362 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3363 LEAVE_with_name("eval");
3364 if (IN_PERL_COMPILETIME)
3365 CopHINTS_set(&PL_compiling, PL_hints);
3366 #ifdef OP_IN_REGISTER
3369 PERL_UNUSED_VAR(newsp);
3370 PERL_UNUSED_VAR(optype);
3372 return PL_eval_start;
3377 =for apidoc find_runcv
3379 Locate the CV corresponding to the currently executing sub or eval.
3380 If db_seqp is non_null, skip CVs that are in the DB package and populate
3381 *db_seqp with the cop sequence number at the point that the DB:: code was
3382 entered. (allows debuggers to eval in the scope of the breakpoint rather
3383 than in the scope of the debugger itself).
3389 Perl_find_runcv(pTHX_ U32 *db_seqp)
3395 *db_seqp = PL_curcop->cop_seq;
3396 for (si = PL_curstackinfo; si; si = si->si_prev) {
3398 for (ix = si->si_cxix; ix >= 0; ix--) {
3399 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3400 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3401 CV * const cv = cx->blk_sub.cv;
3402 /* skip DB:: code */
3403 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3404 *db_seqp = cx->blk_oldcop->cop_seq;
3409 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3410 return cx->blk_eval.cv;
3417 /* Run yyparse() in a setjmp wrapper. Returns:
3418 * 0: yyparse() successful
3419 * 1: yyparse() failed
3423 S_try_yyparse(pTHX_ int gramtype)
3428 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3432 ret = yyparse(gramtype) ? 1 : 0;
3446 /* Compile a require/do, an eval '', or a /(?{...})/.
3447 * In the last case, startop is non-null, and contains the address of
3448 * a pointer that should be set to the just-compiled code.
3449 * outside is the lexically enclosing CV (if any) that invoked us.
3450 * Returns a bool indicating whether the compile was successful; if so,
3451 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3452 * pushes undef (also croaks if startop != NULL).
3455 /* This function is called from three places, sv_compile_2op, pp_require
3456 * and pp_entereval. These can be distinguished as follows:
3457 * sv_compile_2op - startop is non-null
3458 * pp_require - startop is null; saveop is not entereval
3459 * pp_entereval - startop is null; saveop is entereval
3463 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq, HV *hh)
3466 OP * const saveop = PL_op;
3467 COP * const oldcurcop = PL_curcop;
3468 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3472 PL_in_eval = (in_require
3473 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3478 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3480 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3481 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3482 cxstack[cxstack_ix].blk_gimme = gimme;
3484 CvOUTSIDE_SEQ(evalcv) = seq;
3485 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3487 /* set up a scratch pad */
3489 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3490 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3494 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3496 /* make sure we compile in the right package */
3498 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3499 SAVEGENERICSV(PL_curstash);
3500 PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3502 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3503 SAVESPTR(PL_beginav);
3504 PL_beginav = newAV();
3505 SAVEFREESV(PL_beginav);
3506 SAVESPTR(PL_unitcheckav);
3507 PL_unitcheckav = newAV();
3508 SAVEFREESV(PL_unitcheckav);
3511 SAVEBOOL(PL_madskills);
3515 if (!startop) ENTER_with_name("evalcomp");
3516 SAVESPTR(PL_compcv);
3519 /* try to compile it */
3521 PL_eval_root = NULL;
3522 PL_curcop = &PL_compiling;
3523 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3524 PL_in_eval |= EVAL_KEEPERR;
3529 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3533 hv_clear(GvHV(PL_hintgv));
3536 PL_hints = saveop->op_private & OPpEVAL_COPHH
3537 ? oldcurcop->cop_hints : saveop->op_targ;
3539 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3540 SvREFCNT_dec(GvHV(PL_hintgv));
3541 GvHV(PL_hintgv) = hh;
3544 SAVECOMPILEWARNINGS();
3546 if (PL_dowarn & G_WARN_ALL_ON)
3547 PL_compiling.cop_warnings = pWARN_ALL ;
3548 else if (PL_dowarn & G_WARN_ALL_OFF)
3549 PL_compiling.cop_warnings = pWARN_NONE ;
3551 PL_compiling.cop_warnings = pWARN_STD ;
3554 PL_compiling.cop_warnings =
3555 DUP_WARNINGS(oldcurcop->cop_warnings);
3556 cophh_free(CopHINTHASH_get(&PL_compiling));
3557 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3558 /* The label, if present, is the first entry on the chain. So rather
3559 than writing a blank label in front of it (which involves an
3560 allocation), just use the next entry in the chain. */
3561 PL_compiling.cop_hints_hash
3562 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3563 /* Check the assumption that this removed the label. */
3564 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3567 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3571 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3573 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3574 * so honour CATCH_GET and trap it here if necessary */
3576 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3578 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3579 SV **newsp; /* Used by POPBLOCK. */
3581 I32 optype; /* Used by POPEVAL. */
3586 PERL_UNUSED_VAR(newsp);
3587 PERL_UNUSED_VAR(optype);
3589 /* note that if yystatus == 3, then the EVAL CX block has already
3590 * been popped, and various vars restored */
3592 if (yystatus != 3) {
3594 op_free(PL_eval_root);
3595 PL_eval_root = NULL;
3597 SP = PL_stack_base + POPMARK; /* pop original mark */
3599 POPBLOCK(cx,PL_curpm);
3601 namesv = cx->blk_eval.old_namesv;
3603 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3604 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3609 /* If cx is still NULL, it means that we didn't go in the
3610 * POPEVAL branch. */
3611 cx = &cxstack[cxstack_ix];
3612 assert(CxTYPE(cx) == CXt_EVAL);
3613 namesv = cx->blk_eval.old_namesv;
3615 (void)hv_store(GvHVn(PL_incgv),
3616 SvPVX_const(namesv),
3617 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3619 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3622 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3625 if (yystatus != 3) {
3626 POPBLOCK(cx,PL_curpm);
3629 Perl_croak(aTHX_ "%"SVf"Compilation failed in regexp",
3632 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3635 if (!*(SvPVx_nolen_const(ERRSV))) {
3636 sv_setpvs(ERRSV, "Compilation error");
3639 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3643 else if (!startop) LEAVE_with_name("evalcomp");
3644 CopLINE_set(&PL_compiling, 0);
3646 *startop = PL_eval_root;
3648 SAVEFREEOP(PL_eval_root);
3650 DEBUG_x(dump_eval());
3652 /* Register with debugger: */
3653 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3654 CV * const cv = get_cvs("DB::postponed", 0);
3658 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3660 call_sv(MUTABLE_SV(cv), G_DISCARD);
3664 if (PL_unitcheckav) {
3665 OP *es = PL_eval_start;
3666 call_list(PL_scopestack_ix, PL_unitcheckav);
3670 /* compiled okay, so do it */
3672 CvDEPTH(evalcv) = 1;
3673 SP = PL_stack_base + POPMARK; /* pop original mark */
3674 PL_op = saveop; /* The caller may need it. */
3675 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3682 S_check_type_and_open(pTHX_ SV *name)
3685 const char *p = SvPV_nolen_const(name);
3686 const int st_rc = PerlLIO_stat(p, &st);
3688 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3690 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3694 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3695 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3697 return PerlIO_open(p, PERL_SCRIPT_MODE);
3701 #ifndef PERL_DISABLE_PMC
3703 S_doopen_pm(pTHX_ SV *name)
3706 const char *p = SvPV_const(name, namelen);
3708 PERL_ARGS_ASSERT_DOOPEN_PM;
3710 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3711 SV *const pmcsv = sv_newmortal();
3714 SvSetSV_nosteal(pmcsv,name);
3715 sv_catpvn(pmcsv, "c", 1);
3717 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3718 return check_type_and_open(pmcsv);
3720 return check_type_and_open(name);
3723 # define doopen_pm(name) check_type_and_open(name)
3724 #endif /* !PERL_DISABLE_PMC */
3729 register PERL_CONTEXT *cx;
3736 int vms_unixname = 0;
3738 const char *tryname = NULL;
3740 const I32 gimme = GIMME_V;
3741 int filter_has_file = 0;
3742 PerlIO *tryrsfp = NULL;
3743 SV *filter_cache = NULL;
3744 SV *filter_state = NULL;
3745 SV *filter_sub = NULL;
3751 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3752 sv = sv_2mortal(new_version(sv));
3753 if (!sv_derived_from(PL_patchlevel, "version"))
3754 upg_version(PL_patchlevel, TRUE);
3755 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3756 if ( vcmp(sv,PL_patchlevel) <= 0 )
3757 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3758 SVfARG(sv_2mortal(vnormal(sv))),
3759 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3763 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3766 SV * const req = SvRV(sv);
3767 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3769 /* get the left hand term */
3770 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3772 first = SvIV(*av_fetch(lav,0,0));
3773 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3774 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3775 || av_len(lav) > 1 /* FP with > 3 digits */
3776 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3778 DIE(aTHX_ "Perl %"SVf" required--this is only "
3780 SVfARG(sv_2mortal(vnormal(req))),
3781 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3784 else { /* probably 'use 5.10' or 'use 5.8' */
3789 second = SvIV(*av_fetch(lav,1,0));
3791 second /= second >= 600 ? 100 : 10;
3792 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3793 (int)first, (int)second);
3794 upg_version(hintsv, TRUE);
3796 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3797 "--this is only %"SVf", stopped",
3798 SVfARG(sv_2mortal(vnormal(req))),
3799 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3800 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3808 name = SvPV_const(sv, len);
3809 if (!(name && len > 0 && *name))
3810 DIE(aTHX_ "Null filename used");
3811 TAINT_PROPER("require");
3815 /* The key in the %ENV hash is in the syntax of file passed as the argument
3816 * usually this is in UNIX format, but sometimes in VMS format, which
3817 * can result in a module being pulled in more than once.
3818 * To prevent this, the key must be stored in UNIX format if the VMS
3819 * name can be translated to UNIX.
3821 if ((unixname = tounixspec(name, NULL)) != NULL) {
3822 unixlen = strlen(unixname);
3828 /* if not VMS or VMS name can not be translated to UNIX, pass it
3831 unixname = (char *) name;
3834 if (PL_op->op_type == OP_REQUIRE) {
3835 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3836 unixname, unixlen, 0);
3838 if (*svp != &PL_sv_undef)
3841 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3842 "Compilation failed in require", unixname);
3846 /* prepare to compile file */
3848 if (path_is_absolute(name)) {
3849 /* At this point, name is SvPVX(sv) */
3851 tryrsfp = doopen_pm(sv);
3854 AV * const ar = GvAVn(PL_incgv);
3860 namesv = newSV_type(SVt_PV);
3861 for (i = 0; i <= AvFILL(ar); i++) {
3862 SV * const dirsv = *av_fetch(ar, i, TRUE);
3864 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3871 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3872 && !sv_isobject(loader))
3874 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3877 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3878 PTR2UV(SvRV(dirsv)), name);
3879 tryname = SvPVX_const(namesv);
3882 ENTER_with_name("call_INC");
3890 if (sv_isobject(loader))
3891 count = call_method("INC", G_ARRAY);
3893 count = call_sv(loader, G_ARRAY);
3903 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3904 && !isGV_with_GP(SvRV(arg))) {
3905 filter_cache = SvRV(arg);
3906 SvREFCNT_inc_simple_void_NN(filter_cache);
3913 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3917 if (isGV_with_GP(arg)) {
3918 IO * const io = GvIO((const GV *)arg);
3923 tryrsfp = IoIFP(io);
3924 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3925 PerlIO_close(IoOFP(io));
3936 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3938 SvREFCNT_inc_simple_void_NN(filter_sub);
3941 filter_state = SP[i];
3942 SvREFCNT_inc_simple_void(filter_state);
3946 if (!tryrsfp && (filter_cache || filter_sub)) {
3947 tryrsfp = PerlIO_open(BIT_BUCKET,
3955 LEAVE_with_name("call_INC");
3957 /* Adjust file name if the hook has set an %INC entry.
3958 This needs to happen after the FREETMPS above. */
3959 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3961 tryname = SvPV_nolen_const(*svp);
3968 filter_has_file = 0;
3970 SvREFCNT_dec(filter_cache);
3971 filter_cache = NULL;
3974 SvREFCNT_dec(filter_state);
3975 filter_state = NULL;
3978 SvREFCNT_dec(filter_sub);
3983 if (!path_is_absolute(name)
3989 dir = SvPV_const(dirsv, dirlen);
3997 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3999 sv_setpv(namesv, unixdir);
4000 sv_catpv(namesv, unixname);
4002 # ifdef __SYMBIAN32__
4003 if (PL_origfilename[0] &&
4004 PL_origfilename[1] == ':' &&
4005 !(dir[0] && dir[1] == ':'))
4006 Perl_sv_setpvf(aTHX_ namesv,
4011 Perl_sv_setpvf(aTHX_ namesv,
4015 /* The equivalent of
4016 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4017 but without the need to parse the format string, or
4018 call strlen on either pointer, and with the correct
4019 allocation up front. */
4021 char *tmp = SvGROW(namesv, dirlen + len + 2);
4023 memcpy(tmp, dir, dirlen);
4026 /* name came from an SV, so it will have a '\0' at the
4027 end that we can copy as part of this memcpy(). */
4028 memcpy(tmp, name, len + 1);
4030 SvCUR_set(namesv, dirlen + len + 1);
4035 TAINT_PROPER("require");
4036 tryname = SvPVX_const(namesv);
4037 tryrsfp = doopen_pm(namesv);
4039 if (tryname[0] == '.' && tryname[1] == '/') {
4041 while (*++tryname == '/');
4045 else if (errno == EMFILE)
4046 /* no point in trying other paths if out of handles */
4055 if (PL_op->op_type == OP_REQUIRE) {
4056 if(errno == EMFILE) {
4057 /* diag_listed_as: Can't locate %s */
4058 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
4060 if (namesv) { /* did we lookup @INC? */
4061 AV * const ar = GvAVn(PL_incgv);
4063 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4064 for (i = 0; i <= AvFILL(ar); i++) {
4065 sv_catpvs(inc, " ");
4066 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4069 /* diag_listed_as: Can't locate %s */
4071 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
4073 (memEQ(name + len - 2, ".h", 3)
4074 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
4075 (memEQ(name + len - 3, ".ph", 4)
4076 ? " (did you run h2ph?)" : ""),
4081 DIE(aTHX_ "Can't locate %s", name);
4087 SETERRNO(0, SS_NORMAL);
4089 /* Assume success here to prevent recursive requirement. */
4090 /* name is never assigned to again, so len is still strlen(name) */
4091 /* Check whether a hook in @INC has already filled %INC */
4093 (void)hv_store(GvHVn(PL_incgv),
4094 unixname, unixlen, newSVpv(tryname,0),0);
4096 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4098 (void)hv_store(GvHVn(PL_incgv),
4099 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4102 ENTER_with_name("eval");
4104 SAVECOPFILE_FREE(&PL_compiling);
4105 CopFILE_set(&PL_compiling, tryname);
4106 lex_start(NULL, tryrsfp, 0);
4108 if (filter_sub || filter_cache) {
4109 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4110 than hanging another SV from it. In turn, filter_add() optionally
4111 takes the SV to use as the filter (or creates a new SV if passed
4112 NULL), so simply pass in whatever value filter_cache has. */
4113 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
4114 IoLINES(datasv) = filter_has_file;
4115 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4116 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4119 /* switch to eval mode */
4120 PUSHBLOCK(cx, CXt_EVAL, SP);
4122 cx->blk_eval.retop = PL_op->op_next;
4124 SAVECOPLINE(&PL_compiling);
4125 CopLINE_set(&PL_compiling, 0);
4129 /* Store and reset encoding. */
4130 encoding = PL_encoding;
4133 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq, NULL))
4134 op = DOCATCH(PL_eval_start);
4136 op = PL_op->op_next;
4138 /* Restore encoding. */
4139 PL_encoding = encoding;
4144 /* This is a op added to hold the hints hash for
4145 pp_entereval. The hash can be modified by the code
4146 being eval'ed, so we return a copy instead. */
4152 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4160 register PERL_CONTEXT *cx;
4162 const I32 gimme = GIMME_V;
4163 const U32 was = PL_breakable_sub_gen;
4164 char tbuf[TYPE_DIGITS(long) + 12];
4165 bool saved_delete = FALSE;
4166 char *tmpbuf = tbuf;
4169 U32 seq, lex_flags = 0;
4170 HV *saved_hh = NULL;
4171 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4173 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4174 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4176 else if (PL_hints & HINT_LOCALIZE_HH || (
4177 PL_op->op_private & OPpEVAL_COPHH
4178 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4180 saved_hh = cop_hints_2hv(PL_curcop, 0);
4181 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4185 /* make sure we've got a plain PV (no overload etc) before testing
4186 * for taint. Making a copy here is probably overkill, but better
4187 * safe than sorry */
4189 const char * const p = SvPV_const(sv, len);
4191 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4192 lex_flags |= LEX_START_COPIED;
4194 if (bytes && SvUTF8(sv))
4195 SvPVbyte_force(sv, len);
4197 else if (bytes && SvUTF8(sv)) {
4198 /* Don't modify someone else's scalar */
4201 (void)sv_2mortal(sv);
4202 SvPVbyte_force(sv,len);
4203 lex_flags |= LEX_START_COPIED;
4206 TAINT_IF(SvTAINTED(sv));
4207 TAINT_PROPER("eval");
4209 ENTER_with_name("eval");
4210 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4211 ? LEX_IGNORE_UTF8_HINTS
4212 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4217 /* switch to eval mode */
4219 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4220 SV * const temp_sv = sv_newmortal();
4221 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4222 (unsigned long)++PL_evalseq,
4223 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4224 tmpbuf = SvPVX(temp_sv);
4225 len = SvCUR(temp_sv);
4228 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4229 SAVECOPFILE_FREE(&PL_compiling);
4230 CopFILE_set(&PL_compiling, tmpbuf+2);
4231 SAVECOPLINE(&PL_compiling);
4232 CopLINE_set(&PL_compiling, 1);
4233 /* special case: an eval '' executed within the DB package gets lexically
4234 * placed in the first non-DB CV rather than the current CV - this
4235 * allows the debugger to execute code, find lexicals etc, in the
4236 * scope of the code being debugged. Passing &seq gets find_runcv
4237 * to do the dirty work for us */
4238 runcv = find_runcv(&seq);
4240 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4242 cx->blk_eval.retop = PL_op->op_next;
4244 /* prepare to compile string */
4246 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4247 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4249 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4250 deleting the eval's FILEGV from the stash before gv_check() runs
4251 (i.e. before run-time proper). To work around the coredump that
4252 ensues, we always turn GvMULTI_on for any globals that were
4253 introduced within evals. See force_ident(). GSAR 96-10-12 */
4254 char *const safestr = savepvn(tmpbuf, len);
4255 SAVEDELETE(PL_defstash, safestr, len);
4256 saved_delete = TRUE;
4261 if (doeval(gimme, NULL, runcv, seq, saved_hh)) {
4262 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4263 ? (PERLDB_LINE || PERLDB_SAVESRC)
4264 : PERLDB_SAVESRC_NOSUBS) {
4265 /* Retain the filegv we created. */
4266 } else if (!saved_delete) {
4267 char *const safestr = savepvn(tmpbuf, len);
4268 SAVEDELETE(PL_defstash, safestr, len);
4270 return DOCATCH(PL_eval_start);
4272 /* We have already left the scope set up earlier thanks to the LEAVE
4274 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4275 ? (PERLDB_LINE || PERLDB_SAVESRC)
4276 : PERLDB_SAVESRC_INVALID) {
4277 /* Retain the filegv we created. */
4278 } else if (!saved_delete) {
4279 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4281 return PL_op->op_next;
4291 register PERL_CONTEXT *cx;
4293 const U8 save_flags = PL_op -> op_flags;
4301 namesv = cx->blk_eval.old_namesv;
4302 retop = cx->blk_eval.retop;
4303 evalcv = cx->blk_eval.cv;
4306 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4308 PL_curpm = newpm; /* Don't pop $1 et al till now */
4311 assert(CvDEPTH(evalcv) == 1);
4313 CvDEPTH(evalcv) = 0;
4315 if (optype == OP_REQUIRE &&
4316 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4318 /* Unassume the success we assumed earlier. */
4319 (void)hv_delete(GvHVn(PL_incgv),
4320 SvPVX_const(namesv),
4321 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4323 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4325 /* die_unwind() did LEAVE, or we won't be here */
4328 LEAVE_with_name("eval");
4329 if (!(save_flags & OPf_SPECIAL)) {
4337 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4338 close to the related Perl_create_eval_scope. */
4340 Perl_delete_eval_scope(pTHX)
4345 register PERL_CONTEXT *cx;
4351 LEAVE_with_name("eval_scope");
4352 PERL_UNUSED_VAR(newsp);
4353 PERL_UNUSED_VAR(gimme);
4354 PERL_UNUSED_VAR(optype);
4357 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4358 also needed by Perl_fold_constants. */
4360 Perl_create_eval_scope(pTHX_ U32 flags)
4363 const I32 gimme = GIMME_V;
4365 ENTER_with_name("eval_scope");
4368 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4371 PL_in_eval = EVAL_INEVAL;
4372 if (flags & G_KEEPERR)
4373 PL_in_eval |= EVAL_KEEPERR;
4376 if (flags & G_FAKINGEVAL) {
4377 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4385 PERL_CONTEXT * const cx = create_eval_scope(0);
4386 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4387 return DOCATCH(PL_op->op_next);
4396 register PERL_CONTEXT *cx;
4402 PERL_UNUSED_VAR(optype);
4405 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4406 PL_curpm = newpm; /* Don't pop $1 et al till now */
4408 LEAVE_with_name("eval_scope");
4416 register PERL_CONTEXT *cx;
4417 const I32 gimme = GIMME_V;
4419 ENTER_with_name("given");
4422 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
4423 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4425 PUSHBLOCK(cx, CXt_GIVEN, SP);
4434 register PERL_CONTEXT *cx;
4438 PERL_UNUSED_CONTEXT;
4441 assert(CxTYPE(cx) == CXt_GIVEN);
4444 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4445 PL_curpm = newpm; /* Don't pop $1 et al till now */
4447 LEAVE_with_name("given");
4451 /* Helper routines used by pp_smartmatch */
4453 S_make_matcher(pTHX_ REGEXP *re)
4456 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4458 PERL_ARGS_ASSERT_MAKE_MATCHER;
4460 PM_SETRE(matcher, ReREFCNT_inc(re));
4462 SAVEFREEOP((OP *) matcher);
4463 ENTER_with_name("matcher"); SAVETMPS;
4469 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4474 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4476 PL_op = (OP *) matcher;
4479 (void) Perl_pp_match(aTHX);
4481 return (SvTRUEx(POPs));
4485 S_destroy_matcher(pTHX_ PMOP *matcher)
4489 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4490 PERL_UNUSED_ARG(matcher);
4493 LEAVE_with_name("matcher");
4496 /* Do a smart match */
4499 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4500 return do_smartmatch(NULL, NULL, 0);
4503 /* This version of do_smartmatch() implements the
4504 * table of smart matches that is found in perlsyn.
4507 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4512 bool object_on_left = FALSE;
4513 SV *e = TOPs; /* e is for 'expression' */
4514 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4516 /* Take care only to invoke mg_get() once for each argument.
4517 * Currently we do this by copying the SV if it's magical. */
4519 if (!copied && SvGMAGICAL(d))
4520 d = sv_mortalcopy(d);
4527 e = sv_mortalcopy(e);
4529 /* First of all, handle overload magic of the rightmost argument */
4532 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4533 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4535 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4542 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4545 SP -= 2; /* Pop the values */
4550 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4557 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4558 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4559 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4561 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4562 object_on_left = TRUE;
4565 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4567 if (object_on_left) {
4568 goto sm_any_sub; /* Treat objects like scalars */
4570 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4571 /* Test sub truth for each key */
4573 bool andedresults = TRUE;
4574 HV *hv = (HV*) SvRV(d);
4575 I32 numkeys = hv_iterinit(hv);
4576 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4579 while ( (he = hv_iternext(hv)) ) {
4580 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4581 ENTER_with_name("smartmatch_hash_key_test");
4584 PUSHs(hv_iterkeysv(he));
4586 c = call_sv(e, G_SCALAR);
4589 andedresults = FALSE;
4591 andedresults = SvTRUEx(POPs) && andedresults;
4593 LEAVE_with_name("smartmatch_hash_key_test");
4600 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4601 /* Test sub truth for each element */
4603 bool andedresults = TRUE;
4604 AV *av = (AV*) SvRV(d);
4605 const I32 len = av_len(av);
4606 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4609 for (i = 0; i <= len; ++i) {
4610 SV * const * const svp = av_fetch(av, i, FALSE);
4611 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4612 ENTER_with_name("smartmatch_array_elem_test");
4618 c = call_sv(e, G_SCALAR);
4621 andedresults = FALSE;
4623 andedresults = SvTRUEx(POPs) && andedresults;
4625 LEAVE_with_name("smartmatch_array_elem_test");
4634 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4635 ENTER_with_name("smartmatch_coderef");
4640 c = call_sv(e, G_SCALAR);
4644 else if (SvTEMP(TOPs))
4645 SvREFCNT_inc_void(TOPs);
4647 LEAVE_with_name("smartmatch_coderef");
4652 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4653 if (object_on_left) {
4654 goto sm_any_hash; /* Treat objects like scalars */
4656 else if (!SvOK(d)) {
4657 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4660 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4661 /* Check that the key-sets are identical */
4663 HV *other_hv = MUTABLE_HV(SvRV(d));
4665 bool other_tied = FALSE;
4666 U32 this_key_count = 0,
4667 other_key_count = 0;
4668 HV *hv = MUTABLE_HV(SvRV(e));
4670 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4671 /* Tied hashes don't know how many keys they have. */
4672 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4675 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4676 HV * const temp = other_hv;
4681 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4684 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4687 /* The hashes have the same number of keys, so it suffices
4688 to check that one is a subset of the other. */
4689 (void) hv_iterinit(hv);
4690 while ( (he = hv_iternext(hv)) ) {
4691 SV *key = hv_iterkeysv(he);
4693 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4696 if(!hv_exists_ent(other_hv, key, 0)) {
4697 (void) hv_iterinit(hv); /* reset iterator */
4703 (void) hv_iterinit(other_hv);
4704 while ( hv_iternext(other_hv) )
4708 other_key_count = HvUSEDKEYS(other_hv);
4710 if (this_key_count != other_key_count)
4715 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4716 AV * const other_av = MUTABLE_AV(SvRV(d));
4717 const I32 other_len = av_len(other_av) + 1;
4719 HV *hv = MUTABLE_HV(SvRV(e));
4721 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4722 for (i = 0; i < other_len; ++i) {
4723 SV ** const svp = av_fetch(other_av, i, FALSE);
4724 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4725 if (svp) { /* ??? When can this not happen? */
4726 if (hv_exists_ent(hv, *svp, 0))
4732 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4733 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4736 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4738 HV *hv = MUTABLE_HV(SvRV(e));
4740 (void) hv_iterinit(hv);
4741 while ( (he = hv_iternext(hv)) ) {
4742 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4743 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4744 (void) hv_iterinit(hv);
4745 destroy_matcher(matcher);
4749 destroy_matcher(matcher);
4755 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4756 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4763 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4764 if (object_on_left) {
4765 goto sm_any_array; /* Treat objects like scalars */
4767 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4768 AV * const other_av = MUTABLE_AV(SvRV(e));
4769 const I32 other_len = av_len(other_av) + 1;
4772 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4773 for (i = 0; i < other_len; ++i) {
4774 SV ** const svp = av_fetch(other_av, i, FALSE);
4776 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4777 if (svp) { /* ??? When can this not happen? */
4778 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4784 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4785 AV *other_av = MUTABLE_AV(SvRV(d));
4786 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4787 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4791 const I32 other_len = av_len(other_av);
4793 if (NULL == seen_this) {
4794 seen_this = newHV();
4795 (void) sv_2mortal(MUTABLE_SV(seen_this));
4797 if (NULL == seen_other) {
4798 seen_other = newHV();
4799 (void) sv_2mortal(MUTABLE_SV(seen_other));
4801 for(i = 0; i <= other_len; ++i) {
4802 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4803 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4805 if (!this_elem || !other_elem) {
4806 if ((this_elem && SvOK(*this_elem))
4807 || (other_elem && SvOK(*other_elem)))
4810 else if (hv_exists_ent(seen_this,
4811 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4812 hv_exists_ent(seen_other,
4813 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4815 if (*this_elem != *other_elem)
4819 (void)hv_store_ent(seen_this,
4820 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4822 (void)hv_store_ent(seen_other,
4823 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4829 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4830 (void) do_smartmatch(seen_this, seen_other, 0);
4832 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4841 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4842 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4845 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4846 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4849 for(i = 0; i <= this_len; ++i) {
4850 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4851 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4852 if (svp && matcher_matches_sv(matcher, *svp)) {
4853 destroy_matcher(matcher);
4857 destroy_matcher(matcher);
4861 else if (!SvOK(d)) {
4862 /* undef ~~ array */
4863 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4866 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4867 for (i = 0; i <= this_len; ++i) {
4868 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4869 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4870 if (!svp || !SvOK(*svp))
4879 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4881 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4882 for (i = 0; i <= this_len; ++i) {
4883 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4890 /* infinite recursion isn't supposed to happen here */
4891 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4892 (void) do_smartmatch(NULL, NULL, 1);
4894 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4903 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4904 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4905 SV *t = d; d = e; e = t;
4906 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4909 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4910 SV *t = d; d = e; e = t;
4911 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4912 goto sm_regex_array;
4915 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4917 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4919 PUSHs(matcher_matches_sv(matcher, d)
4922 destroy_matcher(matcher);
4927 /* See if there is overload magic on left */
4928 else if (object_on_left && SvAMAGIC(d)) {
4930 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4931 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4934 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4942 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4945 else if (!SvOK(d)) {
4946 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4947 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4952 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4953 DEBUG_M(if (SvNIOK(e))
4954 Perl_deb(aTHX_ " applying rule Any-Num\n");
4956 Perl_deb(aTHX_ " applying rule Num-numish\n");
4958 /* numeric comparison */
4961 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4962 (void) Perl_pp_i_eq(aTHX);
4964 (void) Perl_pp_eq(aTHX);
4972 /* As a last resort, use string comparison */
4973 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4976 return Perl_pp_seq(aTHX);
4982 register PERL_CONTEXT *cx;
4983 const I32 gimme = GIMME_V;
4985 /* This is essentially an optimization: if the match
4986 fails, we don't want to push a context and then
4987 pop it again right away, so we skip straight
4988 to the op that follows the leavewhen.
4989 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4991 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4992 RETURNOP(cLOGOP->op_other->op_next);
4994 ENTER_with_name("when");
4997 PUSHBLOCK(cx, CXt_WHEN, SP);
5007 register PERL_CONTEXT *cx;
5012 cxix = dopoptogiven(cxstack_ix);
5014 /* diag_listed_as: Can't "when" outside a topicalizer */
5015 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5016 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5019 assert(CxTYPE(cx) == CXt_WHEN);
5022 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
5023 PL_curpm = newpm; /* pop $1 et al */
5025 LEAVE_with_name("when");
5027 if (cxix < cxstack_ix)
5030 cx = &cxstack[cxix];
5032 if (CxFOREACH(cx)) {
5033 /* clear off anything above the scope we're re-entering */
5034 I32 inner = PL_scopestack_ix;
5037 if (PL_scopestack_ix < inner)
5038 leave_scope(PL_scopestack[PL_scopestack_ix]);
5039 PL_curcop = cx->blk_oldcop;
5041 return cx->blk_loop.my_op->op_nextop;
5044 RETURNOP(cx->blk_givwhen.leave_op);
5051 register PERL_CONTEXT *cx;
5056 PERL_UNUSED_VAR(gimme);
5058 cxix = dopoptowhen(cxstack_ix);
5060 DIE(aTHX_ "Can't \"continue\" outside a when block");
5062 if (cxix < cxstack_ix)
5066 assert(CxTYPE(cx) == CXt_WHEN);
5069 PL_curpm = newpm; /* pop $1 et al */
5071 LEAVE_with_name("when");
5072 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5079 register PERL_CONTEXT *cx;
5081 cxix = dopoptogiven(cxstack_ix);
5083 DIE(aTHX_ "Can't \"break\" outside a given block");
5085 cx = &cxstack[cxix];
5087 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5089 if (cxix < cxstack_ix)
5092 /* Restore the sp at the time we entered the given block */
5095 return cx->blk_givwhen.leave_op;
5099 S_doparseform(pTHX_ SV *sv)
5102 register char *s = SvPV(sv, len);
5103 register char *send;
5104 register char *base = NULL; /* start of current field */
5105 register I32 skipspaces = 0; /* number of contiguous spaces seen */
5106 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5107 bool repeat = FALSE; /* ~~ seen on this line */
5108 bool postspace = FALSE; /* a text field may need right padding */
5111 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5113 bool ischop; /* it's a ^ rather than a @ */
5114 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5115 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5119 PERL_ARGS_ASSERT_DOPARSEFORM;
5122 Perl_croak(aTHX_ "Null picture in formline");
5124 if (SvTYPE(sv) >= SVt_PVMG) {
5125 /* This might, of course, still return NULL. */
5126 mg = mg_find(sv, PERL_MAGIC_fm);
5128 sv_upgrade(sv, SVt_PVMG);
5132 /* still the same as previously-compiled string? */
5133 SV *old = mg->mg_obj;
5134 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5135 && len == SvCUR(old)
5136 && strnEQ(SvPVX(old), SvPVX(sv), len)
5138 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5142 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5143 Safefree(mg->mg_ptr);
5149 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5150 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5153 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5154 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5158 /* estimate the buffer size needed */
5159 for (base = s; s <= send; s++) {
5160 if (*s == '\n' || *s == '@' || *s == '^')
5166 Newx(fops, maxops, U32);
5171 *fpc++ = FF_LINEMARK;
5172 noblank = repeat = FALSE;
5190 case ' ': case '\t':
5197 } /* else FALL THROUGH */
5205 *fpc++ = FF_LITERAL;
5213 *fpc++ = (U32)skipspaces;
5217 *fpc++ = FF_NEWLINE;
5221 arg = fpc - linepc + 1;
5228 *fpc++ = FF_LINEMARK;
5229 noblank = repeat = FALSE;
5238 ischop = s[-1] == '^';
5244 arg = (s - base) - 1;
5246 *fpc++ = FF_LITERAL;
5252 if (*s == '*') { /* @* or ^* */
5254 *fpc++ = 2; /* skip the @* or ^* */
5256 *fpc++ = FF_LINESNGL;
5259 *fpc++ = FF_LINEGLOB;
5261 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5262 arg = ischop ? FORM_NUM_BLANK : 0;
5267 const char * const f = ++s;
5270 arg |= FORM_NUM_POINT + (s - f);
5272 *fpc++ = s - base; /* fieldsize for FETCH */
5273 *fpc++ = FF_DECIMAL;
5275 unchopnum |= ! ischop;
5277 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5278 arg = ischop ? FORM_NUM_BLANK : 0;
5280 s++; /* skip the '0' first */
5284 const char * const f = ++s;
5287 arg |= FORM_NUM_POINT + (s - f);
5289 *fpc++ = s - base; /* fieldsize for FETCH */
5290 *fpc++ = FF_0DECIMAL;
5292 unchopnum |= ! ischop;
5294 else { /* text field */
5296 bool ismore = FALSE;
5299 while (*++s == '>') ;
5300 prespace = FF_SPACE;
5302 else if (*s == '|') {
5303 while (*++s == '|') ;
5304 prespace = FF_HALFSPACE;
5309 while (*++s == '<') ;
5312 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5316 *fpc++ = s - base; /* fieldsize for FETCH */
5318 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5321 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5335 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5338 mg->mg_ptr = (char *) fops;
5339 mg->mg_len = arg * sizeof(U32);
5340 mg->mg_obj = sv_copy;
5341 mg->mg_flags |= MGf_REFCOUNTED;
5343 if (unchopnum && repeat)
5344 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5351 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5353 /* Can value be printed in fldsize chars, using %*.*f ? */
5357 int intsize = fldsize - (value < 0 ? 1 : 0);
5359 if (frcsize & FORM_NUM_POINT)
5361 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5364 while (intsize--) pwr *= 10.0;
5365 while (frcsize--) eps /= 10.0;
5368 if (value + eps >= pwr)
5371 if (value - eps <= -pwr)
5378 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5381 SV * const datasv = FILTER_DATA(idx);
5382 const int filter_has_file = IoLINES(datasv);
5383 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5384 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5389 char *prune_from = NULL;
5390 bool read_from_cache = FALSE;
5393 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5395 assert(maxlen >= 0);
5398 /* I was having segfault trouble under Linux 2.2.5 after a
5399 parse error occured. (Had to hack around it with a test
5400 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5401 not sure where the trouble is yet. XXX */
5404 SV *const cache = datasv;
5407 const char *cache_p = SvPV(cache, cache_len);
5411 /* Running in block mode and we have some cached data already.
5413 if (cache_len >= umaxlen) {
5414 /* In fact, so much data we don't even need to call
5419 const char *const first_nl =
5420 (const char *)memchr(cache_p, '\n', cache_len);
5422 take = first_nl + 1 - cache_p;
5426 sv_catpvn(buf_sv, cache_p, take);
5427 sv_chop(cache, cache_p + take);
5428 /* Definitely not EOF */
5432 sv_catsv(buf_sv, cache);
5434 umaxlen -= cache_len;
5437 read_from_cache = TRUE;
5441 /* Filter API says that the filter appends to the contents of the buffer.
5442 Usually the buffer is "", so the details don't matter. But if it's not,
5443 then clearly what it contains is already filtered by this filter, so we
5444 don't want to pass it in a second time.
5445 I'm going to use a mortal in case the upstream filter croaks. */
5446 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5447 ? sv_newmortal() : buf_sv;
5448 SvUPGRADE(upstream, SVt_PV);
5450 if (filter_has_file) {
5451 status = FILTER_READ(idx+1, upstream, 0);
5454 if (filter_sub && status >= 0) {
5458 ENTER_with_name("call_filter_sub");
5463 DEFSV_set(upstream);
5467 PUSHs(filter_state);
5470 count = call_sv(filter_sub, G_SCALAR);
5482 LEAVE_with_name("call_filter_sub");
5485 if(SvOK(upstream)) {
5486 got_p = SvPV(upstream, got_len);
5488 if (got_len > umaxlen) {
5489 prune_from = got_p + umaxlen;
5492 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5493 if (first_nl && first_nl + 1 < got_p + got_len) {
5494 /* There's a second line here... */
5495 prune_from = first_nl + 1;
5500 /* Oh. Too long. Stuff some in our cache. */
5501 STRLEN cached_len = got_p + got_len - prune_from;
5502 SV *const cache = datasv;
5505 /* Cache should be empty. */
5506 assert(!SvCUR(cache));
5509 sv_setpvn(cache, prune_from, cached_len);
5510 /* If you ask for block mode, you may well split UTF-8 characters.
5511 "If it breaks, you get to keep both parts"
5512 (Your code is broken if you don't put them back together again
5513 before something notices.) */
5514 if (SvUTF8(upstream)) {
5517 SvCUR_set(upstream, got_len - cached_len);
5519 /* Can't yet be EOF */
5524 /* If they are at EOF but buf_sv has something in it, then they may never
5525 have touched the SV upstream, so it may be undefined. If we naively
5526 concatenate it then we get a warning about use of uninitialised value.
5528 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5529 sv_catsv(buf_sv, upstream);
5533 IoLINES(datasv) = 0;
5535 SvREFCNT_dec(filter_state);
5536 IoTOP_GV(datasv) = NULL;
5539 SvREFCNT_dec(filter_sub);
5540 IoBOTTOM_GV(datasv) = NULL;
5542 filter_del(S_run_user_filter);
5544 if (status == 0 && read_from_cache) {
5545 /* If we read some data from the cache (and by getting here it implies
5546 that we emptied the cache) then we aren't yet at EOF, and mustn't
5547 report that to our caller. */
5553 /* perhaps someone can come up with a better name for
5554 this? it is not really "absolute", per se ... */
5556 S_path_is_absolute(const char *name)
5558 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5560 if (PERL_FILE_IS_ABSOLUTE(name)
5562 || (*name == '.' && ((name[1] == '/' ||
5563 (name[1] == '.' && name[2] == '/'))
5564 || (name[1] == '\\' ||
5565 ( name[1] == '.' && name[2] == '\\')))
5568 || (*name == '.' && (name[1] == '/' ||
5569 (name[1] == '.' && name[2] == '/')))
5581 * c-indentation-style: bsd
5583 * indent-tabs-mode: nil
5586 * ex: set ts=8 sts=4 sw=4 et: