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
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
96 if (PL_op->op_flags & OPf_STACKED) {
97 /* multiple args; concatentate them */
99 tmpstr = PAD_SV(ARGTARG);
100 sv_setpvs(tmpstr, "");
101 while (++MARK <= SP) {
102 if (PL_amagic_generation) {
104 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
107 sv_setsv(tmpstr, sv);
111 sv_catsv(tmpstr, *MARK);
120 SV * const sv = SvRV(tmpstr);
121 if (SvTYPE(sv) == SVt_REGEXP)
125 re = reg_temp_copy(re);
126 ReREFCNT_dec(PM_GETRE(pm));
131 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
133 assert (re != (REGEXP*) &PL_sv_undef);
135 /* Check against the last compiled regexp. */
136 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
137 memNE(RX_PRECOMP(re), t, len))
139 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
140 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
144 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
146 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
148 } else if (PL_curcop->cop_hints_hash) {
149 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
151 if (ptr && SvIOK(ptr) && SvIV(ptr))
152 eng = INT2PTR(regexp_engine*,SvIV(ptr));
155 if (PL_op->op_flags & OPf_SPECIAL)
156 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
158 if (DO_UTF8(tmpstr)) {
159 assert (SvUTF8(tmpstr));
160 } else if (SvUTF8(tmpstr)) {
161 /* Not doing UTF-8, despite what the SV says. Is this only if
162 we're trapped in use 'bytes'? */
163 /* Make a copy of the octet sequence, but without the flag on,
164 as the compiler now honours the SvUTF8 flag on tmpstr. */
166 const char *const p = SvPV(tmpstr, len);
167 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
171 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
173 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
175 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
176 inside tie/overload accessors. */
182 #ifndef INCOMPLETE_TAINTS
185 RX_EXTFLAGS(re) |= RXf_TAINTED;
187 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
191 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
195 #if !defined(USE_ITHREADS)
196 /* can't change the optree at runtime either */
197 /* PMf_KEEP is handled differently under threads to avoid these problems */
198 if (pm->op_pmflags & PMf_KEEP) {
199 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
200 cLOGOP->op_first->op_next = PL_op->op_next;
210 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
211 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
212 register SV * const dstr = cx->sb_dstr;
213 register char *s = cx->sb_s;
214 register char *m = cx->sb_m;
215 char *orig = cx->sb_orig;
216 register REGEXP * const rx = cx->sb_rx;
218 REGEXP *old = PM_GETRE(pm);
222 PM_SETRE(pm,ReREFCNT_inc(rx));
225 rxres_restore(&cx->sb_rxres, rx);
226 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
228 if (cx->sb_iters++) {
229 const I32 saviters = cx->sb_iters;
230 if (cx->sb_iters > cx->sb_maxiters)
231 DIE(aTHX_ "Substitution loop");
233 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
234 cx->sb_rxtainted |= 2;
235 sv_catsv(dstr, POPs);
238 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
239 s == m, cx->sb_targ, NULL,
240 ((cx->sb_rflags & REXEC_COPY_STR)
241 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
242 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
244 SV * const targ = cx->sb_targ;
246 assert(cx->sb_strend >= s);
247 if(cx->sb_strend > s) {
248 if (DO_UTF8(dstr) && !SvUTF8(targ))
249 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
251 sv_catpvn(dstr, s, cx->sb_strend - s);
253 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
255 #ifdef PERL_OLD_COPY_ON_WRITE
257 sv_force_normal_flags(targ, SV_COW_DROP_PV);
263 SvPV_set(targ, SvPVX(dstr));
264 SvCUR_set(targ, SvCUR(dstr));
265 SvLEN_set(targ, SvLEN(dstr));
268 SvPV_set(dstr, NULL);
270 TAINT_IF(cx->sb_rxtainted & 1);
271 mPUSHi(saviters - 1);
273 (void)SvPOK_only_UTF8(targ);
274 TAINT_IF(cx->sb_rxtainted);
278 LEAVE_SCOPE(cx->sb_oldsave);
280 RETURNOP(pm->op_next);
282 cx->sb_iters = saviters;
284 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
287 cx->sb_orig = orig = RX_SUBBEG(rx);
289 cx->sb_strend = s + (cx->sb_strend - m);
291 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
293 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
294 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
296 sv_catpvn(dstr, s, m-s);
298 cx->sb_s = RX_OFFS(rx)[0].end + orig;
299 { /* Update the pos() information. */
300 SV * const sv = cx->sb_targ;
302 SvUPGRADE(sv, SVt_PVMG);
303 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
306 sv_force_normal_flags(sv, 0);
308 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
311 mg->mg_len = m - orig;
314 (void)ReREFCNT_inc(rx);
315 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
316 rxres_save(&cx->sb_rxres, rx);
317 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
321 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
326 PERL_ARGS_ASSERT_RXRES_SAVE;
329 if (!p || p[1] < RX_NPARENS(rx)) {
330 #ifdef PERL_OLD_COPY_ON_WRITE
331 i = 7 + RX_NPARENS(rx) * 2;
333 i = 6 + RX_NPARENS(rx) * 2;
342 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
343 RX_MATCH_COPIED_off(rx);
345 #ifdef PERL_OLD_COPY_ON_WRITE
346 *p++ = PTR2UV(RX_SAVED_COPY(rx));
347 RX_SAVED_COPY(rx) = NULL;
350 *p++ = RX_NPARENS(rx);
352 *p++ = PTR2UV(RX_SUBBEG(rx));
353 *p++ = (UV)RX_SUBLEN(rx);
354 for (i = 0; i <= RX_NPARENS(rx); ++i) {
355 *p++ = (UV)RX_OFFS(rx)[i].start;
356 *p++ = (UV)RX_OFFS(rx)[i].end;
361 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
366 PERL_ARGS_ASSERT_RXRES_RESTORE;
369 RX_MATCH_COPY_FREE(rx);
370 RX_MATCH_COPIED_set(rx, *p);
373 #ifdef PERL_OLD_COPY_ON_WRITE
374 if (RX_SAVED_COPY(rx))
375 SvREFCNT_dec (RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
380 RX_NPARENS(rx) = *p++;
382 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
383 RX_SUBLEN(rx) = (I32)(*p++);
384 for (i = 0; i <= RX_NPARENS(rx); ++i) {
385 RX_OFFS(rx)[i].start = (I32)(*p++);
386 RX_OFFS(rx)[i].end = (I32)(*p++);
391 S_rxres_free(pTHX_ void **rsp)
393 UV * const p = (UV*)*rsp;
395 PERL_ARGS_ASSERT_RXRES_FREE;
400 void *tmp = INT2PTR(char*,*p);
403 PoisonFree(*p, 1, sizeof(*p));
405 Safefree(INT2PTR(char*,*p));
407 #ifdef PERL_OLD_COPY_ON_WRITE
409 SvREFCNT_dec (INT2PTR(SV*,p[1]));
419 dVAR; dSP; dMARK; dORIGMARK;
420 register SV * const tmpForm = *++MARK;
425 register SV *sv = NULL;
426 const char *item = NULL;
430 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
431 const char *chophere = NULL;
432 char *linemark = NULL;
434 bool gotsome = FALSE;
436 const STRLEN fudge = SvPOK(tmpForm)
437 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
438 bool item_is_utf8 = FALSE;
439 bool targ_is_utf8 = FALSE;
441 OP * parseres = NULL;
444 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445 if (SvREADONLY(tmpForm)) {
446 SvREADONLY_off(tmpForm);
447 parseres = doparseform(tmpForm);
448 SvREADONLY_on(tmpForm);
451 parseres = doparseform(tmpForm);
455 SvPV_force(PL_formtarget, len);
456 if (DO_UTF8(PL_formtarget))
458 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
460 f = SvPV_const(tmpForm, len);
461 /* need to jump to the next word */
462 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
466 const char *name = "???";
469 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
470 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
471 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
472 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
473 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
475 case FF_CHECKNL: name = "CHECKNL"; break;
476 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
477 case FF_SPACE: name = "SPACE"; break;
478 case FF_HALFSPACE: name = "HALFSPACE"; break;
479 case FF_ITEM: name = "ITEM"; break;
480 case FF_CHOP: name = "CHOP"; break;
481 case FF_LINEGLOB: name = "LINEGLOB"; break;
482 case FF_NEWLINE: name = "NEWLINE"; break;
483 case FF_MORE: name = "MORE"; break;
484 case FF_LINEMARK: name = "LINEMARK"; break;
485 case FF_END: name = "END"; break;
486 case FF_0DECIMAL: name = "0DECIMAL"; break;
487 case FF_LINESNGL: name = "LINESNGL"; break;
490 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
492 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
503 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
504 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
506 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
507 t = SvEND(PL_formtarget);
511 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
512 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
514 sv_utf8_upgrade(PL_formtarget);
515 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
516 t = SvEND(PL_formtarget);
536 if (ckWARN(WARN_SYNTAX))
537 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
544 const char *s = item = SvPV_const(sv, len);
547 itemsize = sv_len_utf8(sv);
548 if (itemsize != (I32)len) {
550 if (itemsize > fieldsize) {
551 itemsize = fieldsize;
552 itembytes = itemsize;
553 sv_pos_u2b(sv, &itembytes, 0);
557 send = chophere = s + itembytes;
567 sv_pos_b2u(sv, &itemsize);
571 item_is_utf8 = FALSE;
572 if (itemsize > fieldsize)
573 itemsize = fieldsize;
574 send = chophere = s + itemsize;
588 const char *s = item = SvPV_const(sv, len);
591 itemsize = sv_len_utf8(sv);
592 if (itemsize != (I32)len) {
594 if (itemsize <= fieldsize) {
595 const char *send = chophere = s + itemsize;
608 itemsize = fieldsize;
609 itembytes = itemsize;
610 sv_pos_u2b(sv, &itembytes, 0);
611 send = chophere = s + itembytes;
612 while (s < send || (s == send && isSPACE(*s))) {
622 if (strchr(PL_chopset, *s))
627 itemsize = chophere - item;
628 sv_pos_b2u(sv, &itemsize);
634 item_is_utf8 = FALSE;
635 if (itemsize <= fieldsize) {
636 const char *const send = chophere = s + itemsize;
649 itemsize = fieldsize;
650 send = chophere = s + itemsize;
651 while (s < send || (s == send && isSPACE(*s))) {
661 if (strchr(PL_chopset, *s))
666 itemsize = chophere - item;
672 arg = fieldsize - itemsize;
681 arg = fieldsize - itemsize;
692 const char *s = item;
696 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
698 sv_utf8_upgrade(PL_formtarget);
699 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
700 t = SvEND(PL_formtarget);
704 if (UTF8_IS_CONTINUED(*s)) {
705 STRLEN skip = UTF8SKIP(s);
722 if ( !((*t++ = *s++) & ~31) )
728 if (targ_is_utf8 && !item_is_utf8) {
729 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
731 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
732 for (; t < SvEND(PL_formtarget); t++) {
745 const int ch = *t++ = *s++;
748 if ( !((*t++ = *s++) & ~31) )
757 const char *s = chophere;
771 const bool oneline = fpc[-1] == FF_LINESNGL;
772 const char *s = item = SvPV_const(sv, len);
773 item_is_utf8 = DO_UTF8(sv);
776 STRLEN to_copy = itemsize;
777 const char *const send = s + len;
778 const U8 *source = (const U8 *) s;
782 chophere = s + itemsize;
786 to_copy = s - SvPVX_const(sv) - 1;
798 if (targ_is_utf8 && !item_is_utf8) {
799 source = tmp = bytes_to_utf8(source, &to_copy);
800 SvCUR_set(PL_formtarget,
801 t - SvPVX_const(PL_formtarget));
803 if (item_is_utf8 && !targ_is_utf8) {
804 /* Upgrade targ to UTF8, and then we reduce it to
805 a problem we have a simple solution for. */
806 SvCUR_set(PL_formtarget,
807 t - SvPVX_const(PL_formtarget));
809 /* Don't need get magic. */
810 sv_utf8_upgrade_flags(PL_formtarget, 0);
812 SvCUR_set(PL_formtarget,
813 t - SvPVX_const(PL_formtarget));
816 /* Easy. They agree. */
817 assert (item_is_utf8 == targ_is_utf8);
819 SvGROW(PL_formtarget,
820 SvCUR(PL_formtarget) + to_copy + fudge + 1);
821 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
823 Copy(source, t, to_copy, char);
825 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
827 if (SvGMAGICAL(sv)) {
828 /* Mustn't call sv_pos_b2u() as it does a second
829 mg_get(). Is this a bug? Do we need a _flags()
831 itemsize = utf8_length(source, source + itemsize);
833 sv_pos_b2u(sv, &itemsize);
845 #if defined(USE_LONG_DOUBLE)
848 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
852 "%#0*.*f" : "%0*.*f");
857 #if defined(USE_LONG_DOUBLE)
859 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
862 ((arg & 256) ? "%#*.*f" : "%*.*f");
865 /* If the field is marked with ^ and the value is undefined,
867 if ((arg & 512) && !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 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
886 RESTORE_NUMERIC_STANDARD();
893 while (t-- > linemark && *t == ' ') ;
901 if (arg) { /* repeat until fields exhausted? */
903 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
904 lines += FmLINES(PL_formtarget);
907 if (strnEQ(linemark, linemark - arg, arg))
908 DIE(aTHX_ "Runaway format");
911 SvUTF8_on(PL_formtarget);
912 FmLINES(PL_formtarget) = lines;
914 RETURNOP(cLISTOP->op_first);
925 const char *s = chophere;
926 const char *send = item + len;
928 while (isSPACE(*s) && (s < send))
933 arg = fieldsize - itemsize;
940 if (strnEQ(s1," ",3)) {
941 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
952 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
954 SvUTF8_on(PL_formtarget);
955 FmLINES(PL_formtarget) += lines;
967 if (PL_stack_base + *PL_markstack_ptr == SP) {
969 if (GIMME_V == G_SCALAR)
971 RETURNOP(PL_op->op_next->op_next);
973 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
974 pp_pushmark(); /* push dst */
975 pp_pushmark(); /* push src */
976 ENTER; /* enter outer scope */
979 if (PL_op->op_private & OPpGREP_LEX)
980 SAVESPTR(PAD_SVl(PL_op->op_targ));
983 ENTER; /* enter inner scope */
986 src = PL_stack_base[*PL_markstack_ptr];
988 if (PL_op->op_private & OPpGREP_LEX)
989 PAD_SVl(PL_op->op_targ) = src;
994 if (PL_op->op_type == OP_MAPSTART)
995 pp_pushmark(); /* push top */
996 return ((LOGOP*)PL_op->op_next)->op_other;
1002 const I32 gimme = GIMME_V;
1003 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1009 /* first, move source pointer to the next item in the source list */
1010 ++PL_markstack_ptr[-1];
1012 /* if there are new items, push them into the destination list */
1013 if (items && gimme != G_VOID) {
1014 /* might need to make room back there first */
1015 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1016 /* XXX this implementation is very pessimal because the stack
1017 * is repeatedly extended for every set of items. Is possible
1018 * to do this without any stack extension or copying at all
1019 * by maintaining a separate list over which the map iterates
1020 * (like foreach does). --gsar */
1022 /* everything in the stack after the destination list moves
1023 * towards the end the stack by the amount of room needed */
1024 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1026 /* items to shift up (accounting for the moved source pointer) */
1027 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1029 /* This optimization is by Ben Tilly and it does
1030 * things differently from what Sarathy (gsar)
1031 * is describing. The downside of this optimization is
1032 * that leaves "holes" (uninitialized and hopefully unused areas)
1033 * to the Perl stack, but on the other hand this
1034 * shouldn't be a problem. If Sarathy's idea gets
1035 * implemented, this optimization should become
1036 * irrelevant. --jhi */
1038 shift = count; /* Avoid shifting too often --Ben Tilly */
1042 dst = (SP += shift);
1043 PL_markstack_ptr[-1] += shift;
1044 *PL_markstack_ptr += shift;
1048 /* copy the new items down to the destination list */
1049 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1050 if (gimme == G_ARRAY) {
1052 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1055 /* scalar context: we don't care about which values map returns
1056 * (we use undef here). And so we certainly don't want to do mortal
1057 * copies of meaningless values. */
1058 while (items-- > 0) {
1060 *dst-- = &PL_sv_undef;
1064 LEAVE; /* exit inner scope */
1067 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1069 (void)POPMARK; /* pop top */
1070 LEAVE; /* exit outer scope */
1071 (void)POPMARK; /* pop src */
1072 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1073 (void)POPMARK; /* pop dst */
1074 SP = PL_stack_base + POPMARK; /* pop original mark */
1075 if (gimme == G_SCALAR) {
1076 if (PL_op->op_private & OPpGREP_LEX) {
1077 SV* sv = sv_newmortal();
1078 sv_setiv(sv, items);
1086 else if (gimme == G_ARRAY)
1093 ENTER; /* enter inner scope */
1096 /* set $_ to the new source item */
1097 src = PL_stack_base[PL_markstack_ptr[-1]];
1099 if (PL_op->op_private & OPpGREP_LEX)
1100 PAD_SVl(PL_op->op_targ) = src;
1104 RETURNOP(cLOGOP->op_other);
1113 if (GIMME == G_ARRAY)
1115 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1116 return cLOGOP->op_other;
1126 if (GIMME == G_ARRAY) {
1127 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1131 SV * const targ = PAD_SV(PL_op->op_targ);
1134 if (PL_op->op_private & OPpFLIP_LINENUM) {
1135 if (GvIO(PL_last_in_gv)) {
1136 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1139 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1141 flip = SvIV(sv) == SvIV(GvSV(gv));
1147 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1148 if (PL_op->op_flags & OPf_SPECIAL) {
1156 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1159 sv_setpvs(TARG, "");
1165 /* This code tries to decide if "$left .. $right" should use the
1166 magical string increment, or if the range is numeric (we make
1167 an exception for .."0" [#18165]). AMS 20021031. */
1169 #define RANGE_IS_NUMERIC(left,right) ( \
1170 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1171 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1172 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1173 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1174 && (!SvOK(right) || looks_like_number(right))))
1180 if (GIMME == G_ARRAY) {
1186 if (RANGE_IS_NUMERIC(left,right)) {
1189 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1190 (SvOK(right) && SvNV(right) > IV_MAX))
1191 DIE(aTHX_ "Range iterator outside integer range");
1202 SV * const sv = sv_2mortal(newSViv(i++));
1207 SV * const final = sv_mortalcopy(right);
1209 const char * const tmps = SvPV_const(final, len);
1211 SV *sv = sv_mortalcopy(left);
1212 SvPV_force_nolen(sv);
1213 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1215 if (strEQ(SvPVX_const(sv),tmps))
1217 sv = sv_2mortal(newSVsv(sv));
1224 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1228 if (PL_op->op_private & OPpFLIP_LINENUM) {
1229 if (GvIO(PL_last_in_gv)) {
1230 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1233 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1234 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1242 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1243 sv_catpvs(targ, "E0");
1253 static const char * const context_name[] = {
1256 NULL, /* CXt_BLOCK never actually needs "block" */
1258 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1259 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1260 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1261 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1269 S_dopoptolabel(pTHX_ const char *label)
1274 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1276 for (i = cxstack_ix; i >= 0; i--) {
1277 register const PERL_CONTEXT * const cx = &cxstack[i];
1278 switch (CxTYPE(cx)) {
1286 if (ckWARN(WARN_EXITING))
1287 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1288 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1289 if (CxTYPE(cx) == CXt_NULL)
1292 case CXt_LOOP_LAZYIV:
1293 case CXt_LOOP_LAZYSV:
1295 case CXt_LOOP_PLAIN:
1296 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1297 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1298 (long)i, CxLABEL(cx)));
1301 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1311 Perl_dowantarray(pTHX)
1314 const I32 gimme = block_gimme();
1315 return (gimme == G_VOID) ? G_SCALAR : gimme;
1319 Perl_block_gimme(pTHX)
1322 const I32 cxix = dopoptosub(cxstack_ix);
1326 switch (cxstack[cxix].blk_gimme) {
1334 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1341 Perl_is_lvalue_sub(pTHX)
1344 const I32 cxix = dopoptosub(cxstack_ix);
1345 assert(cxix >= 0); /* We should only be called from inside subs */
1347 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1348 return CxLVAL(cxstack + cxix);
1354 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1359 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1361 for (i = startingblock; i >= 0; i--) {
1362 register const PERL_CONTEXT * const cx = &cxstk[i];
1363 switch (CxTYPE(cx)) {
1369 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1377 S_dopoptoeval(pTHX_ I32 startingblock)
1381 for (i = startingblock; i >= 0; i--) {
1382 register const PERL_CONTEXT *cx = &cxstack[i];
1383 switch (CxTYPE(cx)) {
1387 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1395 S_dopoptoloop(pTHX_ I32 startingblock)
1399 for (i = startingblock; i >= 0; i--) {
1400 register const PERL_CONTEXT * const cx = &cxstack[i];
1401 switch (CxTYPE(cx)) {
1407 if (ckWARN(WARN_EXITING))
1408 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1409 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1410 if ((CxTYPE(cx)) == CXt_NULL)
1413 case CXt_LOOP_LAZYIV:
1414 case CXt_LOOP_LAZYSV:
1416 case CXt_LOOP_PLAIN:
1417 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1425 S_dopoptogiven(pTHX_ I32 startingblock)
1429 for (i = startingblock; i >= 0; i--) {
1430 register const PERL_CONTEXT *cx = &cxstack[i];
1431 switch (CxTYPE(cx)) {
1435 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1437 case CXt_LOOP_PLAIN:
1438 assert(!CxFOREACHDEF(cx));
1440 case CXt_LOOP_LAZYIV:
1441 case CXt_LOOP_LAZYSV:
1443 if (CxFOREACHDEF(cx)) {
1444 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1453 S_dopoptowhen(pTHX_ I32 startingblock)
1457 for (i = startingblock; i >= 0; i--) {
1458 register const PERL_CONTEXT *cx = &cxstack[i];
1459 switch (CxTYPE(cx)) {
1463 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1471 Perl_dounwind(pTHX_ I32 cxix)
1476 while (cxstack_ix > cxix) {
1478 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1479 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1480 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1481 /* Note: we don't need to restore the base context info till the end. */
1482 switch (CxTYPE(cx)) {
1485 continue; /* not break */
1493 case CXt_LOOP_LAZYIV:
1494 case CXt_LOOP_LAZYSV:
1496 case CXt_LOOP_PLAIN:
1507 PERL_UNUSED_VAR(optype);
1511 Perl_qerror(pTHX_ SV *err)
1515 PERL_ARGS_ASSERT_QERROR;
1518 sv_catsv(ERRSV, err);
1520 sv_catsv(PL_errors, err);
1522 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1524 ++PL_parser->error_count;
1528 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1537 if (PL_in_eval & EVAL_KEEPERR) {
1538 static const char prefix[] = "\t(in cleanup) ";
1539 SV * const err = ERRSV;
1540 const char *e = NULL;
1543 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1545 e = SvPV_const(err, len);
1547 if (*e != *message || strNE(e,message))
1551 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1552 sv_catpvn(err, prefix, sizeof(prefix)-1);
1553 sv_catpvn(err, message, msglen);
1554 if (ckWARN(WARN_MISC)) {
1555 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1556 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1557 SvPVX_const(err)+start);
1562 sv_setpvn(ERRSV, message, msglen);
1566 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1567 && PL_curstackinfo->si_prev)
1575 register PERL_CONTEXT *cx;
1578 if (cxix < cxstack_ix)
1581 POPBLOCK(cx,PL_curpm);
1582 if (CxTYPE(cx) != CXt_EVAL) {
1584 message = SvPVx_const(ERRSV, msglen);
1585 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1586 PerlIO_write(Perl_error_log, message, msglen);
1591 if (gimme == G_SCALAR)
1592 *++newsp = &PL_sv_undef;
1593 PL_stack_sp = newsp;
1597 /* LEAVE could clobber PL_curcop (see save_re_context())
1598 * XXX it might be better to find a way to avoid messing with
1599 * PL_curcop in save_re_context() instead, but this is a more
1600 * minimal fix --GSAR */
1601 PL_curcop = cx->blk_oldcop;
1603 if (optype == OP_REQUIRE) {
1604 const char* const msg = SvPVx_nolen_const(ERRSV);
1605 SV * const nsv = cx->blk_eval.old_namesv;
1606 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1608 DIE(aTHX_ "%sCompilation failed in require",
1609 *msg ? msg : "Unknown error\n");
1611 assert(CxTYPE(cx) == CXt_EVAL);
1612 return cx->blk_eval.retop;
1616 message = SvPVx_const(ERRSV, msglen);
1618 write_to_stderr(message, msglen);
1626 dVAR; dSP; dPOPTOPssrl;
1627 if (SvTRUE(left) != SvTRUE(right))
1637 register I32 cxix = dopoptosub(cxstack_ix);
1638 register const PERL_CONTEXT *cx;
1639 register const PERL_CONTEXT *ccstack = cxstack;
1640 const PERL_SI *top_si = PL_curstackinfo;
1642 const char *stashname;
1649 /* we may be in a higher stacklevel, so dig down deeper */
1650 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1651 top_si = top_si->si_prev;
1652 ccstack = top_si->si_cxstack;
1653 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1656 if (GIMME != G_ARRAY) {
1662 /* caller() should not report the automatic calls to &DB::sub */
1663 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1664 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1668 cxix = dopoptosub_at(ccstack, cxix - 1);
1671 cx = &ccstack[cxix];
1672 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1673 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1674 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1675 field below is defined for any cx. */
1676 /* caller() should not report the automatic calls to &DB::sub */
1677 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1678 cx = &ccstack[dbcxix];
1681 stashname = CopSTASHPV(cx->blk_oldcop);
1682 if (GIMME != G_ARRAY) {
1685 PUSHs(&PL_sv_undef);
1688 sv_setpv(TARG, stashname);
1697 PUSHs(&PL_sv_undef);
1699 mPUSHs(newSVpv(stashname, 0));
1700 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1701 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1704 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1705 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1706 /* So is ccstack[dbcxix]. */
1708 SV * const sv = newSV(0);
1709 gv_efullname3(sv, cvgv, NULL);
1711 PUSHs(boolSV(CxHASARGS(cx)));
1714 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1715 PUSHs(boolSV(CxHASARGS(cx)));
1719 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1722 gimme = (I32)cx->blk_gimme;
1723 if (gimme == G_VOID)
1724 PUSHs(&PL_sv_undef);
1726 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1727 if (CxTYPE(cx) == CXt_EVAL) {
1729 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1730 PUSHs(cx->blk_eval.cur_text);
1734 else if (cx->blk_eval.old_namesv) {
1735 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1738 /* eval BLOCK (try blocks have old_namesv == 0) */
1740 PUSHs(&PL_sv_undef);
1741 PUSHs(&PL_sv_undef);
1745 PUSHs(&PL_sv_undef);
1746 PUSHs(&PL_sv_undef);
1748 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1749 && CopSTASH_eq(PL_curcop, PL_debstash))
1751 AV * const ary = cx->blk_sub.argarray;
1752 const int off = AvARRAY(ary) - AvALLOC(ary);
1755 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1756 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1758 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1761 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1762 av_extend(PL_dbargs, AvFILLp(ary) + off);
1763 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1764 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1766 /* XXX only hints propagated via op_private are currently
1767 * visible (others are not easily accessible, since they
1768 * use the global PL_hints) */
1769 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1772 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1774 if (old_warnings == pWARN_NONE ||
1775 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1776 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1777 else if (old_warnings == pWARN_ALL ||
1778 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1779 /* Get the bit mask for $warnings::Bits{all}, because
1780 * it could have been extended by warnings::register */
1782 HV * const bits = get_hv("warnings::Bits", FALSE);
1783 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1784 mask = newSVsv(*bits_all);
1787 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1791 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1795 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1796 sv_2mortal(newRV_noinc(
1797 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1798 cx->blk_oldcop->cop_hints_hash))))
1807 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1808 sv_reset(tmps, CopSTASH(PL_curcop));
1813 /* like pp_nextstate, but used instead when the debugger is active */
1818 PL_curcop = (COP*)PL_op;
1819 TAINT_NOT; /* Each statement is presumed innocent */
1820 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1823 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1824 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1827 register PERL_CONTEXT *cx;
1828 const I32 gimme = G_ARRAY;
1830 GV * const gv = PL_DBgv;
1831 register CV * const cv = GvCV(gv);
1834 DIE(aTHX_ "No DB::DB routine defined");
1836 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1837 /* don't do recursive DB::DB call */
1852 (void)(*CvXSUB(cv))(aTHX_ cv);
1859 PUSHBLOCK(cx, CXt_SUB, SP);
1861 cx->blk_sub.retop = PL_op->op_next;
1864 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1865 RETURNOP(CvSTART(cv));
1875 register PERL_CONTEXT *cx;
1876 const I32 gimme = GIMME_V;
1878 U8 cxtype = CXt_LOOP_FOR;
1886 if (PL_op->op_targ) {
1887 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1888 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1889 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1890 SVs_PADSTALE, SVs_PADSTALE);
1892 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1893 #ifndef USE_ITHREADS
1894 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1900 GV * const gv = MUTABLE_GV(POPs);
1901 svp = &GvSV(gv); /* symbol table variable */
1902 SAVEGENERICSV(*svp);
1905 iterdata = (PAD*)gv;
1909 if (PL_op->op_private & OPpITER_DEF)
1910 cxtype |= CXp_FOR_DEF;
1914 PUSHBLOCK(cx, cxtype, SP);
1916 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1918 PUSHLOOP_FOR(cx, svp, MARK, 0);
1920 if (PL_op->op_flags & OPf_STACKED) {
1921 SV *maybe_ary = POPs;
1922 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1924 SV * const right = maybe_ary;
1927 if (RANGE_IS_NUMERIC(sv,right)) {
1928 cx->cx_type &= ~CXTYPEMASK;
1929 cx->cx_type |= CXt_LOOP_LAZYIV;
1930 /* Make sure that no-one re-orders cop.h and breaks our
1932 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1933 #ifdef NV_PRESERVES_UV
1934 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1935 (SvNV(sv) > (NV)IV_MAX)))
1937 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1938 (SvNV(right) < (NV)IV_MIN))))
1940 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1943 ((SvUV(sv) > (UV)IV_MAX) ||
1944 (SvNV(sv) > (NV)UV_MAX)))))
1946 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1948 ((SvNV(right) > 0) &&
1949 ((SvUV(right) > (UV)IV_MAX) ||
1950 (SvNV(right) > (NV)UV_MAX))))))
1952 DIE(aTHX_ "Range iterator outside integer range");
1953 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1954 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1956 /* for correct -Dstv display */
1957 cx->blk_oldsp = sp - PL_stack_base;
1961 cx->cx_type &= ~CXTYPEMASK;
1962 cx->cx_type |= CXt_LOOP_LAZYSV;
1963 /* Make sure that no-one re-orders cop.h and breaks our
1965 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1966 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1967 cx->blk_loop.state_u.lazysv.end = right;
1968 SvREFCNT_inc(right);
1969 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1970 /* This will do the upgrade to SVt_PV, and warn if the value
1971 is uninitialised. */
1972 (void) SvPV_nolen_const(right);
1973 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1974 to replace !SvOK() with a pointer to "". */
1976 SvREFCNT_dec(right);
1977 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1981 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1982 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1983 SvREFCNT_inc(maybe_ary);
1984 cx->blk_loop.state_u.ary.ix =
1985 (PL_op->op_private & OPpITER_REVERSED) ?
1986 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1990 else { /* iterating over items on the stack */
1991 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1992 if (PL_op->op_private & OPpITER_REVERSED) {
1993 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1996 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2006 register PERL_CONTEXT *cx;
2007 const I32 gimme = GIMME_V;
2013 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2014 PUSHLOOP_PLAIN(cx, SP);
2022 register PERL_CONTEXT *cx;
2029 assert(CxTYPE_is_LOOP(cx));
2031 newsp = PL_stack_base + cx->blk_loop.resetsp;
2034 if (gimme == G_VOID)
2036 else if (gimme == G_SCALAR) {
2038 *++newsp = sv_mortalcopy(*SP);
2040 *++newsp = &PL_sv_undef;
2044 *++newsp = sv_mortalcopy(*++mark);
2045 TAINT_NOT; /* Each item is independent */
2051 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2052 PL_curpm = newpm; /* ... and pop $1 et al */
2063 register PERL_CONTEXT *cx;
2064 bool popsub2 = FALSE;
2065 bool clear_errsv = FALSE;
2073 const I32 cxix = dopoptosub(cxstack_ix);
2076 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2077 * sort block, which is a CXt_NULL
2080 PL_stack_base[1] = *PL_stack_sp;
2081 PL_stack_sp = PL_stack_base + 1;
2085 DIE(aTHX_ "Can't return outside a subroutine");
2087 if (cxix < cxstack_ix)
2090 if (CxMULTICALL(&cxstack[cxix])) {
2091 gimme = cxstack[cxix].blk_gimme;
2092 if (gimme == G_VOID)
2093 PL_stack_sp = PL_stack_base;
2094 else if (gimme == G_SCALAR) {
2095 PL_stack_base[1] = *PL_stack_sp;
2096 PL_stack_sp = PL_stack_base + 1;
2102 switch (CxTYPE(cx)) {
2105 retop = cx->blk_sub.retop;
2106 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2109 if (!(PL_in_eval & EVAL_KEEPERR))
2112 retop = cx->blk_eval.retop;
2116 if (optype == OP_REQUIRE &&
2117 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2119 /* Unassume the success we assumed earlier. */
2120 SV * const nsv = cx->blk_eval.old_namesv;
2121 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2122 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2127 retop = cx->blk_sub.retop;
2130 DIE(aTHX_ "panic: return");
2134 if (gimme == G_SCALAR) {
2137 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2139 *++newsp = SvREFCNT_inc(*SP);
2144 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2146 *++newsp = sv_mortalcopy(sv);
2151 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2154 *++newsp = sv_mortalcopy(*SP);
2157 *++newsp = &PL_sv_undef;
2159 else if (gimme == G_ARRAY) {
2160 while (++MARK <= SP) {
2161 *++newsp = (popsub2 && SvTEMP(*MARK))
2162 ? *MARK : sv_mortalcopy(*MARK);
2163 TAINT_NOT; /* Each item is independent */
2166 PL_stack_sp = newsp;
2169 /* Stack values are safe: */
2172 POPSUB(cx,sv); /* release CV and @_ ... */
2176 PL_curpm = newpm; /* ... and pop $1 et al */
2189 register PERL_CONTEXT *cx;
2200 if (PL_op->op_flags & OPf_SPECIAL) {
2201 cxix = dopoptoloop(cxstack_ix);
2203 DIE(aTHX_ "Can't \"last\" outside a loop block");
2206 cxix = dopoptolabel(cPVOP->op_pv);
2208 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2210 if (cxix < cxstack_ix)
2214 cxstack_ix++; /* temporarily protect top context */
2216 switch (CxTYPE(cx)) {
2217 case CXt_LOOP_LAZYIV:
2218 case CXt_LOOP_LAZYSV:
2220 case CXt_LOOP_PLAIN:
2222 newsp = PL_stack_base + cx->blk_loop.resetsp;
2223 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2227 nextop = cx->blk_sub.retop;
2231 nextop = cx->blk_eval.retop;
2235 nextop = cx->blk_sub.retop;
2238 DIE(aTHX_ "panic: last");
2242 if (gimme == G_SCALAR) {
2244 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2245 ? *SP : sv_mortalcopy(*SP);
2247 *++newsp = &PL_sv_undef;
2249 else if (gimme == G_ARRAY) {
2250 while (++MARK <= SP) {
2251 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2252 ? *MARK : sv_mortalcopy(*MARK);
2253 TAINT_NOT; /* Each item is independent */
2261 /* Stack values are safe: */
2263 case CXt_LOOP_LAZYIV:
2264 case CXt_LOOP_PLAIN:
2265 case CXt_LOOP_LAZYSV:
2267 POPLOOP(cx); /* release loop vars ... */
2271 POPSUB(cx,sv); /* release CV and @_ ... */
2274 PL_curpm = newpm; /* ... and pop $1 et al */
2277 PERL_UNUSED_VAR(optype);
2278 PERL_UNUSED_VAR(gimme);
2286 register PERL_CONTEXT *cx;
2289 if (PL_op->op_flags & OPf_SPECIAL) {
2290 cxix = dopoptoloop(cxstack_ix);
2292 DIE(aTHX_ "Can't \"next\" outside a loop block");
2295 cxix = dopoptolabel(cPVOP->op_pv);
2297 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2299 if (cxix < cxstack_ix)
2302 /* clear off anything above the scope we're re-entering, but
2303 * save the rest until after a possible continue block */
2304 inner = PL_scopestack_ix;
2306 if (PL_scopestack_ix < inner)
2307 leave_scope(PL_scopestack[PL_scopestack_ix]);
2308 PL_curcop = cx->blk_oldcop;
2309 return CX_LOOP_NEXTOP_GET(cx);
2316 register PERL_CONTEXT *cx;
2320 if (PL_op->op_flags & OPf_SPECIAL) {
2321 cxix = dopoptoloop(cxstack_ix);
2323 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2326 cxix = dopoptolabel(cPVOP->op_pv);
2328 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2330 if (cxix < cxstack_ix)
2333 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2334 if (redo_op->op_type == OP_ENTER) {
2335 /* pop one less context to avoid $x being freed in while (my $x..) */
2337 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2338 redo_op = redo_op->op_next;
2342 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2343 LEAVE_SCOPE(oldsave);
2345 PL_curcop = cx->blk_oldcop;
2350 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2354 static const char too_deep[] = "Target of goto is too deeply nested";
2356 PERL_ARGS_ASSERT_DOFINDLABEL;
2359 Perl_croak(aTHX_ too_deep);
2360 if (o->op_type == OP_LEAVE ||
2361 o->op_type == OP_SCOPE ||
2362 o->op_type == OP_LEAVELOOP ||
2363 o->op_type == OP_LEAVESUB ||
2364 o->op_type == OP_LEAVETRY)
2366 *ops++ = cUNOPo->op_first;
2368 Perl_croak(aTHX_ too_deep);
2371 if (o->op_flags & OPf_KIDS) {
2373 /* First try all the kids at this level, since that's likeliest. */
2374 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2375 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2376 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2379 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2380 if (kid == PL_lastgotoprobe)
2382 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2385 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2386 ops[-1]->op_type == OP_DBSTATE)
2391 if ((o = dofindlabel(kid, label, ops, oplimit)))
2404 register PERL_CONTEXT *cx;
2405 #define GOTO_DEPTH 64
2406 OP *enterops[GOTO_DEPTH];
2407 const char *label = NULL;
2408 const bool do_dump = (PL_op->op_type == OP_DUMP);
2409 static const char must_have_label[] = "goto must have label";
2411 if (PL_op->op_flags & OPf_STACKED) {
2412 SV * const sv = POPs;
2414 /* This egregious kludge implements goto &subroutine */
2415 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2417 register PERL_CONTEXT *cx;
2418 CV *cv = MUTABLE_CV(SvRV(sv));
2425 if (!CvROOT(cv) && !CvXSUB(cv)) {
2426 const GV * const gv = CvGV(cv);
2430 /* autoloaded stub? */
2431 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2433 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2434 GvNAMELEN(gv), FALSE);
2435 if (autogv && (cv = GvCV(autogv)))
2437 tmpstr = sv_newmortal();
2438 gv_efullname3(tmpstr, gv, NULL);
2439 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2441 DIE(aTHX_ "Goto undefined subroutine");
2444 /* First do some returnish stuff. */
2445 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2447 cxix = dopoptosub(cxstack_ix);
2449 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2450 if (cxix < cxstack_ix)
2454 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2455 if (CxTYPE(cx) == CXt_EVAL) {
2457 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2459 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2461 else if (CxMULTICALL(cx))
2462 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2463 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2464 /* put @_ back onto stack */
2465 AV* av = cx->blk_sub.argarray;
2467 items = AvFILLp(av) + 1;
2468 EXTEND(SP, items+1); /* @_ could have been extended. */
2469 Copy(AvARRAY(av), SP + 1, items, SV*);
2470 SvREFCNT_dec(GvAV(PL_defgv));
2471 GvAV(PL_defgv) = cx->blk_sub.savearray;
2473 /* abandon @_ if it got reified */
2478 av_extend(av, items-1);
2480 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2483 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2484 AV* const av = GvAV(PL_defgv);
2485 items = AvFILLp(av) + 1;
2486 EXTEND(SP, items+1); /* @_ could have been extended. */
2487 Copy(AvARRAY(av), SP + 1, items, SV*);
2491 if (CxTYPE(cx) == CXt_SUB &&
2492 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2493 SvREFCNT_dec(cx->blk_sub.cv);
2494 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2495 LEAVE_SCOPE(oldsave);
2497 /* Now do some callish stuff. */
2499 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2501 OP* const retop = cx->blk_sub.retop;
2506 for (index=0; index<items; index++)
2507 sv_2mortal(SP[-index]);
2510 /* XS subs don't have a CxSUB, so pop it */
2511 POPBLOCK(cx, PL_curpm);
2512 /* Push a mark for the start of arglist */
2515 (void)(*CvXSUB(cv))(aTHX_ cv);
2520 AV* const padlist = CvPADLIST(cv);
2521 if (CxTYPE(cx) == CXt_EVAL) {
2522 PL_in_eval = CxOLD_IN_EVAL(cx);
2523 PL_eval_root = cx->blk_eval.old_eval_root;
2524 cx->cx_type = CXt_SUB;
2526 cx->blk_sub.cv = cv;
2527 cx->blk_sub.olddepth = CvDEPTH(cv);
2530 if (CvDEPTH(cv) < 2)
2531 SvREFCNT_inc_simple_void_NN(cv);
2533 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2534 sub_crush_depth(cv);
2535 pad_push(padlist, CvDEPTH(cv));
2538 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2541 AV *const av = MUTABLE_AV(PAD_SVl(0));
2543 cx->blk_sub.savearray = GvAV(PL_defgv);
2544 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2545 CX_CURPAD_SAVE(cx->blk_sub);
2546 cx->blk_sub.argarray = av;
2548 if (items >= AvMAX(av) + 1) {
2549 SV **ary = AvALLOC(av);
2550 if (AvARRAY(av) != ary) {
2551 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2554 if (items >= AvMAX(av) + 1) {
2555 AvMAX(av) = items - 1;
2556 Renew(ary,items+1,SV*);
2562 Copy(mark,AvARRAY(av),items,SV*);
2563 AvFILLp(av) = items - 1;
2564 assert(!AvREAL(av));
2566 /* transfer 'ownership' of refcnts to new @_ */
2576 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2577 Perl_get_db_sub(aTHX_ NULL, cv);
2579 CV * const gotocv = get_cv("DB::goto", FALSE);
2581 PUSHMARK( PL_stack_sp );
2582 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2587 RETURNOP(CvSTART(cv));
2591 label = SvPV_nolen_const(sv);
2592 if (!(do_dump || *label))
2593 DIE(aTHX_ must_have_label);
2596 else if (PL_op->op_flags & OPf_SPECIAL) {
2598 DIE(aTHX_ must_have_label);
2601 label = cPVOP->op_pv;
2603 if (label && *label) {
2604 OP *gotoprobe = NULL;
2605 bool leaving_eval = FALSE;
2606 bool in_block = FALSE;
2607 PERL_CONTEXT *last_eval_cx = NULL;
2611 PL_lastgotoprobe = NULL;
2613 for (ix = cxstack_ix; ix >= 0; ix--) {
2615 switch (CxTYPE(cx)) {
2617 leaving_eval = TRUE;
2618 if (!CxTRYBLOCK(cx)) {
2619 gotoprobe = (last_eval_cx ?
2620 last_eval_cx->blk_eval.old_eval_root :
2625 /* else fall through */
2626 case CXt_LOOP_LAZYIV:
2627 case CXt_LOOP_LAZYSV:
2629 case CXt_LOOP_PLAIN:
2630 gotoprobe = cx->blk_oldcop->op_sibling;
2636 gotoprobe = cx->blk_oldcop->op_sibling;
2639 gotoprobe = PL_main_root;
2642 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2643 gotoprobe = CvROOT(cx->blk_sub.cv);
2649 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2652 DIE(aTHX_ "panic: goto");
2653 gotoprobe = PL_main_root;
2657 retop = dofindlabel(gotoprobe, label,
2658 enterops, enterops + GOTO_DEPTH);
2662 PL_lastgotoprobe = gotoprobe;
2665 DIE(aTHX_ "Can't find label %s", label);
2667 /* if we're leaving an eval, check before we pop any frames
2668 that we're not going to punt, otherwise the error
2671 if (leaving_eval && *enterops && enterops[1]) {
2673 for (i = 1; enterops[i]; i++)
2674 if (enterops[i]->op_type == OP_ENTERITER)
2675 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2678 /* pop unwanted frames */
2680 if (ix < cxstack_ix) {
2687 oldsave = PL_scopestack[PL_scopestack_ix];
2688 LEAVE_SCOPE(oldsave);
2691 /* push wanted frames */
2693 if (*enterops && enterops[1]) {
2694 OP * const oldop = PL_op;
2695 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2696 for (; enterops[ix]; ix++) {
2697 PL_op = enterops[ix];
2698 /* Eventually we may want to stack the needed arguments
2699 * for each op. For now, we punt on the hard ones. */
2700 if (PL_op->op_type == OP_ENTERITER)
2701 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2702 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2710 if (!retop) retop = PL_main_start;
2712 PL_restartop = retop;
2713 PL_do_undump = TRUE;
2717 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2718 PL_do_undump = FALSE;
2735 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2737 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2740 PL_exit_flags |= PERL_EXIT_EXPECTED;
2742 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2743 if (anum || !(PL_minus_c && PL_madskills))
2748 PUSHs(&PL_sv_undef);
2755 S_save_lines(pTHX_ AV *array, SV *sv)
2757 const char *s = SvPVX_const(sv);
2758 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2761 PERL_ARGS_ASSERT_SAVE_LINES;
2763 while (s && s < send) {
2765 SV * const tmpstr = newSV_type(SVt_PVMG);
2767 t = (const char *)memchr(s, '\n', send - s);
2773 sv_setpvn(tmpstr, s, t - s);
2774 av_store(array, line++, tmpstr);
2780 S_docatch(pTHX_ OP *o)
2784 OP * const oldop = PL_op;
2788 assert(CATCH_GET == TRUE);
2795 assert(cxstack_ix >= 0);
2796 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2797 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2802 /* die caught by an inner eval - continue inner loop */
2804 /* NB XXX we rely on the old popped CxEVAL still being at the top
2805 * of the stack; the way die_where() currently works, this
2806 * assumption is valid. In theory The cur_top_env value should be
2807 * returned in another global, the way retop (aka PL_restartop)
2809 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2812 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2814 PL_op = PL_restartop;
2831 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2832 /* sv Text to convert to OP tree. */
2833 /* startop op_free() this to undo. */
2834 /* code Short string id of the caller. */
2836 /* FIXME - how much of this code is common with pp_entereval? */
2837 dVAR; dSP; /* Make POPBLOCK work. */
2843 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2844 char *tmpbuf = tbuf;
2847 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2850 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2853 lex_start(sv, NULL, FALSE);
2855 /* switch to eval mode */
2857 if (IN_PERL_COMPILETIME) {
2858 SAVECOPSTASH_FREE(&PL_compiling);
2859 CopSTASH_set(&PL_compiling, PL_curstash);
2861 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2862 SV * const sv = sv_newmortal();
2863 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2864 code, (unsigned long)++PL_evalseq,
2865 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2870 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2871 (unsigned long)++PL_evalseq);
2872 SAVECOPFILE_FREE(&PL_compiling);
2873 CopFILE_set(&PL_compiling, tmpbuf+2);
2874 SAVECOPLINE(&PL_compiling);
2875 CopLINE_set(&PL_compiling, 1);
2876 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2877 deleting the eval's FILEGV from the stash before gv_check() runs
2878 (i.e. before run-time proper). To work around the coredump that
2879 ensues, we always turn GvMULTI_on for any globals that were
2880 introduced within evals. See force_ident(). GSAR 96-10-12 */
2881 safestr = savepvn(tmpbuf, len);
2882 SAVEDELETE(PL_defstash, safestr, len);
2884 #ifdef OP_IN_REGISTER
2890 /* we get here either during compilation, or via pp_regcomp at runtime */
2891 runtime = IN_PERL_RUNTIME;
2893 runcv = find_runcv(NULL);
2896 PL_op->op_type = OP_ENTEREVAL;
2897 PL_op->op_flags = 0; /* Avoid uninit warning. */
2898 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2902 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2904 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2905 POPBLOCK(cx,PL_curpm);
2908 (*startop)->op_type = OP_NULL;
2909 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2911 /* XXX DAPM do this properly one year */
2912 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2914 if (IN_PERL_COMPILETIME)
2915 CopHINTS_set(&PL_compiling, PL_hints);
2916 #ifdef OP_IN_REGISTER
2919 PERL_UNUSED_VAR(newsp);
2920 PERL_UNUSED_VAR(optype);
2922 return PL_eval_start;
2927 =for apidoc find_runcv
2929 Locate the CV corresponding to the currently executing sub or eval.
2930 If db_seqp is non_null, skip CVs that are in the DB package and populate
2931 *db_seqp with the cop sequence number at the point that the DB:: code was
2932 entered. (allows debuggers to eval in the scope of the breakpoint rather
2933 than in the scope of the debugger itself).
2939 Perl_find_runcv(pTHX_ U32 *db_seqp)
2945 *db_seqp = PL_curcop->cop_seq;
2946 for (si = PL_curstackinfo; si; si = si->si_prev) {
2948 for (ix = si->si_cxix; ix >= 0; ix--) {
2949 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2950 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2951 CV * const cv = cx->blk_sub.cv;
2952 /* skip DB:: code */
2953 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2954 *db_seqp = cx->blk_oldcop->cop_seq;
2959 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2967 /* Compile a require/do, an eval '', or a /(?{...})/.
2968 * In the last case, startop is non-null, and contains the address of
2969 * a pointer that should be set to the just-compiled code.
2970 * outside is the lexically enclosing CV (if any) that invoked us.
2971 * Returns a bool indicating whether the compile was successful; if so,
2972 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2973 * pushes undef (also croaks if startop != NULL).
2977 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2980 OP * const saveop = PL_op;
2982 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2983 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2988 SAVESPTR(PL_compcv);
2989 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2990 CvEVAL_on(PL_compcv);
2991 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2992 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2994 CvOUTSIDE_SEQ(PL_compcv) = seq;
2995 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2997 /* set up a scratch pad */
2999 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3000 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3004 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3006 /* make sure we compile in the right package */
3008 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3009 SAVESPTR(PL_curstash);
3010 PL_curstash = CopSTASH(PL_curcop);
3012 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3013 SAVESPTR(PL_beginav);
3014 PL_beginav = newAV();
3015 SAVEFREESV(PL_beginav);
3016 SAVESPTR(PL_unitcheckav);
3017 PL_unitcheckav = newAV();
3018 SAVEFREESV(PL_unitcheckav);
3021 SAVEBOOL(PL_madskills);
3025 /* try to compile it */
3027 PL_eval_root = NULL;
3028 PL_curcop = &PL_compiling;
3029 CopARYBASE_set(PL_curcop, 0);
3030 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3031 PL_in_eval |= EVAL_KEEPERR;
3034 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3035 SV **newsp; /* Used by POPBLOCK. */
3036 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3037 I32 optype = 0; /* Might be reset by POPEVAL. */
3042 op_free(PL_eval_root);
3043 PL_eval_root = NULL;
3045 SP = PL_stack_base + POPMARK; /* pop original mark */
3047 POPBLOCK(cx,PL_curpm);
3053 msg = SvPVx_nolen_const(ERRSV);
3054 if (optype == OP_REQUIRE) {
3055 const SV * const nsv = cx->blk_eval.old_namesv;
3056 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3058 Perl_croak(aTHX_ "%sCompilation failed in require",
3059 *msg ? msg : "Unknown error\n");
3062 POPBLOCK(cx,PL_curpm);
3064 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3065 (*msg ? msg : "Unknown error\n"));
3069 sv_setpvs(ERRSV, "Compilation error");
3072 PERL_UNUSED_VAR(newsp);
3073 PUSHs(&PL_sv_undef);
3077 CopLINE_set(&PL_compiling, 0);
3079 *startop = PL_eval_root;
3081 SAVEFREEOP(PL_eval_root);
3083 /* Set the context for this new optree.
3084 * If the last op is an OP_REQUIRE, force scalar context.
3085 * Otherwise, propagate the context from the eval(). */
3086 if (PL_eval_root->op_type == OP_LEAVEEVAL
3087 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3088 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3090 scalar(PL_eval_root);
3091 else if ((gimme & G_WANT) == G_VOID)
3092 scalarvoid(PL_eval_root);
3093 else if ((gimme & G_WANT) == G_ARRAY)
3096 scalar(PL_eval_root);
3098 DEBUG_x(dump_eval());
3100 /* Register with debugger: */
3101 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3102 CV * const cv = get_cv("DB::postponed", FALSE);
3106 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3108 call_sv(MUTABLE_SV(cv), G_DISCARD);
3113 call_list(PL_scopestack_ix, PL_unitcheckav);
3115 /* compiled okay, so do it */
3117 CvDEPTH(PL_compcv) = 1;
3118 SP = PL_stack_base + POPMARK; /* pop original mark */
3119 PL_op = saveop; /* The caller may need it. */
3120 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3127 S_check_type_and_open(pTHX_ const char *name)
3130 const int st_rc = PerlLIO_stat(name, &st);
3132 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3134 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3138 return PerlIO_open(name, PERL_SCRIPT_MODE);
3141 #ifndef PERL_DISABLE_PMC
3143 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3147 PERL_ARGS_ASSERT_DOOPEN_PM;
3149 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3150 SV *const pmcsv = newSV(namelen + 2);
3151 char *const pmc = SvPVX(pmcsv);
3154 memcpy(pmc, name, namelen);
3156 pmc[namelen + 1] = '\0';
3158 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3159 fp = check_type_and_open(name);
3162 fp = check_type_and_open(pmc);
3164 SvREFCNT_dec(pmcsv);
3167 fp = check_type_and_open(name);
3172 # define doopen_pm(name, namelen) check_type_and_open(name)
3173 #endif /* !PERL_DISABLE_PMC */
3178 register PERL_CONTEXT *cx;
3185 int vms_unixname = 0;
3187 const char *tryname = NULL;
3189 const I32 gimme = GIMME_V;
3190 int filter_has_file = 0;
3191 PerlIO *tryrsfp = NULL;
3192 SV *filter_cache = NULL;
3193 SV *filter_state = NULL;
3194 SV *filter_sub = NULL;
3200 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3201 sv = new_version(sv);
3202 if (!sv_derived_from(PL_patchlevel, "version"))
3203 upg_version(PL_patchlevel, TRUE);
3204 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3205 if ( vcmp(sv,PL_patchlevel) <= 0 )
3206 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3207 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3210 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3213 SV * const req = SvRV(sv);
3214 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3216 /* get the left hand term */
3217 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3219 first = SvIV(*av_fetch(lav,0,0));
3220 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3221 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3222 || av_len(lav) > 1 /* FP with > 3 digits */
3223 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3225 DIE(aTHX_ "Perl %"SVf" required--this is only "
3226 "%"SVf", stopped", SVfARG(vnormal(req)),
3227 SVfARG(vnormal(PL_patchlevel)));
3229 else { /* probably 'use 5.10' or 'use 5.8' */
3230 SV * hintsv = newSV(0);
3234 second = SvIV(*av_fetch(lav,1,0));
3236 second /= second >= 600 ? 100 : 10;
3237 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3238 (int)first, (int)second,0);
3239 upg_version(hintsv, TRUE);
3241 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3242 "--this is only %"SVf", stopped",
3243 SVfARG(vnormal(req)),
3244 SVfARG(vnormal(hintsv)),
3245 SVfARG(vnormal(PL_patchlevel)));
3250 /* We do this only with use, not require. */
3252 /* If we request a version >= 5.9.5, load feature.pm with the
3253 * feature bundle that corresponds to the required version. */
3254 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3255 SV *const importsv = vnormal(sv);
3256 *SvPVX_mutable(importsv) = ':';
3258 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3264 name = SvPV_const(sv, len);
3265 if (!(name && len > 0 && *name))
3266 DIE(aTHX_ "Null filename used");
3267 TAINT_PROPER("require");
3271 /* The key in the %ENV hash is in the syntax of file passed as the argument
3272 * usually this is in UNIX format, but sometimes in VMS format, which
3273 * can result in a module being pulled in more than once.
3274 * To prevent this, the key must be stored in UNIX format if the VMS
3275 * name can be translated to UNIX.
3277 if ((unixname = tounixspec(name, NULL)) != NULL) {
3278 unixlen = strlen(unixname);
3284 /* if not VMS or VMS name can not be translated to UNIX, pass it
3287 unixname = (char *) name;
3290 if (PL_op->op_type == OP_REQUIRE) {
3291 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3292 unixname, unixlen, 0);
3294 if (*svp != &PL_sv_undef)
3297 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3298 "Compilation failed in require", unixname);
3302 /* prepare to compile file */
3304 if (path_is_absolute(name)) {
3306 tryrsfp = doopen_pm(name, len);
3308 #ifdef MACOS_TRADITIONAL
3312 MacPerl_CanonDir(name, newname, 1);
3313 if (path_is_absolute(newname)) {
3315 tryrsfp = doopen_pm(newname, strlen(newname));
3320 AV * const ar = GvAVn(PL_incgv);
3326 namesv = newSV_type(SVt_PV);
3327 for (i = 0; i <= AvFILL(ar); i++) {
3328 SV * const dirsv = *av_fetch(ar, i, TRUE);
3330 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3337 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3338 && !sv_isobject(loader))
3340 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3343 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3344 PTR2UV(SvRV(dirsv)), name);
3345 tryname = SvPVX_const(namesv);
3356 if (sv_isobject(loader))
3357 count = call_method("INC", G_ARRAY);
3359 count = call_sv(loader, G_ARRAY);
3362 /* Adjust file name if the hook has set an %INC entry */
3363 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3365 tryname = SvPVX_const(*svp);
3374 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3375 && !isGV_with_GP(SvRV(arg))) {
3376 filter_cache = SvRV(arg);
3377 SvREFCNT_inc_simple_void_NN(filter_cache);
3384 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3388 if (isGV_with_GP(arg)) {
3389 IO * const io = GvIO((const GV *)arg);
3394 tryrsfp = IoIFP(io);
3395 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3396 PerlIO_close(IoOFP(io));
3407 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3409 SvREFCNT_inc_simple_void_NN(filter_sub);
3412 filter_state = SP[i];
3413 SvREFCNT_inc_simple_void(filter_state);
3417 if (!tryrsfp && (filter_cache || filter_sub)) {
3418 tryrsfp = PerlIO_open(BIT_BUCKET,
3433 filter_has_file = 0;
3435 SvREFCNT_dec(filter_cache);
3436 filter_cache = NULL;
3439 SvREFCNT_dec(filter_state);
3440 filter_state = NULL;
3443 SvREFCNT_dec(filter_sub);
3448 if (!path_is_absolute(name)
3449 #ifdef MACOS_TRADITIONAL
3450 /* We consider paths of the form :a:b ambiguous and interpret them first
3451 as global then as local
3453 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3460 dir = SvPV_const(dirsv, dirlen);
3466 #ifdef MACOS_TRADITIONAL
3470 MacPerl_CanonDir(name, buf2, 1);
3471 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3475 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3477 sv_setpv(namesv, unixdir);
3478 sv_catpv(namesv, unixname);
3480 # ifdef __SYMBIAN32__
3481 if (PL_origfilename[0] &&
3482 PL_origfilename[1] == ':' &&
3483 !(dir[0] && dir[1] == ':'))
3484 Perl_sv_setpvf(aTHX_ namesv,
3489 Perl_sv_setpvf(aTHX_ namesv,
3493 /* The equivalent of
3494 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3495 but without the need to parse the format string, or
3496 call strlen on either pointer, and with the correct
3497 allocation up front. */
3499 char *tmp = SvGROW(namesv, dirlen + len + 2);
3501 memcpy(tmp, dir, dirlen);
3504 /* name came from an SV, so it will have a '\0' at the
3505 end that we can copy as part of this memcpy(). */
3506 memcpy(tmp, name, len + 1);
3508 SvCUR_set(namesv, dirlen + len + 1);
3510 /* Don't even actually have to turn SvPOK_on() as we
3511 access it directly with SvPVX() below. */
3516 TAINT_PROPER("require");
3517 tryname = SvPVX_const(namesv);
3518 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3520 if (tryname[0] == '.' && tryname[1] == '/')
3524 else if (errno == EMFILE)
3525 /* no point in trying other paths if out of handles */
3532 SAVECOPFILE_FREE(&PL_compiling);
3533 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3534 SvREFCNT_dec(namesv);
3536 if (PL_op->op_type == OP_REQUIRE) {
3537 const char *msgstr = name;
3538 if(errno == EMFILE) {
3540 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3542 msgstr = SvPV_nolen_const(msg);
3544 if (namesv) { /* did we lookup @INC? */
3545 AV * const ar = GvAVn(PL_incgv);
3547 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3548 "%s in @INC%s%s (@INC contains:",
3550 (instr(msgstr, ".h ")
3551 ? " (change .h to .ph maybe?)" : ""),
3552 (instr(msgstr, ".ph ")
3553 ? " (did you run h2ph?)" : "")
3556 for (i = 0; i <= AvFILL(ar); i++) {
3557 sv_catpvs(msg, " ");
3558 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3560 sv_catpvs(msg, ")");
3561 msgstr = SvPV_nolen_const(msg);
3564 DIE(aTHX_ "Can't locate %s", msgstr);
3570 SETERRNO(0, SS_NORMAL);
3572 /* Assume success here to prevent recursive requirement. */
3573 /* name is never assigned to again, so len is still strlen(name) */
3574 /* Check whether a hook in @INC has already filled %INC */
3576 (void)hv_store(GvHVn(PL_incgv),
3577 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3579 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3581 (void)hv_store(GvHVn(PL_incgv),
3582 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3587 lex_start(NULL, tryrsfp, TRUE);
3591 if (PL_compiling.cop_hints_hash) {
3592 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3593 PL_compiling.cop_hints_hash = NULL;
3596 SAVECOMPILEWARNINGS();
3597 if (PL_dowarn & G_WARN_ALL_ON)
3598 PL_compiling.cop_warnings = pWARN_ALL ;
3599 else if (PL_dowarn & G_WARN_ALL_OFF)
3600 PL_compiling.cop_warnings = pWARN_NONE ;
3602 PL_compiling.cop_warnings = pWARN_STD ;
3604 if (filter_sub || filter_cache) {
3605 SV * const datasv = filter_add(S_run_user_filter, NULL);
3606 IoLINES(datasv) = filter_has_file;
3607 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3608 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3609 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3612 /* switch to eval mode */
3613 PUSHBLOCK(cx, CXt_EVAL, SP);
3615 cx->blk_eval.retop = PL_op->op_next;
3617 SAVECOPLINE(&PL_compiling);
3618 CopLINE_set(&PL_compiling, 0);
3622 /* Store and reset encoding. */
3623 encoding = PL_encoding;
3626 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3627 op = DOCATCH(PL_eval_start);
3629 op = PL_op->op_next;
3631 /* Restore encoding. */
3632 PL_encoding = encoding;
3637 /* This is a op added to hold the hints hash for
3638 pp_entereval. The hash can be modified by the code
3639 being eval'ed, so we return a copy instead. */
3645 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3653 register PERL_CONTEXT *cx;
3655 const I32 gimme = GIMME_V;
3656 const U32 was = PL_breakable_sub_gen;
3657 char tbuf[TYPE_DIGITS(long) + 12];
3658 char *tmpbuf = tbuf;
3664 HV *saved_hh = NULL;
3666 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3667 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3671 TAINT_IF(SvTAINTED(sv));
3672 TAINT_PROPER("eval");
3675 lex_start(sv, NULL, FALSE);
3678 /* switch to eval mode */
3680 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3681 SV * const temp_sv = sv_newmortal();
3682 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3683 (unsigned long)++PL_evalseq,
3684 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3685 tmpbuf = SvPVX(temp_sv);
3686 len = SvCUR(temp_sv);
3689 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3690 SAVECOPFILE_FREE(&PL_compiling);
3691 CopFILE_set(&PL_compiling, tmpbuf+2);
3692 SAVECOPLINE(&PL_compiling);
3693 CopLINE_set(&PL_compiling, 1);
3694 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3695 deleting the eval's FILEGV from the stash before gv_check() runs
3696 (i.e. before run-time proper). To work around the coredump that
3697 ensues, we always turn GvMULTI_on for any globals that were
3698 introduced within evals. See force_ident(). GSAR 96-10-12 */
3699 safestr = savepvn(tmpbuf, len);
3700 SAVEDELETE(PL_defstash, safestr, len);
3702 PL_hints = PL_op->op_targ;
3704 GvHV(PL_hintgv) = saved_hh;
3705 SAVECOMPILEWARNINGS();
3706 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3707 if (PL_compiling.cop_hints_hash) {
3708 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3710 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3711 if (PL_compiling.cop_hints_hash) {
3713 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3714 HINTS_REFCNT_UNLOCK;
3716 /* special case: an eval '' executed within the DB package gets lexically
3717 * placed in the first non-DB CV rather than the current CV - this
3718 * allows the debugger to execute code, find lexicals etc, in the
3719 * scope of the code being debugged. Passing &seq gets find_runcv
3720 * to do the dirty work for us */
3721 runcv = find_runcv(&seq);
3723 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3725 cx->blk_eval.retop = PL_op->op_next;
3727 /* prepare to compile string */
3729 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3730 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3732 ok = doeval(gimme, NULL, runcv, seq);
3733 if (ok ? (was != PL_breakable_sub_gen /* Some subs defined here. */
3734 ? (PERLDB_LINE || PERLDB_SAVESRC)
3735 : PERLDB_SAVESRC_NOSUBS)
3736 : 0 /* PERLDB_SAVESRC_INVALID */
3737 /* Much that I'd like to think that it was this trivial to add this
3738 feature, it's not, due to
3741 in S_doeval() for the failure case. So really we want a more
3742 sophisticated way of (optionally) clearing the source code.
3743 Particularly as the current way is buggy, as a syntactically
3744 invalid eval string can still define a subroutine that is retained,
3745 and the user may wish to breakpoint. */) {
3746 /* Just need to change the string in our writable scratch buffer that
3747 will be used at scope exit to delete this eval's "file" name, to
3748 something safe. The key names are of the form "_<(eval 1)" upwards,
3749 so the 8th char is the first digit, which will not have a leading
3750 zero. So give it a leading zero, and it can't match anything, but
3751 still sits within the pattern space "reserved" for evals. */
3754 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3764 register PERL_CONTEXT *cx;
3766 const U8 save_flags = PL_op -> op_flags;
3771 retop = cx->blk_eval.retop;
3774 if (gimme == G_VOID)
3776 else if (gimme == G_SCALAR) {
3779 if (SvFLAGS(TOPs) & SVs_TEMP)
3782 *MARK = sv_mortalcopy(TOPs);
3786 *MARK = &PL_sv_undef;
3791 /* in case LEAVE wipes old return values */
3792 for (mark = newsp + 1; mark <= SP; mark++) {
3793 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3794 *mark = sv_mortalcopy(*mark);
3795 TAINT_NOT; /* Each item is independent */
3799 PL_curpm = newpm; /* Don't pop $1 et al till now */
3802 assert(CvDEPTH(PL_compcv) == 1);
3804 CvDEPTH(PL_compcv) = 0;
3807 if (optype == OP_REQUIRE &&
3808 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3810 /* Unassume the success we assumed earlier. */
3811 SV * const nsv = cx->blk_eval.old_namesv;
3812 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3813 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3814 /* die_where() did LEAVE, or we won't be here */
3818 if (!(save_flags & OPf_SPECIAL)) {
3826 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3827 close to the related Perl_create_eval_scope. */
3829 Perl_delete_eval_scope(pTHX)
3834 register PERL_CONTEXT *cx;
3841 PERL_UNUSED_VAR(newsp);
3842 PERL_UNUSED_VAR(gimme);
3843 PERL_UNUSED_VAR(optype);
3846 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3847 also needed by Perl_fold_constants. */
3849 Perl_create_eval_scope(pTHX_ U32 flags)
3852 const I32 gimme = GIMME_V;
3857 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3860 PL_in_eval = EVAL_INEVAL;
3861 if (flags & G_KEEPERR)
3862 PL_in_eval |= EVAL_KEEPERR;
3865 if (flags & G_FAKINGEVAL) {
3866 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3874 PERL_CONTEXT * const cx = create_eval_scope(0);
3875 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3876 return DOCATCH(PL_op->op_next);
3885 register PERL_CONTEXT *cx;
3890 PERL_UNUSED_VAR(optype);
3893 if (gimme == G_VOID)
3895 else if (gimme == G_SCALAR) {
3899 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3902 *MARK = sv_mortalcopy(TOPs);
3906 *MARK = &PL_sv_undef;
3911 /* in case LEAVE wipes old return values */
3913 for (mark = newsp + 1; mark <= SP; mark++) {
3914 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3915 *mark = sv_mortalcopy(*mark);
3916 TAINT_NOT; /* Each item is independent */
3920 PL_curpm = newpm; /* Don't pop $1 et al till now */
3930 register PERL_CONTEXT *cx;
3931 const I32 gimme = GIMME_V;
3936 if (PL_op->op_targ == 0) {
3937 SV ** const defsv_p = &GvSV(PL_defgv);
3938 *defsv_p = newSVsv(POPs);
3939 SAVECLEARSV(*defsv_p);
3942 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3944 PUSHBLOCK(cx, CXt_GIVEN, SP);
3953 register PERL_CONTEXT *cx;
3957 PERL_UNUSED_CONTEXT;
3960 assert(CxTYPE(cx) == CXt_GIVEN);
3965 PL_curpm = newpm; /* pop $1 et al */
3972 /* Helper routines used by pp_smartmatch */
3974 S_make_matcher(pTHX_ REGEXP *re)
3977 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3979 PERL_ARGS_ASSERT_MAKE_MATCHER;
3981 PM_SETRE(matcher, ReREFCNT_inc(re));
3983 SAVEFREEOP((OP *) matcher);
3990 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3995 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3997 PL_op = (OP *) matcher;
4002 return (SvTRUEx(POPs));
4006 S_destroy_matcher(pTHX_ PMOP *matcher)
4010 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4011 PERL_UNUSED_ARG(matcher);
4017 /* Do a smart match */
4020 return do_smartmatch(NULL, NULL);
4023 /* This version of do_smartmatch() implements the
4024 * table of smart matches that is found in perlsyn.
4027 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4032 SV *e = TOPs; /* e is for 'expression' */
4033 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4034 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
4035 REGEXP *this_regex, *other_regex;
4037 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4039 # define SM_REF(type) ( \
4040 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4041 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4043 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4044 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4045 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4046 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4047 && NOT_EMPTY_PROTO(This) && (Other = d)))
4049 # define SM_REGEX ( \
4050 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4051 && (this_regex = (REGEXP*) This) \
4054 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4055 && (this_regex = (REGEXP*) This) \
4059 # define SM_OBJECT ( \
4060 (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
4062 (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
4064 # define SM_OTHER_REF(type) \
4065 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4067 # define SM_OTHER_REGEX (SvROK(Other) \
4068 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
4069 && (other_regex = (REGEXP*) SvRV(Other)))
4072 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4073 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4075 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4076 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4078 tryAMAGICbinSET(smart, 0);
4080 SP -= 2; /* Pop the values */
4082 /* Take care only to invoke mg_get() once for each argument.
4083 * Currently we do this by copying the SV if it's magical. */
4086 d = sv_mortalcopy(d);
4093 e = sv_mortalcopy(e);
4096 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4101 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4103 if (This == SvRV(Other))
4114 c = call_sv(This, G_SCALAR);
4118 else if (SvTEMP(TOPs))
4119 SvREFCNT_inc_void(TOPs);
4124 else if (SM_REF(PVHV)) {
4125 if (SM_OTHER_REF(PVHV)) {
4126 /* Check that the key-sets are identical */
4128 HV *other_hv = MUTABLE_HV(SvRV(Other));
4130 bool other_tied = FALSE;
4131 U32 this_key_count = 0,
4132 other_key_count = 0;
4134 /* Tied hashes don't know how many keys they have. */
4135 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4138 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4139 HV * const temp = other_hv;
4140 other_hv = MUTABLE_HV(This);
4141 This = MUTABLE_SV(temp);
4144 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4147 if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
4150 /* The hashes have the same number of keys, so it suffices
4151 to check that one is a subset of the other. */
4152 (void) hv_iterinit(MUTABLE_HV(This));
4153 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4155 char * const key = hv_iterkey(he, &key_len);
4159 if(!hv_exists(other_hv, key, key_len)) {
4160 (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */
4166 (void) hv_iterinit(other_hv);
4167 while ( hv_iternext(other_hv) )
4171 other_key_count = HvUSEDKEYS(other_hv);
4173 if (this_key_count != other_key_count)
4178 else if (SM_OTHER_REF(PVAV)) {
4179 AV * const other_av = MUTABLE_AV(SvRV(Other));
4180 const I32 other_len = av_len(other_av) + 1;
4183 for (i = 0; i < other_len; ++i) {
4184 SV ** const svp = av_fetch(other_av, i, FALSE);
4188 if (svp) { /* ??? When can this not happen? */
4189 key = SvPV(*svp, key_len);
4190 if (hv_exists(MUTABLE_HV(This), key, key_len))
4196 else if (SM_OTHER_REGEX) {
4197 PMOP * const matcher = make_matcher(other_regex);
4200 (void) hv_iterinit(MUTABLE_HV(This));
4201 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4202 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4203 (void) hv_iterinit(MUTABLE_HV(This));
4204 destroy_matcher(matcher);
4208 destroy_matcher(matcher);
4212 if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
4218 else if (SM_REF(PVAV)) {
4219 if (SM_OTHER_REF(PVAV)) {
4220 AV *other_av = MUTABLE_AV(SvRV(Other));
4221 if (av_len(MUTABLE_AV(This)) != av_len(other_av))
4225 const I32 other_len = av_len(other_av);
4227 if (NULL == seen_this) {
4228 seen_this = newHV();
4229 (void) sv_2mortal(MUTABLE_SV(seen_this));
4231 if (NULL == seen_other) {
4232 seen_this = newHV();
4233 (void) sv_2mortal(MUTABLE_SV(seen_other));
4235 for(i = 0; i <= other_len; ++i) {
4236 SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
4237 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4239 if (!this_elem || !other_elem) {
4240 if (this_elem || other_elem)
4243 else if (SM_SEEN_THIS(*this_elem)
4244 || SM_SEEN_OTHER(*other_elem))
4246 if (*this_elem != *other_elem)
4250 (void)hv_store_ent(seen_this,
4251 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4253 (void)hv_store_ent(seen_other,
4254 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4260 (void) do_smartmatch(seen_this, seen_other);
4270 else if (SM_OTHER_REGEX) {
4271 PMOP * const matcher = make_matcher(other_regex);
4272 const I32 this_len = av_len(MUTABLE_AV(This));
4275 for(i = 0; i <= this_len; ++i) {
4276 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4277 if (svp && matcher_matches_sv(matcher, *svp)) {
4278 destroy_matcher(matcher);
4282 destroy_matcher(matcher);
4285 else if (SvIOK(Other) || SvNOK(Other)) {
4288 for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
4289 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4296 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4306 else if (SvPOK(Other)) {
4307 const I32 this_len = av_len(MUTABLE_AV(This));
4310 for(i = 0; i <= this_len; ++i) {
4311 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4326 else if (!SvOK(d) || !SvOK(e)) {
4327 if (!SvOK(d) && !SvOK(e))
4332 else if (SM_REGEX) {
4333 PMOP * const matcher = make_matcher(this_regex);
4336 PUSHs(matcher_matches_sv(matcher, Other)
4339 destroy_matcher(matcher);
4342 else if (SM_REF(PVCV)) {
4344 /* This must be a null-prototyped sub, because we
4345 already checked for the other kind. */
4351 c = call_sv(This, G_SCALAR);
4354 PUSHs(&PL_sv_undef);
4355 else if (SvTEMP(TOPs))
4356 SvREFCNT_inc_void(TOPs);
4358 if (SM_OTHER_REF(PVCV)) {
4359 /* This one has to be null-proto'd too.
4360 Call both of 'em, and compare the results */
4362 c = call_sv(SvRV(Other), G_SCALAR);
4365 PUSHs(&PL_sv_undef);
4366 else if (SvTEMP(TOPs))
4367 SvREFCNT_inc_void(TOPs);
4378 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4379 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4381 if (SvPOK(Other) && !looks_like_number(Other)) {
4382 /* String comparison */
4387 /* Otherwise, numeric comparison */
4390 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4401 /* As a last resort, use string comparison */
4410 register PERL_CONTEXT *cx;
4411 const I32 gimme = GIMME_V;
4413 /* This is essentially an optimization: if the match
4414 fails, we don't want to push a context and then
4415 pop it again right away, so we skip straight
4416 to the op that follows the leavewhen.
4418 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4419 return cLOGOP->op_other->op_next;
4424 PUSHBLOCK(cx, CXt_WHEN, SP);
4433 register PERL_CONTEXT *cx;
4439 assert(CxTYPE(cx) == CXt_WHEN);
4444 PL_curpm = newpm; /* pop $1 et al */
4454 register PERL_CONTEXT *cx;
4457 cxix = dopoptowhen(cxstack_ix);
4459 DIE(aTHX_ "Can't \"continue\" outside a when block");
4460 if (cxix < cxstack_ix)
4463 /* clear off anything above the scope we're re-entering */
4464 inner = PL_scopestack_ix;
4466 if (PL_scopestack_ix < inner)
4467 leave_scope(PL_scopestack[PL_scopestack_ix]);
4468 PL_curcop = cx->blk_oldcop;
4469 return cx->blk_givwhen.leave_op;
4476 register PERL_CONTEXT *cx;
4479 cxix = dopoptogiven(cxstack_ix);
4481 if (PL_op->op_flags & OPf_SPECIAL)
4482 DIE(aTHX_ "Can't use when() outside a topicalizer");
4484 DIE(aTHX_ "Can't \"break\" outside a given block");
4486 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4487 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4489 if (cxix < cxstack_ix)
4492 /* clear off anything above the scope we're re-entering */
4493 inner = PL_scopestack_ix;
4495 if (PL_scopestack_ix < inner)
4496 leave_scope(PL_scopestack[PL_scopestack_ix]);
4497 PL_curcop = cx->blk_oldcop;
4500 return CX_LOOP_NEXTOP_GET(cx);
4502 return cx->blk_givwhen.leave_op;
4506 S_doparseform(pTHX_ SV *sv)
4509 register char *s = SvPV_force(sv, len);
4510 register char * const send = s + len;
4511 register char *base = NULL;
4512 register I32 skipspaces = 0;
4513 bool noblank = FALSE;
4514 bool repeat = FALSE;
4515 bool postspace = FALSE;
4521 bool unchopnum = FALSE;
4522 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4524 PERL_ARGS_ASSERT_DOPARSEFORM;
4527 Perl_croak(aTHX_ "Null picture in formline");
4529 /* estimate the buffer size needed */
4530 for (base = s; s <= send; s++) {
4531 if (*s == '\n' || *s == '@' || *s == '^')
4537 Newx(fops, maxops, U32);
4542 *fpc++ = FF_LINEMARK;
4543 noblank = repeat = FALSE;
4561 case ' ': case '\t':
4568 } /* else FALL THROUGH */
4576 *fpc++ = FF_LITERAL;
4584 *fpc++ = (U16)skipspaces;
4588 *fpc++ = FF_NEWLINE;
4592 arg = fpc - linepc + 1;
4599 *fpc++ = FF_LINEMARK;
4600 noblank = repeat = FALSE;
4609 ischop = s[-1] == '^';
4615 arg = (s - base) - 1;
4617 *fpc++ = FF_LITERAL;
4625 *fpc++ = 2; /* skip the @* or ^* */
4627 *fpc++ = FF_LINESNGL;
4630 *fpc++ = FF_LINEGLOB;
4632 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4633 arg = ischop ? 512 : 0;
4638 const char * const f = ++s;
4641 arg |= 256 + (s - f);
4643 *fpc++ = s - base; /* fieldsize for FETCH */
4644 *fpc++ = FF_DECIMAL;
4646 unchopnum |= ! ischop;
4648 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4649 arg = ischop ? 512 : 0;
4651 s++; /* skip the '0' first */
4655 const char * const f = ++s;
4658 arg |= 256 + (s - f);
4660 *fpc++ = s - base; /* fieldsize for FETCH */
4661 *fpc++ = FF_0DECIMAL;
4663 unchopnum |= ! ischop;
4667 bool ismore = FALSE;
4670 while (*++s == '>') ;
4671 prespace = FF_SPACE;
4673 else if (*s == '|') {
4674 while (*++s == '|') ;
4675 prespace = FF_HALFSPACE;
4680 while (*++s == '<') ;
4683 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4687 *fpc++ = s - base; /* fieldsize for FETCH */
4689 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4692 *fpc++ = (U16)prespace;
4706 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4708 { /* need to jump to the next word */
4710 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4711 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4712 s = SvPVX(sv) + SvCUR(sv) + z;
4714 Copy(fops, s, arg, U32);
4716 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4719 if (unchopnum && repeat)
4720 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4726 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4728 /* Can value be printed in fldsize chars, using %*.*f ? */
4732 int intsize = fldsize - (value < 0 ? 1 : 0);
4739 while (intsize--) pwr *= 10.0;
4740 while (frcsize--) eps /= 10.0;
4743 if (value + eps >= pwr)
4746 if (value - eps <= -pwr)
4753 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4756 SV * const datasv = FILTER_DATA(idx);
4757 const int filter_has_file = IoLINES(datasv);
4758 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4759 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4763 const char *got_p = NULL;
4764 const char *prune_from = NULL;
4765 bool read_from_cache = FALSE;
4768 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4770 assert(maxlen >= 0);
4773 /* I was having segfault trouble under Linux 2.2.5 after a
4774 parse error occured. (Had to hack around it with a test
4775 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4776 not sure where the trouble is yet. XXX */
4778 if (IoFMT_GV(datasv)) {
4779 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4782 const char *cache_p = SvPV(cache, cache_len);
4786 /* Running in block mode and we have some cached data already.
4788 if (cache_len >= umaxlen) {
4789 /* In fact, so much data we don't even need to call
4794 const char *const first_nl =
4795 (const char *)memchr(cache_p, '\n', cache_len);
4797 take = first_nl + 1 - cache_p;
4801 sv_catpvn(buf_sv, cache_p, take);
4802 sv_chop(cache, cache_p + take);
4803 /* Definately not EOF */
4807 sv_catsv(buf_sv, cache);
4809 umaxlen -= cache_len;
4812 read_from_cache = TRUE;
4816 /* Filter API says that the filter appends to the contents of the buffer.
4817 Usually the buffer is "", so the details don't matter. But if it's not,
4818 then clearly what it contains is already filtered by this filter, so we
4819 don't want to pass it in a second time.
4820 I'm going to use a mortal in case the upstream filter croaks. */
4821 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4822 ? sv_newmortal() : buf_sv;
4823 SvUPGRADE(upstream, SVt_PV);
4825 if (filter_has_file) {
4826 status = FILTER_READ(idx+1, upstream, 0);
4829 if (filter_sub && status >= 0) {
4838 DEFSV_set(upstream);
4842 PUSHs(filter_state);
4845 count = call_sv(filter_sub, G_SCALAR);
4860 if(SvOK(upstream)) {
4861 got_p = SvPV(upstream, got_len);
4863 if (got_len > umaxlen) {
4864 prune_from = got_p + umaxlen;
4867 const char *const first_nl =
4868 (const char *)memchr(got_p, '\n', got_len);
4869 if (first_nl && first_nl + 1 < got_p + got_len) {
4870 /* There's a second line here... */
4871 prune_from = first_nl + 1;
4876 /* Oh. Too long. Stuff some in our cache. */
4877 STRLEN cached_len = got_p + got_len - prune_from;
4878 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4881 IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4882 } else if (SvOK(cache)) {
4883 /* Cache should be empty. */
4884 assert(!SvCUR(cache));
4887 sv_setpvn(cache, prune_from, cached_len);
4888 /* If you ask for block mode, you may well split UTF-8 characters.
4889 "If it breaks, you get to keep both parts"
4890 (Your code is broken if you don't put them back together again
4891 before something notices.) */
4892 if (SvUTF8(upstream)) {
4895 SvCUR_set(upstream, got_len - cached_len);
4896 /* Can't yet be EOF */
4901 /* If they are at EOF but buf_sv has something in it, then they may never
4902 have touched the SV upstream, so it may be undefined. If we naively
4903 concatenate it then we get a warning about use of uninitialised value.
4905 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4906 sv_catsv(buf_sv, upstream);
4910 IoLINES(datasv) = 0;
4911 SvREFCNT_dec(IoFMT_GV(datasv));
4913 SvREFCNT_dec(filter_state);
4914 IoTOP_GV(datasv) = NULL;
4917 SvREFCNT_dec(filter_sub);
4918 IoBOTTOM_GV(datasv) = NULL;
4920 filter_del(S_run_user_filter);
4922 if (status == 0 && read_from_cache) {
4923 /* If we read some data from the cache (and by getting here it implies
4924 that we emptied the cache) then we aren't yet at EOF, and mustn't
4925 report that to our caller. */
4931 /* perhaps someone can come up with a better name for
4932 this? it is not really "absolute", per se ... */
4934 S_path_is_absolute(const char *name)
4936 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4938 if (PERL_FILE_IS_ABSOLUTE(name)
4939 #ifdef MACOS_TRADITIONAL
4942 || (*name == '.' && (name[1] == '/' ||
4943 (name[1] == '.' && name[2] == '/')))
4955 * c-indentation-style: bsd
4957 * indent-tabs-mode: t
4960 * ex: set ts=8 sts=4 sw=4 noet: