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_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
515 t = SvEND(PL_formtarget);
535 if (ckWARN(WARN_SYNTAX))
536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
543 const char *s = item = SvPV_const(sv, len);
546 itemsize = sv_len_utf8(sv);
547 if (itemsize != (I32)len) {
549 if (itemsize > fieldsize) {
550 itemsize = fieldsize;
551 itembytes = itemsize;
552 sv_pos_u2b(sv, &itembytes, 0);
556 send = chophere = s + itembytes;
566 sv_pos_b2u(sv, &itemsize);
570 item_is_utf8 = FALSE;
571 if (itemsize > fieldsize)
572 itemsize = fieldsize;
573 send = chophere = s + itemsize;
587 const char *s = item = SvPV_const(sv, len);
590 itemsize = sv_len_utf8(sv);
591 if (itemsize != (I32)len) {
593 if (itemsize <= fieldsize) {
594 const char *send = chophere = s + itemsize;
607 itemsize = fieldsize;
608 itembytes = itemsize;
609 sv_pos_u2b(sv, &itembytes, 0);
610 send = chophere = s + itembytes;
611 while (s < send || (s == send && isSPACE(*s))) {
621 if (strchr(PL_chopset, *s))
626 itemsize = chophere - item;
627 sv_pos_b2u(sv, &itemsize);
633 item_is_utf8 = FALSE;
634 if (itemsize <= fieldsize) {
635 const char *const send = chophere = s + itemsize;
648 itemsize = fieldsize;
649 send = chophere = s + itemsize;
650 while (s < send || (s == send && isSPACE(*s))) {
660 if (strchr(PL_chopset, *s))
665 itemsize = chophere - item;
671 arg = fieldsize - itemsize;
680 arg = fieldsize - itemsize;
691 const char *s = item;
695 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
697 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
699 t = SvEND(PL_formtarget);
703 if (UTF8_IS_CONTINUED(*s)) {
704 STRLEN skip = UTF8SKIP(s);
721 if ( !((*t++ = *s++) & ~31) )
727 if (targ_is_utf8 && !item_is_utf8) {
728 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
730 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
731 for (; t < SvEND(PL_formtarget); t++) {
744 const int ch = *t++ = *s++;
747 if ( !((*t++ = *s++) & ~31) )
756 const char *s = chophere;
770 const bool oneline = fpc[-1] == FF_LINESNGL;
771 const char *s = item = SvPV_const(sv, len);
772 item_is_utf8 = DO_UTF8(sv);
775 STRLEN to_copy = itemsize;
776 const char *const send = s + len;
777 const U8 *source = (const U8 *) s;
781 chophere = s + itemsize;
785 to_copy = s - SvPVX_const(sv) - 1;
797 if (targ_is_utf8 && !item_is_utf8) {
798 source = tmp = bytes_to_utf8(source, &to_copy);
799 SvCUR_set(PL_formtarget,
800 t - SvPVX_const(PL_formtarget));
802 if (item_is_utf8 && !targ_is_utf8) {
803 /* Upgrade targ to UTF8, and then we reduce it to
804 a problem we have a simple solution for. */
805 SvCUR_set(PL_formtarget,
806 t - SvPVX_const(PL_formtarget));
808 /* Don't need get magic. */
809 sv_utf8_upgrade_nomg(PL_formtarget);
811 SvCUR_set(PL_formtarget,
812 t - SvPVX_const(PL_formtarget));
815 /* Easy. They agree. */
816 assert (item_is_utf8 == targ_is_utf8);
818 SvGROW(PL_formtarget,
819 SvCUR(PL_formtarget) + to_copy + fudge + 1);
820 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
822 Copy(source, t, to_copy, char);
824 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
826 if (SvGMAGICAL(sv)) {
827 /* Mustn't call sv_pos_b2u() as it does a second
828 mg_get(). Is this a bug? Do we need a _flags()
830 itemsize = utf8_length(source, source + itemsize);
832 sv_pos_b2u(sv, &itemsize);
844 #if defined(USE_LONG_DOUBLE)
847 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
851 "%#0*.*f" : "%0*.*f");
856 #if defined(USE_LONG_DOUBLE)
858 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
861 ((arg & 256) ? "%#*.*f" : "%*.*f");
864 /* If the field is marked with ^ and the value is undefined,
866 if ((arg & 512) && !SvOK(sv)) {
874 /* overflow evidence */
875 if (num_overflow(value, fieldsize, arg)) {
881 /* Formats aren't yet marked for locales, so assume "yes". */
883 STORE_NUMERIC_STANDARD_SET_LOCAL();
884 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
885 RESTORE_NUMERIC_STANDARD();
892 while (t-- > linemark && *t == ' ') ;
900 if (arg) { /* repeat until fields exhausted? */
902 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
903 lines += FmLINES(PL_formtarget);
906 if (strnEQ(linemark, linemark - arg, arg))
907 DIE(aTHX_ "Runaway format");
910 SvUTF8_on(PL_formtarget);
911 FmLINES(PL_formtarget) = lines;
913 RETURNOP(cLISTOP->op_first);
924 const char *s = chophere;
925 const char *send = item + len;
927 while (isSPACE(*s) && (s < send))
932 arg = fieldsize - itemsize;
939 if (strnEQ(s1," ",3)) {
940 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
951 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
953 SvUTF8_on(PL_formtarget);
954 FmLINES(PL_formtarget) += lines;
966 if (PL_stack_base + *PL_markstack_ptr == SP) {
968 if (GIMME_V == G_SCALAR)
970 RETURNOP(PL_op->op_next->op_next);
972 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
973 pp_pushmark(); /* push dst */
974 pp_pushmark(); /* push src */
975 ENTER; /* enter outer scope */
978 if (PL_op->op_private & OPpGREP_LEX)
979 SAVESPTR(PAD_SVl(PL_op->op_targ));
982 ENTER; /* enter inner scope */
985 src = PL_stack_base[*PL_markstack_ptr];
987 if (PL_op->op_private & OPpGREP_LEX)
988 PAD_SVl(PL_op->op_targ) = src;
993 if (PL_op->op_type == OP_MAPSTART)
994 pp_pushmark(); /* push top */
995 return ((LOGOP*)PL_op->op_next)->op_other;
1001 const I32 gimme = GIMME_V;
1002 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1008 /* first, move source pointer to the next item in the source list */
1009 ++PL_markstack_ptr[-1];
1011 /* if there are new items, push them into the destination list */
1012 if (items && gimme != G_VOID) {
1013 /* might need to make room back there first */
1014 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1015 /* XXX this implementation is very pessimal because the stack
1016 * is repeatedly extended for every set of items. Is possible
1017 * to do this without any stack extension or copying at all
1018 * by maintaining a separate list over which the map iterates
1019 * (like foreach does). --gsar */
1021 /* everything in the stack after the destination list moves
1022 * towards the end the stack by the amount of room needed */
1023 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1025 /* items to shift up (accounting for the moved source pointer) */
1026 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1028 /* This optimization is by Ben Tilly and it does
1029 * things differently from what Sarathy (gsar)
1030 * is describing. The downside of this optimization is
1031 * that leaves "holes" (uninitialized and hopefully unused areas)
1032 * to the Perl stack, but on the other hand this
1033 * shouldn't be a problem. If Sarathy's idea gets
1034 * implemented, this optimization should become
1035 * irrelevant. --jhi */
1037 shift = count; /* Avoid shifting too often --Ben Tilly */
1041 dst = (SP += shift);
1042 PL_markstack_ptr[-1] += shift;
1043 *PL_markstack_ptr += shift;
1047 /* copy the new items down to the destination list */
1048 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1049 if (gimme == G_ARRAY) {
1051 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1054 /* scalar context: we don't care about which values map returns
1055 * (we use undef here). And so we certainly don't want to do mortal
1056 * copies of meaningless values. */
1057 while (items-- > 0) {
1059 *dst-- = &PL_sv_undef;
1063 LEAVE; /* exit inner scope */
1066 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1068 (void)POPMARK; /* pop top */
1069 LEAVE; /* exit outer scope */
1070 (void)POPMARK; /* pop src */
1071 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1072 (void)POPMARK; /* pop dst */
1073 SP = PL_stack_base + POPMARK; /* pop original mark */
1074 if (gimme == G_SCALAR) {
1075 if (PL_op->op_private & OPpGREP_LEX) {
1076 SV* sv = sv_newmortal();
1077 sv_setiv(sv, items);
1085 else if (gimme == G_ARRAY)
1092 ENTER; /* enter inner scope */
1095 /* set $_ to the new source item */
1096 src = PL_stack_base[PL_markstack_ptr[-1]];
1098 if (PL_op->op_private & OPpGREP_LEX)
1099 PAD_SVl(PL_op->op_targ) = src;
1103 RETURNOP(cLOGOP->op_other);
1112 if (GIMME == G_ARRAY)
1114 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115 return cLOGOP->op_other;
1125 if (GIMME == G_ARRAY) {
1126 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1130 SV * const targ = PAD_SV(PL_op->op_targ);
1133 if (PL_op->op_private & OPpFLIP_LINENUM) {
1134 if (GvIO(PL_last_in_gv)) {
1135 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1138 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1140 flip = SvIV(sv) == SvIV(GvSV(gv));
1146 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1147 if (PL_op->op_flags & OPf_SPECIAL) {
1155 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1158 sv_setpvs(TARG, "");
1164 /* This code tries to decide if "$left .. $right" should use the
1165 magical string increment, or if the range is numeric (we make
1166 an exception for .."0" [#18165]). AMS 20021031. */
1168 #define RANGE_IS_NUMERIC(left,right) ( \
1169 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1170 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1171 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1172 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1173 && (!SvOK(right) || looks_like_number(right))))
1179 if (GIMME == G_ARRAY) {
1185 if (RANGE_IS_NUMERIC(left,right)) {
1188 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1189 (SvOK(right) && SvNV(right) > IV_MAX))
1190 DIE(aTHX_ "Range iterator outside integer range");
1201 SV * const sv = sv_2mortal(newSViv(i++));
1206 SV * const final = sv_mortalcopy(right);
1208 const char * const tmps = SvPV_const(final, len);
1210 SV *sv = sv_mortalcopy(left);
1211 SvPV_force_nolen(sv);
1212 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1214 if (strEQ(SvPVX_const(sv),tmps))
1216 sv = sv_2mortal(newSVsv(sv));
1223 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1227 if (PL_op->op_private & OPpFLIP_LINENUM) {
1228 if (GvIO(PL_last_in_gv)) {
1229 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1232 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1233 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1241 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1242 sv_catpvs(targ, "E0");
1252 static const char * const context_name[] = {
1255 NULL, /* CXt_BLOCK never actually needs "block" */
1257 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1258 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1259 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1260 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1268 S_dopoptolabel(pTHX_ const char *label)
1273 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1275 for (i = cxstack_ix; i >= 0; i--) {
1276 register const PERL_CONTEXT * const cx = &cxstack[i];
1277 switch (CxTYPE(cx)) {
1285 if (ckWARN(WARN_EXITING))
1286 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1287 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1288 if (CxTYPE(cx) == CXt_NULL)
1291 case CXt_LOOP_LAZYIV:
1292 case CXt_LOOP_LAZYSV:
1294 case CXt_LOOP_PLAIN:
1295 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1296 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1297 (long)i, CxLABEL(cx)));
1300 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1310 Perl_dowantarray(pTHX)
1313 const I32 gimme = block_gimme();
1314 return (gimme == G_VOID) ? G_SCALAR : gimme;
1318 Perl_block_gimme(pTHX)
1321 const I32 cxix = dopoptosub(cxstack_ix);
1325 switch (cxstack[cxix].blk_gimme) {
1333 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1340 Perl_is_lvalue_sub(pTHX)
1343 const I32 cxix = dopoptosub(cxstack_ix);
1344 assert(cxix >= 0); /* We should only be called from inside subs */
1346 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1347 return CxLVAL(cxstack + cxix);
1353 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1358 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1360 for (i = startingblock; i >= 0; i--) {
1361 register const PERL_CONTEXT * const cx = &cxstk[i];
1362 switch (CxTYPE(cx)) {
1368 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1376 S_dopoptoeval(pTHX_ I32 startingblock)
1380 for (i = startingblock; i >= 0; i--) {
1381 register const PERL_CONTEXT *cx = &cxstack[i];
1382 switch (CxTYPE(cx)) {
1386 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1394 S_dopoptoloop(pTHX_ I32 startingblock)
1398 for (i = startingblock; i >= 0; i--) {
1399 register const PERL_CONTEXT * const cx = &cxstack[i];
1400 switch (CxTYPE(cx)) {
1406 if (ckWARN(WARN_EXITING))
1407 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1408 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1409 if ((CxTYPE(cx)) == CXt_NULL)
1412 case CXt_LOOP_LAZYIV:
1413 case CXt_LOOP_LAZYSV:
1415 case CXt_LOOP_PLAIN:
1416 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1424 S_dopoptogiven(pTHX_ I32 startingblock)
1428 for (i = startingblock; i >= 0; i--) {
1429 register const PERL_CONTEXT *cx = &cxstack[i];
1430 switch (CxTYPE(cx)) {
1434 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1436 case CXt_LOOP_PLAIN:
1437 assert(!CxFOREACHDEF(cx));
1439 case CXt_LOOP_LAZYIV:
1440 case CXt_LOOP_LAZYSV:
1442 if (CxFOREACHDEF(cx)) {
1443 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1452 S_dopoptowhen(pTHX_ I32 startingblock)
1456 for (i = startingblock; i >= 0; i--) {
1457 register const PERL_CONTEXT *cx = &cxstack[i];
1458 switch (CxTYPE(cx)) {
1462 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1470 Perl_dounwind(pTHX_ I32 cxix)
1475 while (cxstack_ix > cxix) {
1477 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1478 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1479 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1480 /* Note: we don't need to restore the base context info till the end. */
1481 switch (CxTYPE(cx)) {
1484 continue; /* not break */
1492 case CXt_LOOP_LAZYIV:
1493 case CXt_LOOP_LAZYSV:
1495 case CXt_LOOP_PLAIN:
1506 PERL_UNUSED_VAR(optype);
1510 Perl_qerror(pTHX_ SV *err)
1514 PERL_ARGS_ASSERT_QERROR;
1517 sv_catsv(ERRSV, err);
1519 sv_catsv(PL_errors, err);
1521 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1523 ++PL_parser->error_count;
1527 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1536 if (PL_in_eval & EVAL_KEEPERR) {
1537 static const char prefix[] = "\t(in cleanup) ";
1538 SV * const err = ERRSV;
1539 const char *e = NULL;
1542 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1544 e = SvPV_const(err, len);
1546 if (*e != *message || strNE(e,message))
1550 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1551 sv_catpvn(err, prefix, sizeof(prefix)-1);
1552 sv_catpvn(err, message, msglen);
1553 if (ckWARN(WARN_MISC)) {
1554 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1555 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1556 SvPVX_const(err)+start);
1561 sv_setpvn(ERRSV, message, msglen);
1565 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1566 && PL_curstackinfo->si_prev)
1574 register PERL_CONTEXT *cx;
1577 if (cxix < cxstack_ix)
1580 POPBLOCK(cx,PL_curpm);
1581 if (CxTYPE(cx) != CXt_EVAL) {
1583 message = SvPVx_const(ERRSV, msglen);
1584 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1585 PerlIO_write(Perl_error_log, message, msglen);
1590 if (gimme == G_SCALAR)
1591 *++newsp = &PL_sv_undef;
1592 PL_stack_sp = newsp;
1596 /* LEAVE could clobber PL_curcop (see save_re_context())
1597 * XXX it might be better to find a way to avoid messing with
1598 * PL_curcop in save_re_context() instead, but this is a more
1599 * minimal fix --GSAR */
1600 PL_curcop = cx->blk_oldcop;
1602 if (optype == OP_REQUIRE) {
1603 const char* const msg = SvPVx_nolen_const(ERRSV);
1604 SV * const nsv = cx->blk_eval.old_namesv;
1605 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1607 DIE(aTHX_ "%sCompilation failed in require",
1608 *msg ? msg : "Unknown error\n");
1610 assert(CxTYPE(cx) == CXt_EVAL);
1611 return cx->blk_eval.retop;
1615 message = SvPVx_const(ERRSV, msglen);
1617 write_to_stderr(message, msglen);
1625 dVAR; dSP; dPOPTOPssrl;
1626 if (SvTRUE(left) != SvTRUE(right))
1636 register I32 cxix = dopoptosub(cxstack_ix);
1637 register const PERL_CONTEXT *cx;
1638 register const PERL_CONTEXT *ccstack = cxstack;
1639 const PERL_SI *top_si = PL_curstackinfo;
1641 const char *stashname;
1648 /* we may be in a higher stacklevel, so dig down deeper */
1649 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1650 top_si = top_si->si_prev;
1651 ccstack = top_si->si_cxstack;
1652 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1655 if (GIMME != G_ARRAY) {
1661 /* caller() should not report the automatic calls to &DB::sub */
1662 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1663 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1667 cxix = dopoptosub_at(ccstack, cxix - 1);
1670 cx = &ccstack[cxix];
1671 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1672 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1673 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1674 field below is defined for any cx. */
1675 /* caller() should not report the automatic calls to &DB::sub */
1676 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1677 cx = &ccstack[dbcxix];
1680 stashname = CopSTASHPV(cx->blk_oldcop);
1681 if (GIMME != G_ARRAY) {
1684 PUSHs(&PL_sv_undef);
1687 sv_setpv(TARG, stashname);
1696 PUSHs(&PL_sv_undef);
1698 mPUSHs(newSVpv(stashname, 0));
1699 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1700 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1703 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1704 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1705 /* So is ccstack[dbcxix]. */
1707 SV * const sv = newSV(0);
1708 gv_efullname3(sv, cvgv, NULL);
1710 PUSHs(boolSV(CxHASARGS(cx)));
1713 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1714 PUSHs(boolSV(CxHASARGS(cx)));
1718 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1721 gimme = (I32)cx->blk_gimme;
1722 if (gimme == G_VOID)
1723 PUSHs(&PL_sv_undef);
1725 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1726 if (CxTYPE(cx) == CXt_EVAL) {
1728 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1729 PUSHs(cx->blk_eval.cur_text);
1733 else if (cx->blk_eval.old_namesv) {
1734 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1737 /* eval BLOCK (try blocks have old_namesv == 0) */
1739 PUSHs(&PL_sv_undef);
1740 PUSHs(&PL_sv_undef);
1744 PUSHs(&PL_sv_undef);
1745 PUSHs(&PL_sv_undef);
1747 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1748 && CopSTASH_eq(PL_curcop, PL_debstash))
1750 AV * const ary = cx->blk_sub.argarray;
1751 const int off = AvARRAY(ary) - AvALLOC(ary);
1754 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1755 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1757 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1760 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1761 av_extend(PL_dbargs, AvFILLp(ary) + off);
1762 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1763 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1765 /* XXX only hints propagated via op_private are currently
1766 * visible (others are not easily accessible, since they
1767 * use the global PL_hints) */
1768 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1771 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1773 if (old_warnings == pWARN_NONE ||
1774 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1775 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1776 else if (old_warnings == pWARN_ALL ||
1777 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1778 /* Get the bit mask for $warnings::Bits{all}, because
1779 * it could have been extended by warnings::register */
1781 HV * const bits = get_hv("warnings::Bits", FALSE);
1782 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1783 mask = newSVsv(*bits_all);
1786 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1790 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1794 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1795 sv_2mortal(newRV_noinc(
1796 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1797 cx->blk_oldcop->cop_hints_hash))))
1806 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1807 sv_reset(tmps, CopSTASH(PL_curcop));
1812 /* like pp_nextstate, but used instead when the debugger is active */
1817 PL_curcop = (COP*)PL_op;
1818 TAINT_NOT; /* Each statement is presumed innocent */
1819 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1822 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1823 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1826 register PERL_CONTEXT *cx;
1827 const I32 gimme = G_ARRAY;
1829 GV * const gv = PL_DBgv;
1830 register CV * const cv = GvCV(gv);
1833 DIE(aTHX_ "No DB::DB routine defined");
1835 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1836 /* don't do recursive DB::DB call */
1851 (void)(*CvXSUB(cv))(aTHX_ cv);
1858 PUSHBLOCK(cx, CXt_SUB, SP);
1860 cx->blk_sub.retop = PL_op->op_next;
1863 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1864 RETURNOP(CvSTART(cv));
1874 register PERL_CONTEXT *cx;
1875 const I32 gimme = GIMME_V;
1877 U8 cxtype = CXt_LOOP_FOR;
1885 if (PL_op->op_targ) {
1886 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1887 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1888 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1889 SVs_PADSTALE, SVs_PADSTALE);
1891 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1892 #ifndef USE_ITHREADS
1893 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1899 GV * const gv = MUTABLE_GV(POPs);
1900 svp = &GvSV(gv); /* symbol table variable */
1901 SAVEGENERICSV(*svp);
1904 iterdata = (PAD*)gv;
1908 if (PL_op->op_private & OPpITER_DEF)
1909 cxtype |= CXp_FOR_DEF;
1913 PUSHBLOCK(cx, cxtype, SP);
1915 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1917 PUSHLOOP_FOR(cx, svp, MARK, 0);
1919 if (PL_op->op_flags & OPf_STACKED) {
1920 SV *maybe_ary = POPs;
1921 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1923 SV * const right = maybe_ary;
1926 if (RANGE_IS_NUMERIC(sv,right)) {
1927 cx->cx_type &= ~CXTYPEMASK;
1928 cx->cx_type |= CXt_LOOP_LAZYIV;
1929 /* Make sure that no-one re-orders cop.h and breaks our
1931 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1932 #ifdef NV_PRESERVES_UV
1933 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1934 (SvNV(sv) > (NV)IV_MAX)))
1936 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1937 (SvNV(right) < (NV)IV_MIN))))
1939 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1942 ((SvUV(sv) > (UV)IV_MAX) ||
1943 (SvNV(sv) > (NV)UV_MAX)))))
1945 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1947 ((SvNV(right) > 0) &&
1948 ((SvUV(right) > (UV)IV_MAX) ||
1949 (SvNV(right) > (NV)UV_MAX))))))
1951 DIE(aTHX_ "Range iterator outside integer range");
1952 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1953 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1955 /* for correct -Dstv display */
1956 cx->blk_oldsp = sp - PL_stack_base;
1960 cx->cx_type &= ~CXTYPEMASK;
1961 cx->cx_type |= CXt_LOOP_LAZYSV;
1962 /* Make sure that no-one re-orders cop.h and breaks our
1964 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1965 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1966 cx->blk_loop.state_u.lazysv.end = right;
1967 SvREFCNT_inc(right);
1968 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1969 /* This will do the upgrade to SVt_PV, and warn if the value
1970 is uninitialised. */
1971 (void) SvPV_nolen_const(right);
1972 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1973 to replace !SvOK() with a pointer to "". */
1975 SvREFCNT_dec(right);
1976 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1980 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1981 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1982 SvREFCNT_inc(maybe_ary);
1983 cx->blk_loop.state_u.ary.ix =
1984 (PL_op->op_private & OPpITER_REVERSED) ?
1985 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1989 else { /* iterating over items on the stack */
1990 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1991 if (PL_op->op_private & OPpITER_REVERSED) {
1992 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1995 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2005 register PERL_CONTEXT *cx;
2006 const I32 gimme = GIMME_V;
2012 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2013 PUSHLOOP_PLAIN(cx, SP);
2021 register PERL_CONTEXT *cx;
2028 assert(CxTYPE_is_LOOP(cx));
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2033 if (gimme == G_VOID)
2035 else if (gimme == G_SCALAR) {
2037 *++newsp = sv_mortalcopy(*SP);
2039 *++newsp = &PL_sv_undef;
2043 *++newsp = sv_mortalcopy(*++mark);
2044 TAINT_NOT; /* Each item is independent */
2050 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2051 PL_curpm = newpm; /* ... and pop $1 et al */
2062 register PERL_CONTEXT *cx;
2063 bool popsub2 = FALSE;
2064 bool clear_errsv = FALSE;
2072 const I32 cxix = dopoptosub(cxstack_ix);
2075 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2076 * sort block, which is a CXt_NULL
2079 PL_stack_base[1] = *PL_stack_sp;
2080 PL_stack_sp = PL_stack_base + 1;
2084 DIE(aTHX_ "Can't return outside a subroutine");
2086 if (cxix < cxstack_ix)
2089 if (CxMULTICALL(&cxstack[cxix])) {
2090 gimme = cxstack[cxix].blk_gimme;
2091 if (gimme == G_VOID)
2092 PL_stack_sp = PL_stack_base;
2093 else if (gimme == G_SCALAR) {
2094 PL_stack_base[1] = *PL_stack_sp;
2095 PL_stack_sp = PL_stack_base + 1;
2101 switch (CxTYPE(cx)) {
2104 retop = cx->blk_sub.retop;
2105 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2108 if (!(PL_in_eval & EVAL_KEEPERR))
2111 retop = cx->blk_eval.retop;
2115 if (optype == OP_REQUIRE &&
2116 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2118 /* Unassume the success we assumed earlier. */
2119 SV * const nsv = cx->blk_eval.old_namesv;
2120 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2121 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2126 retop = cx->blk_sub.retop;
2129 DIE(aTHX_ "panic: return");
2133 if (gimme == G_SCALAR) {
2136 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2138 *++newsp = SvREFCNT_inc(*SP);
2143 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2145 *++newsp = sv_mortalcopy(sv);
2150 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2153 *++newsp = sv_mortalcopy(*SP);
2156 *++newsp = &PL_sv_undef;
2158 else if (gimme == G_ARRAY) {
2159 while (++MARK <= SP) {
2160 *++newsp = (popsub2 && SvTEMP(*MARK))
2161 ? *MARK : sv_mortalcopy(*MARK);
2162 TAINT_NOT; /* Each item is independent */
2165 PL_stack_sp = newsp;
2168 /* Stack values are safe: */
2171 POPSUB(cx,sv); /* release CV and @_ ... */
2175 PL_curpm = newpm; /* ... and pop $1 et al */
2188 register PERL_CONTEXT *cx;
2199 if (PL_op->op_flags & OPf_SPECIAL) {
2200 cxix = dopoptoloop(cxstack_ix);
2202 DIE(aTHX_ "Can't \"last\" outside a loop block");
2205 cxix = dopoptolabel(cPVOP->op_pv);
2207 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2209 if (cxix < cxstack_ix)
2213 cxstack_ix++; /* temporarily protect top context */
2215 switch (CxTYPE(cx)) {
2216 case CXt_LOOP_LAZYIV:
2217 case CXt_LOOP_LAZYSV:
2219 case CXt_LOOP_PLAIN:
2221 newsp = PL_stack_base + cx->blk_loop.resetsp;
2222 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2226 nextop = cx->blk_sub.retop;
2230 nextop = cx->blk_eval.retop;
2234 nextop = cx->blk_sub.retop;
2237 DIE(aTHX_ "panic: last");
2241 if (gimme == G_SCALAR) {
2243 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2244 ? *SP : sv_mortalcopy(*SP);
2246 *++newsp = &PL_sv_undef;
2248 else if (gimme == G_ARRAY) {
2249 while (++MARK <= SP) {
2250 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2251 ? *MARK : sv_mortalcopy(*MARK);
2252 TAINT_NOT; /* Each item is independent */
2260 /* Stack values are safe: */
2262 case CXt_LOOP_LAZYIV:
2263 case CXt_LOOP_PLAIN:
2264 case CXt_LOOP_LAZYSV:
2266 POPLOOP(cx); /* release loop vars ... */
2270 POPSUB(cx,sv); /* release CV and @_ ... */
2273 PL_curpm = newpm; /* ... and pop $1 et al */
2276 PERL_UNUSED_VAR(optype);
2277 PERL_UNUSED_VAR(gimme);
2285 register PERL_CONTEXT *cx;
2288 if (PL_op->op_flags & OPf_SPECIAL) {
2289 cxix = dopoptoloop(cxstack_ix);
2291 DIE(aTHX_ "Can't \"next\" outside a loop block");
2294 cxix = dopoptolabel(cPVOP->op_pv);
2296 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2298 if (cxix < cxstack_ix)
2301 /* clear off anything above the scope we're re-entering, but
2302 * save the rest until after a possible continue block */
2303 inner = PL_scopestack_ix;
2305 if (PL_scopestack_ix < inner)
2306 leave_scope(PL_scopestack[PL_scopestack_ix]);
2307 PL_curcop = cx->blk_oldcop;
2308 return CX_LOOP_NEXTOP_GET(cx);
2315 register PERL_CONTEXT *cx;
2319 if (PL_op->op_flags & OPf_SPECIAL) {
2320 cxix = dopoptoloop(cxstack_ix);
2322 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2325 cxix = dopoptolabel(cPVOP->op_pv);
2327 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2329 if (cxix < cxstack_ix)
2332 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2333 if (redo_op->op_type == OP_ENTER) {
2334 /* pop one less context to avoid $x being freed in while (my $x..) */
2336 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2337 redo_op = redo_op->op_next;
2341 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2342 LEAVE_SCOPE(oldsave);
2344 PL_curcop = cx->blk_oldcop;
2349 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2353 static const char too_deep[] = "Target of goto is too deeply nested";
2355 PERL_ARGS_ASSERT_DOFINDLABEL;
2358 Perl_croak(aTHX_ too_deep);
2359 if (o->op_type == OP_LEAVE ||
2360 o->op_type == OP_SCOPE ||
2361 o->op_type == OP_LEAVELOOP ||
2362 o->op_type == OP_LEAVESUB ||
2363 o->op_type == OP_LEAVETRY)
2365 *ops++ = cUNOPo->op_first;
2367 Perl_croak(aTHX_ too_deep);
2370 if (o->op_flags & OPf_KIDS) {
2372 /* First try all the kids at this level, since that's likeliest. */
2373 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2374 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2375 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2378 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2379 if (kid == PL_lastgotoprobe)
2381 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2384 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2385 ops[-1]->op_type == OP_DBSTATE)
2390 if ((o = dofindlabel(kid, label, ops, oplimit)))
2403 register PERL_CONTEXT *cx;
2404 #define GOTO_DEPTH 64
2405 OP *enterops[GOTO_DEPTH];
2406 const char *label = NULL;
2407 const bool do_dump = (PL_op->op_type == OP_DUMP);
2408 static const char must_have_label[] = "goto must have label";
2410 if (PL_op->op_flags & OPf_STACKED) {
2411 SV * const sv = POPs;
2413 /* This egregious kludge implements goto &subroutine */
2414 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2416 register PERL_CONTEXT *cx;
2417 CV *cv = MUTABLE_CV(SvRV(sv));
2424 if (!CvROOT(cv) && !CvXSUB(cv)) {
2425 const GV * const gv = CvGV(cv);
2429 /* autoloaded stub? */
2430 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2432 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2433 GvNAMELEN(gv), FALSE);
2434 if (autogv && (cv = GvCV(autogv)))
2436 tmpstr = sv_newmortal();
2437 gv_efullname3(tmpstr, gv, NULL);
2438 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2440 DIE(aTHX_ "Goto undefined subroutine");
2443 /* First do some returnish stuff. */
2444 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2446 cxix = dopoptosub(cxstack_ix);
2448 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2449 if (cxix < cxstack_ix)
2453 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2454 if (CxTYPE(cx) == CXt_EVAL) {
2456 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2458 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2460 else if (CxMULTICALL(cx))
2461 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2462 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2463 /* put @_ back onto stack */
2464 AV* av = cx->blk_sub.argarray;
2466 items = AvFILLp(av) + 1;
2467 EXTEND(SP, items+1); /* @_ could have been extended. */
2468 Copy(AvARRAY(av), SP + 1, items, SV*);
2469 SvREFCNT_dec(GvAV(PL_defgv));
2470 GvAV(PL_defgv) = cx->blk_sub.savearray;
2472 /* abandon @_ if it got reified */
2477 av_extend(av, items-1);
2479 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2482 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2483 AV* const av = GvAV(PL_defgv);
2484 items = AvFILLp(av) + 1;
2485 EXTEND(SP, items+1); /* @_ could have been extended. */
2486 Copy(AvARRAY(av), SP + 1, items, SV*);
2490 if (CxTYPE(cx) == CXt_SUB &&
2491 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2492 SvREFCNT_dec(cx->blk_sub.cv);
2493 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2494 LEAVE_SCOPE(oldsave);
2496 /* Now do some callish stuff. */
2498 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2500 OP* const retop = cx->blk_sub.retop;
2505 for (index=0; index<items; index++)
2506 sv_2mortal(SP[-index]);
2509 /* XS subs don't have a CxSUB, so pop it */
2510 POPBLOCK(cx, PL_curpm);
2511 /* Push a mark for the start of arglist */
2514 (void)(*CvXSUB(cv))(aTHX_ cv);
2519 AV* const padlist = CvPADLIST(cv);
2520 if (CxTYPE(cx) == CXt_EVAL) {
2521 PL_in_eval = CxOLD_IN_EVAL(cx);
2522 PL_eval_root = cx->blk_eval.old_eval_root;
2523 cx->cx_type = CXt_SUB;
2525 cx->blk_sub.cv = cv;
2526 cx->blk_sub.olddepth = CvDEPTH(cv);
2529 if (CvDEPTH(cv) < 2)
2530 SvREFCNT_inc_simple_void_NN(cv);
2532 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2533 sub_crush_depth(cv);
2534 pad_push(padlist, CvDEPTH(cv));
2537 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2540 AV *const av = MUTABLE_AV(PAD_SVl(0));
2542 cx->blk_sub.savearray = GvAV(PL_defgv);
2543 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2544 CX_CURPAD_SAVE(cx->blk_sub);
2545 cx->blk_sub.argarray = av;
2547 if (items >= AvMAX(av) + 1) {
2548 SV **ary = AvALLOC(av);
2549 if (AvARRAY(av) != ary) {
2550 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2553 if (items >= AvMAX(av) + 1) {
2554 AvMAX(av) = items - 1;
2555 Renew(ary,items+1,SV*);
2561 Copy(mark,AvARRAY(av),items,SV*);
2562 AvFILLp(av) = items - 1;
2563 assert(!AvREAL(av));
2565 /* transfer 'ownership' of refcnts to new @_ */
2575 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2576 Perl_get_db_sub(aTHX_ NULL, cv);
2578 CV * const gotocv = get_cv("DB::goto", FALSE);
2580 PUSHMARK( PL_stack_sp );
2581 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2586 RETURNOP(CvSTART(cv));
2590 label = SvPV_nolen_const(sv);
2591 if (!(do_dump || *label))
2592 DIE(aTHX_ must_have_label);
2595 else if (PL_op->op_flags & OPf_SPECIAL) {
2597 DIE(aTHX_ must_have_label);
2600 label = cPVOP->op_pv;
2602 if (label && *label) {
2603 OP *gotoprobe = NULL;
2604 bool leaving_eval = FALSE;
2605 bool in_block = FALSE;
2606 PERL_CONTEXT *last_eval_cx = NULL;
2610 PL_lastgotoprobe = NULL;
2612 for (ix = cxstack_ix; ix >= 0; ix--) {
2614 switch (CxTYPE(cx)) {
2616 leaving_eval = TRUE;
2617 if (!CxTRYBLOCK(cx)) {
2618 gotoprobe = (last_eval_cx ?
2619 last_eval_cx->blk_eval.old_eval_root :
2624 /* else fall through */
2625 case CXt_LOOP_LAZYIV:
2626 case CXt_LOOP_LAZYSV:
2628 case CXt_LOOP_PLAIN:
2629 gotoprobe = cx->blk_oldcop->op_sibling;
2635 gotoprobe = cx->blk_oldcop->op_sibling;
2638 gotoprobe = PL_main_root;
2641 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2642 gotoprobe = CvROOT(cx->blk_sub.cv);
2648 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2651 DIE(aTHX_ "panic: goto");
2652 gotoprobe = PL_main_root;
2656 retop = dofindlabel(gotoprobe, label,
2657 enterops, enterops + GOTO_DEPTH);
2661 PL_lastgotoprobe = gotoprobe;
2664 DIE(aTHX_ "Can't find label %s", label);
2666 /* if we're leaving an eval, check before we pop any frames
2667 that we're not going to punt, otherwise the error
2670 if (leaving_eval && *enterops && enterops[1]) {
2672 for (i = 1; enterops[i]; i++)
2673 if (enterops[i]->op_type == OP_ENTERITER)
2674 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2677 /* pop unwanted frames */
2679 if (ix < cxstack_ix) {
2686 oldsave = PL_scopestack[PL_scopestack_ix];
2687 LEAVE_SCOPE(oldsave);
2690 /* push wanted frames */
2692 if (*enterops && enterops[1]) {
2693 OP * const oldop = PL_op;
2694 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2695 for (; enterops[ix]; ix++) {
2696 PL_op = enterops[ix];
2697 /* Eventually we may want to stack the needed arguments
2698 * for each op. For now, we punt on the hard ones. */
2699 if (PL_op->op_type == OP_ENTERITER)
2700 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2701 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2709 if (!retop) retop = PL_main_start;
2711 PL_restartop = retop;
2712 PL_do_undump = TRUE;
2716 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2717 PL_do_undump = FALSE;
2734 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2736 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2739 PL_exit_flags |= PERL_EXIT_EXPECTED;
2741 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2742 if (anum || !(PL_minus_c && PL_madskills))
2747 PUSHs(&PL_sv_undef);
2754 S_save_lines(pTHX_ AV *array, SV *sv)
2756 const char *s = SvPVX_const(sv);
2757 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2760 PERL_ARGS_ASSERT_SAVE_LINES;
2762 while (s && s < send) {
2764 SV * const tmpstr = newSV_type(SVt_PVMG);
2766 t = (const char *)memchr(s, '\n', send - s);
2772 sv_setpvn(tmpstr, s, t - s);
2773 av_store(array, line++, tmpstr);
2779 S_docatch(pTHX_ OP *o)
2783 OP * const oldop = PL_op;
2787 assert(CATCH_GET == TRUE);
2794 assert(cxstack_ix >= 0);
2795 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2796 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2801 /* die caught by an inner eval - continue inner loop */
2803 /* NB XXX we rely on the old popped CxEVAL still being at the top
2804 * of the stack; the way die_where() currently works, this
2805 * assumption is valid. In theory The cur_top_env value should be
2806 * returned in another global, the way retop (aka PL_restartop)
2808 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2811 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2813 PL_op = PL_restartop;
2830 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2831 /* sv Text to convert to OP tree. */
2832 /* startop op_free() this to undo. */
2833 /* code Short string id of the caller. */
2835 /* FIXME - how much of this code is common with pp_entereval? */
2836 dVAR; dSP; /* Make POPBLOCK work. */
2842 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2843 char *tmpbuf = tbuf;
2846 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2849 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2852 lex_start(sv, NULL, FALSE);
2854 /* switch to eval mode */
2856 if (IN_PERL_COMPILETIME) {
2857 SAVECOPSTASH_FREE(&PL_compiling);
2858 CopSTASH_set(&PL_compiling, PL_curstash);
2860 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2861 SV * const sv = sv_newmortal();
2862 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2863 code, (unsigned long)++PL_evalseq,
2864 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2869 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2870 (unsigned long)++PL_evalseq);
2871 SAVECOPFILE_FREE(&PL_compiling);
2872 CopFILE_set(&PL_compiling, tmpbuf+2);
2873 SAVECOPLINE(&PL_compiling);
2874 CopLINE_set(&PL_compiling, 1);
2875 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2876 deleting the eval's FILEGV from the stash before gv_check() runs
2877 (i.e. before run-time proper). To work around the coredump that
2878 ensues, we always turn GvMULTI_on for any globals that were
2879 introduced within evals. See force_ident(). GSAR 96-10-12 */
2880 safestr = savepvn(tmpbuf, len);
2881 SAVEDELETE(PL_defstash, safestr, len);
2883 #ifdef OP_IN_REGISTER
2889 /* we get here either during compilation, or via pp_regcomp at runtime */
2890 runtime = IN_PERL_RUNTIME;
2892 runcv = find_runcv(NULL);
2895 PL_op->op_type = OP_ENTEREVAL;
2896 PL_op->op_flags = 0; /* Avoid uninit warning. */
2897 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2901 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2903 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2904 POPBLOCK(cx,PL_curpm);
2907 (*startop)->op_type = OP_NULL;
2908 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2910 /* XXX DAPM do this properly one year */
2911 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2913 if (IN_PERL_COMPILETIME)
2914 CopHINTS_set(&PL_compiling, PL_hints);
2915 #ifdef OP_IN_REGISTER
2918 PERL_UNUSED_VAR(newsp);
2919 PERL_UNUSED_VAR(optype);
2921 return PL_eval_start;
2926 =for apidoc find_runcv
2928 Locate the CV corresponding to the currently executing sub or eval.
2929 If db_seqp is non_null, skip CVs that are in the DB package and populate
2930 *db_seqp with the cop sequence number at the point that the DB:: code was
2931 entered. (allows debuggers to eval in the scope of the breakpoint rather
2932 than in the scope of the debugger itself).
2938 Perl_find_runcv(pTHX_ U32 *db_seqp)
2944 *db_seqp = PL_curcop->cop_seq;
2945 for (si = PL_curstackinfo; si; si = si->si_prev) {
2947 for (ix = si->si_cxix; ix >= 0; ix--) {
2948 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2949 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2950 CV * const cv = cx->blk_sub.cv;
2951 /* skip DB:: code */
2952 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2953 *db_seqp = cx->blk_oldcop->cop_seq;
2958 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2966 /* Compile a require/do, an eval '', or a /(?{...})/.
2967 * In the last case, startop is non-null, and contains the address of
2968 * a pointer that should be set to the just-compiled code.
2969 * outside is the lexically enclosing CV (if any) that invoked us.
2970 * Returns a bool indicating whether the compile was successful; if so,
2971 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2972 * pushes undef (also croaks if startop != NULL).
2976 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2979 OP * const saveop = PL_op;
2981 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2982 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2987 SAVESPTR(PL_compcv);
2988 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2989 CvEVAL_on(PL_compcv);
2990 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2991 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2993 CvOUTSIDE_SEQ(PL_compcv) = seq;
2994 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2996 /* set up a scratch pad */
2998 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2999 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3003 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3005 /* make sure we compile in the right package */
3007 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3008 SAVESPTR(PL_curstash);
3009 PL_curstash = CopSTASH(PL_curcop);
3011 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3012 SAVESPTR(PL_beginav);
3013 PL_beginav = newAV();
3014 SAVEFREESV(PL_beginav);
3015 SAVESPTR(PL_unitcheckav);
3016 PL_unitcheckav = newAV();
3017 SAVEFREESV(PL_unitcheckav);
3020 SAVEBOOL(PL_madskills);
3024 /* try to compile it */
3026 PL_eval_root = NULL;
3027 PL_curcop = &PL_compiling;
3028 CopARYBASE_set(PL_curcop, 0);
3029 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3030 PL_in_eval |= EVAL_KEEPERR;
3033 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3034 SV **newsp; /* Used by POPBLOCK. */
3035 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3036 I32 optype = 0; /* Might be reset by POPEVAL. */
3041 op_free(PL_eval_root);
3042 PL_eval_root = NULL;
3044 SP = PL_stack_base + POPMARK; /* pop original mark */
3046 POPBLOCK(cx,PL_curpm);
3050 LEAVE; /* pp_entereval knows about this LEAVE. */
3052 msg = SvPVx_nolen_const(ERRSV);
3053 if (optype == OP_REQUIRE) {
3054 const SV * const nsv = cx->blk_eval.old_namesv;
3055 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3057 Perl_croak(aTHX_ "%sCompilation failed in require",
3058 *msg ? msg : "Unknown error\n");
3061 POPBLOCK(cx,PL_curpm);
3063 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3064 (*msg ? msg : "Unknown error\n"));
3068 sv_setpvs(ERRSV, "Compilation error");
3071 PERL_UNUSED_VAR(newsp);
3072 PUSHs(&PL_sv_undef);
3076 CopLINE_set(&PL_compiling, 0);
3078 *startop = PL_eval_root;
3080 SAVEFREEOP(PL_eval_root);
3082 /* Set the context for this new optree.
3083 * If the last op is an OP_REQUIRE, force scalar context.
3084 * Otherwise, propagate the context from the eval(). */
3085 if (PL_eval_root->op_type == OP_LEAVEEVAL
3086 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3087 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3089 scalar(PL_eval_root);
3090 else if ((gimme & G_WANT) == G_VOID)
3091 scalarvoid(PL_eval_root);
3092 else if ((gimme & G_WANT) == G_ARRAY)
3095 scalar(PL_eval_root);
3097 DEBUG_x(dump_eval());
3099 /* Register with debugger: */
3100 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3101 CV * const cv = get_cv("DB::postponed", FALSE);
3105 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3107 call_sv(MUTABLE_SV(cv), G_DISCARD);
3112 call_list(PL_scopestack_ix, PL_unitcheckav);
3114 /* compiled okay, so do it */
3116 CvDEPTH(PL_compcv) = 1;
3117 SP = PL_stack_base + POPMARK; /* pop original mark */
3118 PL_op = saveop; /* The caller may need it. */
3119 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3126 S_check_type_and_open(pTHX_ const char *name)
3129 const int st_rc = PerlLIO_stat(name, &st);
3131 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3133 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3137 return PerlIO_open(name, PERL_SCRIPT_MODE);
3140 #ifndef PERL_DISABLE_PMC
3142 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3146 PERL_ARGS_ASSERT_DOOPEN_PM;
3148 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3149 SV *const pmcsv = newSV(namelen + 2);
3150 char *const pmc = SvPVX(pmcsv);
3153 memcpy(pmc, name, namelen);
3155 pmc[namelen + 1] = '\0';
3157 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3158 fp = check_type_and_open(name);
3161 fp = check_type_and_open(pmc);
3163 SvREFCNT_dec(pmcsv);
3166 fp = check_type_and_open(name);
3171 # define doopen_pm(name, namelen) check_type_and_open(name)
3172 #endif /* !PERL_DISABLE_PMC */
3177 register PERL_CONTEXT *cx;
3184 int vms_unixname = 0;
3186 const char *tryname = NULL;
3188 const I32 gimme = GIMME_V;
3189 int filter_has_file = 0;
3190 PerlIO *tryrsfp = NULL;
3191 SV *filter_cache = NULL;
3192 SV *filter_state = NULL;
3193 SV *filter_sub = NULL;
3199 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3200 sv = new_version(sv);
3201 if (!sv_derived_from(PL_patchlevel, "version"))
3202 upg_version(PL_patchlevel, TRUE);
3203 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3204 if ( vcmp(sv,PL_patchlevel) <= 0 )
3205 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3206 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3209 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3212 SV * const req = SvRV(sv);
3213 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3215 /* get the left hand term */
3216 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3218 first = SvIV(*av_fetch(lav,0,0));
3219 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3220 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3221 || av_len(lav) > 1 /* FP with > 3 digits */
3222 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3224 DIE(aTHX_ "Perl %"SVf" required--this is only "
3225 "%"SVf", stopped", SVfARG(vnormal(req)),
3226 SVfARG(vnormal(PL_patchlevel)));
3228 else { /* probably 'use 5.10' or 'use 5.8' */
3229 SV * hintsv = newSV(0);
3233 second = SvIV(*av_fetch(lav,1,0));
3235 second /= second >= 600 ? 100 : 10;
3236 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3237 (int)first, (int)second,0);
3238 upg_version(hintsv, TRUE);
3240 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3241 "--this is only %"SVf", stopped",
3242 SVfARG(vnormal(req)),
3243 SVfARG(vnormal(hintsv)),
3244 SVfARG(vnormal(PL_patchlevel)));
3249 /* We do this only with use, not require. */
3251 /* If we request a version >= 5.9.5, load feature.pm with the
3252 * feature bundle that corresponds to the required version. */
3253 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3254 SV *const importsv = vnormal(sv);
3255 *SvPVX_mutable(importsv) = ':';
3257 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3263 name = SvPV_const(sv, len);
3264 if (!(name && len > 0 && *name))
3265 DIE(aTHX_ "Null filename used");
3266 TAINT_PROPER("require");
3270 /* The key in the %ENV hash is in the syntax of file passed as the argument
3271 * usually this is in UNIX format, but sometimes in VMS format, which
3272 * can result in a module being pulled in more than once.
3273 * To prevent this, the key must be stored in UNIX format if the VMS
3274 * name can be translated to UNIX.
3276 if ((unixname = tounixspec(name, NULL)) != NULL) {
3277 unixlen = strlen(unixname);
3283 /* if not VMS or VMS name can not be translated to UNIX, pass it
3286 unixname = (char *) name;
3289 if (PL_op->op_type == OP_REQUIRE) {
3290 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3291 unixname, unixlen, 0);
3293 if (*svp != &PL_sv_undef)
3296 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3297 "Compilation failed in require", unixname);
3301 /* prepare to compile file */
3303 if (path_is_absolute(name)) {
3305 tryrsfp = doopen_pm(name, len);
3307 #ifdef MACOS_TRADITIONAL
3311 MacPerl_CanonDir(name, newname, 1);
3312 if (path_is_absolute(newname)) {
3314 tryrsfp = doopen_pm(newname, strlen(newname));
3319 AV * const ar = GvAVn(PL_incgv);
3325 namesv = newSV_type(SVt_PV);
3326 for (i = 0; i <= AvFILL(ar); i++) {
3327 SV * const dirsv = *av_fetch(ar, i, TRUE);
3329 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3336 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3337 && !sv_isobject(loader))
3339 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3342 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3343 PTR2UV(SvRV(dirsv)), name);
3344 tryname = SvPVX_const(namesv);
3355 if (sv_isobject(loader))
3356 count = call_method("INC", G_ARRAY);
3358 count = call_sv(loader, G_ARRAY);
3361 /* Adjust file name if the hook has set an %INC entry */
3362 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3364 tryname = SvPVX_const(*svp);
3373 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3374 && !isGV_with_GP(SvRV(arg))) {
3375 filter_cache = SvRV(arg);
3376 SvREFCNT_inc_simple_void_NN(filter_cache);
3383 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3387 if (isGV_with_GP(arg)) {
3388 IO * const io = GvIO((const GV *)arg);
3393 tryrsfp = IoIFP(io);
3394 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3395 PerlIO_close(IoOFP(io));
3406 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3408 SvREFCNT_inc_simple_void_NN(filter_sub);
3411 filter_state = SP[i];
3412 SvREFCNT_inc_simple_void(filter_state);
3416 if (!tryrsfp && (filter_cache || filter_sub)) {
3417 tryrsfp = PerlIO_open(BIT_BUCKET,
3432 filter_has_file = 0;
3434 SvREFCNT_dec(filter_cache);
3435 filter_cache = NULL;
3438 SvREFCNT_dec(filter_state);
3439 filter_state = NULL;
3442 SvREFCNT_dec(filter_sub);
3447 if (!path_is_absolute(name)
3448 #ifdef MACOS_TRADITIONAL
3449 /* We consider paths of the form :a:b ambiguous and interpret them first
3450 as global then as local
3452 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3459 dir = SvPV_const(dirsv, dirlen);
3465 #ifdef MACOS_TRADITIONAL
3469 MacPerl_CanonDir(name, buf2, 1);
3470 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3474 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3476 sv_setpv(namesv, unixdir);
3477 sv_catpv(namesv, unixname);
3479 # ifdef __SYMBIAN32__
3480 if (PL_origfilename[0] &&
3481 PL_origfilename[1] == ':' &&
3482 !(dir[0] && dir[1] == ':'))
3483 Perl_sv_setpvf(aTHX_ namesv,
3488 Perl_sv_setpvf(aTHX_ namesv,
3492 /* The equivalent of
3493 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3494 but without the need to parse the format string, or
3495 call strlen on either pointer, and with the correct
3496 allocation up front. */
3498 char *tmp = SvGROW(namesv, dirlen + len + 2);
3500 memcpy(tmp, dir, dirlen);
3503 /* name came from an SV, so it will have a '\0' at the
3504 end that we can copy as part of this memcpy(). */
3505 memcpy(tmp, name, len + 1);
3507 SvCUR_set(namesv, dirlen + len + 1);
3509 /* Don't even actually have to turn SvPOK_on() as we
3510 access it directly with SvPVX() below. */
3515 TAINT_PROPER("require");
3516 tryname = SvPVX_const(namesv);
3517 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3519 if (tryname[0] == '.' && tryname[1] == '/')
3523 else if (errno == EMFILE)
3524 /* no point in trying other paths if out of handles */
3531 SAVECOPFILE_FREE(&PL_compiling);
3532 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3533 SvREFCNT_dec(namesv);
3535 if (PL_op->op_type == OP_REQUIRE) {
3536 const char *msgstr = name;
3537 if(errno == EMFILE) {
3539 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3541 msgstr = SvPV_nolen_const(msg);
3543 if (namesv) { /* did we lookup @INC? */
3544 AV * const ar = GvAVn(PL_incgv);
3546 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3547 "%s in @INC%s%s (@INC contains:",
3549 (instr(msgstr, ".h ")
3550 ? " (change .h to .ph maybe?)" : ""),
3551 (instr(msgstr, ".ph ")
3552 ? " (did you run h2ph?)" : "")
3555 for (i = 0; i <= AvFILL(ar); i++) {
3556 sv_catpvs(msg, " ");
3557 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3559 sv_catpvs(msg, ")");
3560 msgstr = SvPV_nolen_const(msg);
3563 DIE(aTHX_ "Can't locate %s", msgstr);
3569 SETERRNO(0, SS_NORMAL);
3571 /* Assume success here to prevent recursive requirement. */
3572 /* name is never assigned to again, so len is still strlen(name) */
3573 /* Check whether a hook in @INC has already filled %INC */
3575 (void)hv_store(GvHVn(PL_incgv),
3576 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3578 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3580 (void)hv_store(GvHVn(PL_incgv),
3581 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3586 lex_start(NULL, tryrsfp, TRUE);
3590 if (PL_compiling.cop_hints_hash) {
3591 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3592 PL_compiling.cop_hints_hash = NULL;
3595 SAVECOMPILEWARNINGS();
3596 if (PL_dowarn & G_WARN_ALL_ON)
3597 PL_compiling.cop_warnings = pWARN_ALL ;
3598 else if (PL_dowarn & G_WARN_ALL_OFF)
3599 PL_compiling.cop_warnings = pWARN_NONE ;
3601 PL_compiling.cop_warnings = pWARN_STD ;
3603 if (filter_sub || filter_cache) {
3604 SV * const datasv = filter_add(S_run_user_filter, NULL);
3605 IoLINES(datasv) = filter_has_file;
3606 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3607 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3608 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3611 /* switch to eval mode */
3612 PUSHBLOCK(cx, CXt_EVAL, SP);
3614 cx->blk_eval.retop = PL_op->op_next;
3616 SAVECOPLINE(&PL_compiling);
3617 CopLINE_set(&PL_compiling, 0);
3621 /* Store and reset encoding. */
3622 encoding = PL_encoding;
3625 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3626 op = DOCATCH(PL_eval_start);
3628 op = PL_op->op_next;
3630 /* Restore encoding. */
3631 PL_encoding = encoding;
3636 /* This is a op added to hold the hints hash for
3637 pp_entereval. The hash can be modified by the code
3638 being eval'ed, so we return a copy instead. */
3644 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3652 register PERL_CONTEXT *cx;
3654 const I32 gimme = GIMME_V;
3655 const U32 was = PL_breakable_sub_gen;
3656 char tbuf[TYPE_DIGITS(long) + 12];
3657 char *tmpbuf = tbuf;
3661 HV *saved_hh = NULL;
3663 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3664 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3668 TAINT_IF(SvTAINTED(sv));
3669 TAINT_PROPER("eval");
3672 lex_start(sv, NULL, FALSE);
3675 /* switch to eval mode */
3677 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3678 SV * const temp_sv = sv_newmortal();
3679 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3680 (unsigned long)++PL_evalseq,
3681 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3682 tmpbuf = SvPVX(temp_sv);
3683 len = SvCUR(temp_sv);
3686 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3687 SAVECOPFILE_FREE(&PL_compiling);
3688 CopFILE_set(&PL_compiling, tmpbuf+2);
3689 SAVECOPLINE(&PL_compiling);
3690 CopLINE_set(&PL_compiling, 1);
3691 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3692 deleting the eval's FILEGV from the stash before gv_check() runs
3693 (i.e. before run-time proper). To work around the coredump that
3694 ensues, we always turn GvMULTI_on for any globals that were
3695 introduced within evals. See force_ident(). GSAR 96-10-12 */
3697 PL_hints = PL_op->op_targ;
3699 GvHV(PL_hintgv) = saved_hh;
3700 SAVECOMPILEWARNINGS();
3701 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3702 if (PL_compiling.cop_hints_hash) {
3703 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3705 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3706 if (PL_compiling.cop_hints_hash) {
3708 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3709 HINTS_REFCNT_UNLOCK;
3711 /* special case: an eval '' executed within the DB package gets lexically
3712 * placed in the first non-DB CV rather than the current CV - this
3713 * allows the debugger to execute code, find lexicals etc, in the
3714 * scope of the code being debugged. Passing &seq gets find_runcv
3715 * to do the dirty work for us */
3716 runcv = find_runcv(&seq);
3718 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3720 cx->blk_eval.retop = PL_op->op_next;
3722 /* prepare to compile string */
3724 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3725 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3728 if (doeval(gimme, NULL, runcv, seq)) {
3729 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3730 ? (PERLDB_LINE || PERLDB_SAVESRC)
3731 : PERLDB_SAVESRC_NOSUBS) {
3732 /* Retain the filegv we created. */
3734 char *const safestr = savepvn(tmpbuf, len);
3735 SAVEDELETE(PL_defstash, safestr, len);
3737 return DOCATCH(PL_eval_start);
3739 /* We have already left the scope set up earler thanks to the LEAVE
3741 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3742 ? (PERLDB_LINE || PERLDB_SAVESRC)
3743 : PERLDB_SAVESRC_INVALID) {
3744 /* Retain the filegv we created. */
3746 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3748 return PL_op->op_next;
3759 register PERL_CONTEXT *cx;
3761 const U8 save_flags = PL_op -> op_flags;
3766 retop = cx->blk_eval.retop;
3769 if (gimme == G_VOID)
3771 else if (gimme == G_SCALAR) {
3774 if (SvFLAGS(TOPs) & SVs_TEMP)
3777 *MARK = sv_mortalcopy(TOPs);
3781 *MARK = &PL_sv_undef;
3786 /* in case LEAVE wipes old return values */
3787 for (mark = newsp + 1; mark <= SP; mark++) {
3788 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3789 *mark = sv_mortalcopy(*mark);
3790 TAINT_NOT; /* Each item is independent */
3794 PL_curpm = newpm; /* Don't pop $1 et al till now */
3797 assert(CvDEPTH(PL_compcv) == 1);
3799 CvDEPTH(PL_compcv) = 0;
3802 if (optype == OP_REQUIRE &&
3803 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3805 /* Unassume the success we assumed earlier. */
3806 SV * const nsv = cx->blk_eval.old_namesv;
3807 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3808 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3809 /* die_where() did LEAVE, or we won't be here */
3813 if (!(save_flags & OPf_SPECIAL)) {
3821 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3822 close to the related Perl_create_eval_scope. */
3824 Perl_delete_eval_scope(pTHX)
3829 register PERL_CONTEXT *cx;
3836 PERL_UNUSED_VAR(newsp);
3837 PERL_UNUSED_VAR(gimme);
3838 PERL_UNUSED_VAR(optype);
3841 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3842 also needed by Perl_fold_constants. */
3844 Perl_create_eval_scope(pTHX_ U32 flags)
3847 const I32 gimme = GIMME_V;
3852 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3855 PL_in_eval = EVAL_INEVAL;
3856 if (flags & G_KEEPERR)
3857 PL_in_eval |= EVAL_KEEPERR;
3860 if (flags & G_FAKINGEVAL) {
3861 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3869 PERL_CONTEXT * const cx = create_eval_scope(0);
3870 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3871 return DOCATCH(PL_op->op_next);
3880 register PERL_CONTEXT *cx;
3885 PERL_UNUSED_VAR(optype);
3888 if (gimme == G_VOID)
3890 else if (gimme == G_SCALAR) {
3894 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3897 *MARK = sv_mortalcopy(TOPs);
3901 *MARK = &PL_sv_undef;
3906 /* in case LEAVE wipes old return values */
3908 for (mark = newsp + 1; mark <= SP; mark++) {
3909 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3910 *mark = sv_mortalcopy(*mark);
3911 TAINT_NOT; /* Each item is independent */
3915 PL_curpm = newpm; /* Don't pop $1 et al till now */
3925 register PERL_CONTEXT *cx;
3926 const I32 gimme = GIMME_V;
3931 if (PL_op->op_targ == 0) {
3932 SV ** const defsv_p = &GvSV(PL_defgv);
3933 *defsv_p = newSVsv(POPs);
3934 SAVECLEARSV(*defsv_p);
3937 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3939 PUSHBLOCK(cx, CXt_GIVEN, SP);
3948 register PERL_CONTEXT *cx;
3952 PERL_UNUSED_CONTEXT;
3955 assert(CxTYPE(cx) == CXt_GIVEN);
3960 PL_curpm = newpm; /* pop $1 et al */
3967 /* Helper routines used by pp_smartmatch */
3969 S_make_matcher(pTHX_ REGEXP *re)
3972 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3974 PERL_ARGS_ASSERT_MAKE_MATCHER;
3976 PM_SETRE(matcher, ReREFCNT_inc(re));
3978 SAVEFREEOP((OP *) matcher);
3985 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3990 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3992 PL_op = (OP *) matcher;
3997 return (SvTRUEx(POPs));
4001 S_destroy_matcher(pTHX_ PMOP *matcher)
4005 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4006 PERL_UNUSED_ARG(matcher);
4012 /* Do a smart match */
4015 return do_smartmatch(NULL, NULL);
4018 /* This version of do_smartmatch() implements the
4019 * table of smart matches that is found in perlsyn.
4022 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4027 SV *e = TOPs; /* e is for 'expression' */
4028 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4029 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
4030 REGEXP *this_regex, *other_regex;
4032 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4034 # define SM_REF(type) ( \
4035 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4036 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4038 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4039 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4040 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4041 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4042 && NOT_EMPTY_PROTO(This) && (Other = d)))
4044 # define SM_REGEX ( \
4045 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4046 && (this_regex = (REGEXP*) This) \
4049 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4050 && (this_regex = (REGEXP*) This) \
4054 # define SM_OBJECT ( \
4055 (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
4057 (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
4059 # define SM_OTHER_REF(type) \
4060 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4062 # define SM_OTHER_REGEX (SvROK(Other) \
4063 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
4064 && (other_regex = (REGEXP*) SvRV(Other)))
4067 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4068 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4070 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4071 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4073 tryAMAGICbinSET(smart, 0);
4075 SP -= 2; /* Pop the values */
4077 /* Take care only to invoke mg_get() once for each argument.
4078 * Currently we do this by copying the SV if it's magical. */
4081 d = sv_mortalcopy(d);
4088 e = sv_mortalcopy(e);
4091 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4096 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4098 if (This == SvRV(Other))
4109 c = call_sv(This, G_SCALAR);
4113 else if (SvTEMP(TOPs))
4114 SvREFCNT_inc_void(TOPs);
4119 else if (SM_REF(PVHV)) {
4120 if (SM_OTHER_REF(PVHV)) {
4121 /* Check that the key-sets are identical */
4123 HV *other_hv = MUTABLE_HV(SvRV(Other));
4125 bool other_tied = FALSE;
4126 U32 this_key_count = 0,
4127 other_key_count = 0;
4129 /* Tied hashes don't know how many keys they have. */
4130 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4133 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4134 HV * const temp = other_hv;
4135 other_hv = MUTABLE_HV(This);
4136 This = MUTABLE_SV(temp);
4139 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4142 if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
4145 /* The hashes have the same number of keys, so it suffices
4146 to check that one is a subset of the other. */
4147 (void) hv_iterinit(MUTABLE_HV(This));
4148 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4150 char * const key = hv_iterkey(he, &key_len);
4154 if(!hv_exists(other_hv, key, key_len)) {
4155 (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */
4161 (void) hv_iterinit(other_hv);
4162 while ( hv_iternext(other_hv) )
4166 other_key_count = HvUSEDKEYS(other_hv);
4168 if (this_key_count != other_key_count)
4173 else if (SM_OTHER_REF(PVAV)) {
4174 AV * const other_av = MUTABLE_AV(SvRV(Other));
4175 const I32 other_len = av_len(other_av) + 1;
4178 for (i = 0; i < other_len; ++i) {
4179 SV ** const svp = av_fetch(other_av, i, FALSE);
4183 if (svp) { /* ??? When can this not happen? */
4184 key = SvPV(*svp, key_len);
4185 if (hv_exists(MUTABLE_HV(This), key, key_len))
4191 else if (SM_OTHER_REGEX) {
4192 PMOP * const matcher = make_matcher(other_regex);
4195 (void) hv_iterinit(MUTABLE_HV(This));
4196 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4197 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4198 (void) hv_iterinit(MUTABLE_HV(This));
4199 destroy_matcher(matcher);
4203 destroy_matcher(matcher);
4207 if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
4213 else if (SM_REF(PVAV)) {
4214 if (SM_OTHER_REF(PVAV)) {
4215 AV *other_av = MUTABLE_AV(SvRV(Other));
4216 if (av_len(MUTABLE_AV(This)) != av_len(other_av))
4220 const I32 other_len = av_len(other_av);
4222 if (NULL == seen_this) {
4223 seen_this = newHV();
4224 (void) sv_2mortal(MUTABLE_SV(seen_this));
4226 if (NULL == seen_other) {
4227 seen_this = newHV();
4228 (void) sv_2mortal(MUTABLE_SV(seen_other));
4230 for(i = 0; i <= other_len; ++i) {
4231 SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
4232 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4234 if (!this_elem || !other_elem) {
4235 if (this_elem || other_elem)
4238 else if (SM_SEEN_THIS(*this_elem)
4239 || SM_SEEN_OTHER(*other_elem))
4241 if (*this_elem != *other_elem)
4245 (void)hv_store_ent(seen_this,
4246 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4248 (void)hv_store_ent(seen_other,
4249 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4255 (void) do_smartmatch(seen_this, seen_other);
4265 else if (SM_OTHER_REGEX) {
4266 PMOP * const matcher = make_matcher(other_regex);
4267 const I32 this_len = av_len(MUTABLE_AV(This));
4270 for(i = 0; i <= this_len; ++i) {
4271 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4272 if (svp && matcher_matches_sv(matcher, *svp)) {
4273 destroy_matcher(matcher);
4277 destroy_matcher(matcher);
4280 else if (SvIOK(Other) || SvNOK(Other)) {
4283 for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
4284 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4291 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4301 else if (SvPOK(Other)) {
4302 const I32 this_len = av_len(MUTABLE_AV(This));
4305 for(i = 0; i <= this_len; ++i) {
4306 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4321 else if (!SvOK(d) || !SvOK(e)) {
4322 if (!SvOK(d) && !SvOK(e))
4327 else if (SM_REGEX) {
4328 PMOP * const matcher = make_matcher(this_regex);
4331 PUSHs(matcher_matches_sv(matcher, Other)
4334 destroy_matcher(matcher);
4337 else if (SM_REF(PVCV)) {
4339 /* This must be a null-prototyped sub, because we
4340 already checked for the other kind. */
4346 c = call_sv(This, G_SCALAR);
4349 PUSHs(&PL_sv_undef);
4350 else if (SvTEMP(TOPs))
4351 SvREFCNT_inc_void(TOPs);
4353 if (SM_OTHER_REF(PVCV)) {
4354 /* This one has to be null-proto'd too.
4355 Call both of 'em, and compare the results */
4357 c = call_sv(SvRV(Other), G_SCALAR);
4360 PUSHs(&PL_sv_undef);
4361 else if (SvTEMP(TOPs))
4362 SvREFCNT_inc_void(TOPs);
4373 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4374 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4376 if (SvPOK(Other) && !looks_like_number(Other)) {
4377 /* String comparison */
4382 /* Otherwise, numeric comparison */
4385 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4396 /* As a last resort, use string comparison */
4405 register PERL_CONTEXT *cx;
4406 const I32 gimme = GIMME_V;
4408 /* This is essentially an optimization: if the match
4409 fails, we don't want to push a context and then
4410 pop it again right away, so we skip straight
4411 to the op that follows the leavewhen.
4413 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4414 return cLOGOP->op_other->op_next;
4419 PUSHBLOCK(cx, CXt_WHEN, SP);
4428 register PERL_CONTEXT *cx;
4434 assert(CxTYPE(cx) == CXt_WHEN);
4439 PL_curpm = newpm; /* pop $1 et al */
4449 register PERL_CONTEXT *cx;
4452 cxix = dopoptowhen(cxstack_ix);
4454 DIE(aTHX_ "Can't \"continue\" outside a when block");
4455 if (cxix < cxstack_ix)
4458 /* clear off anything above the scope we're re-entering */
4459 inner = PL_scopestack_ix;
4461 if (PL_scopestack_ix < inner)
4462 leave_scope(PL_scopestack[PL_scopestack_ix]);
4463 PL_curcop = cx->blk_oldcop;
4464 return cx->blk_givwhen.leave_op;
4471 register PERL_CONTEXT *cx;
4474 cxix = dopoptogiven(cxstack_ix);
4476 if (PL_op->op_flags & OPf_SPECIAL)
4477 DIE(aTHX_ "Can't use when() outside a topicalizer");
4479 DIE(aTHX_ "Can't \"break\" outside a given block");
4481 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4482 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4484 if (cxix < cxstack_ix)
4487 /* clear off anything above the scope we're re-entering */
4488 inner = PL_scopestack_ix;
4490 if (PL_scopestack_ix < inner)
4491 leave_scope(PL_scopestack[PL_scopestack_ix]);
4492 PL_curcop = cx->blk_oldcop;
4495 return CX_LOOP_NEXTOP_GET(cx);
4497 return cx->blk_givwhen.leave_op;
4501 S_doparseform(pTHX_ SV *sv)
4504 register char *s = SvPV_force(sv, len);
4505 register char * const send = s + len;
4506 register char *base = NULL;
4507 register I32 skipspaces = 0;
4508 bool noblank = FALSE;
4509 bool repeat = FALSE;
4510 bool postspace = FALSE;
4516 bool unchopnum = FALSE;
4517 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4519 PERL_ARGS_ASSERT_DOPARSEFORM;
4522 Perl_croak(aTHX_ "Null picture in formline");
4524 /* estimate the buffer size needed */
4525 for (base = s; s <= send; s++) {
4526 if (*s == '\n' || *s == '@' || *s == '^')
4532 Newx(fops, maxops, U32);
4537 *fpc++ = FF_LINEMARK;
4538 noblank = repeat = FALSE;
4556 case ' ': case '\t':
4563 } /* else FALL THROUGH */
4571 *fpc++ = FF_LITERAL;
4579 *fpc++ = (U16)skipspaces;
4583 *fpc++ = FF_NEWLINE;
4587 arg = fpc - linepc + 1;
4594 *fpc++ = FF_LINEMARK;
4595 noblank = repeat = FALSE;
4604 ischop = s[-1] == '^';
4610 arg = (s - base) - 1;
4612 *fpc++ = FF_LITERAL;
4620 *fpc++ = 2; /* skip the @* or ^* */
4622 *fpc++ = FF_LINESNGL;
4625 *fpc++ = FF_LINEGLOB;
4627 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4628 arg = ischop ? 512 : 0;
4633 const char * const f = ++s;
4636 arg |= 256 + (s - f);
4638 *fpc++ = s - base; /* fieldsize for FETCH */
4639 *fpc++ = FF_DECIMAL;
4641 unchopnum |= ! ischop;
4643 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4644 arg = ischop ? 512 : 0;
4646 s++; /* skip the '0' first */
4650 const char * const f = ++s;
4653 arg |= 256 + (s - f);
4655 *fpc++ = s - base; /* fieldsize for FETCH */
4656 *fpc++ = FF_0DECIMAL;
4658 unchopnum |= ! ischop;
4662 bool ismore = FALSE;
4665 while (*++s == '>') ;
4666 prespace = FF_SPACE;
4668 else if (*s == '|') {
4669 while (*++s == '|') ;
4670 prespace = FF_HALFSPACE;
4675 while (*++s == '<') ;
4678 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4682 *fpc++ = s - base; /* fieldsize for FETCH */
4684 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4687 *fpc++ = (U16)prespace;
4701 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4703 { /* need to jump to the next word */
4705 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4706 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4707 s = SvPVX(sv) + SvCUR(sv) + z;
4709 Copy(fops, s, arg, U32);
4711 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4714 if (unchopnum && repeat)
4715 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4721 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4723 /* Can value be printed in fldsize chars, using %*.*f ? */
4727 int intsize = fldsize - (value < 0 ? 1 : 0);
4734 while (intsize--) pwr *= 10.0;
4735 while (frcsize--) eps /= 10.0;
4738 if (value + eps >= pwr)
4741 if (value - eps <= -pwr)
4748 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4751 SV * const datasv = FILTER_DATA(idx);
4752 const int filter_has_file = IoLINES(datasv);
4753 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4754 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4758 const char *got_p = NULL;
4759 const char *prune_from = NULL;
4760 bool read_from_cache = FALSE;
4763 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4765 assert(maxlen >= 0);
4768 /* I was having segfault trouble under Linux 2.2.5 after a
4769 parse error occured. (Had to hack around it with a test
4770 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4771 not sure where the trouble is yet. XXX */
4773 if (IoFMT_GV(datasv)) {
4774 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4777 const char *cache_p = SvPV(cache, cache_len);
4781 /* Running in block mode and we have some cached data already.
4783 if (cache_len >= umaxlen) {
4784 /* In fact, so much data we don't even need to call
4789 const char *const first_nl =
4790 (const char *)memchr(cache_p, '\n', cache_len);
4792 take = first_nl + 1 - cache_p;
4796 sv_catpvn(buf_sv, cache_p, take);
4797 sv_chop(cache, cache_p + take);
4798 /* Definately not EOF */
4802 sv_catsv(buf_sv, cache);
4804 umaxlen -= cache_len;
4807 read_from_cache = TRUE;
4811 /* Filter API says that the filter appends to the contents of the buffer.
4812 Usually the buffer is "", so the details don't matter. But if it's not,
4813 then clearly what it contains is already filtered by this filter, so we
4814 don't want to pass it in a second time.
4815 I'm going to use a mortal in case the upstream filter croaks. */
4816 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4817 ? sv_newmortal() : buf_sv;
4818 SvUPGRADE(upstream, SVt_PV);
4820 if (filter_has_file) {
4821 status = FILTER_READ(idx+1, upstream, 0);
4824 if (filter_sub && status >= 0) {
4833 DEFSV_set(upstream);
4837 PUSHs(filter_state);
4840 count = call_sv(filter_sub, G_SCALAR);
4855 if(SvOK(upstream)) {
4856 got_p = SvPV(upstream, got_len);
4858 if (got_len > umaxlen) {
4859 prune_from = got_p + umaxlen;
4862 const char *const first_nl =
4863 (const char *)memchr(got_p, '\n', got_len);
4864 if (first_nl && first_nl + 1 < got_p + got_len) {
4865 /* There's a second line here... */
4866 prune_from = first_nl + 1;
4871 /* Oh. Too long. Stuff some in our cache. */
4872 STRLEN cached_len = got_p + got_len - prune_from;
4873 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4876 IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4877 } else if (SvOK(cache)) {
4878 /* Cache should be empty. */
4879 assert(!SvCUR(cache));
4882 sv_setpvn(cache, prune_from, cached_len);
4883 /* If you ask for block mode, you may well split UTF-8 characters.
4884 "If it breaks, you get to keep both parts"
4885 (Your code is broken if you don't put them back together again
4886 before something notices.) */
4887 if (SvUTF8(upstream)) {
4890 SvCUR_set(upstream, got_len - cached_len);
4891 /* Can't yet be EOF */
4896 /* If they are at EOF but buf_sv has something in it, then they may never
4897 have touched the SV upstream, so it may be undefined. If we naively
4898 concatenate it then we get a warning about use of uninitialised value.
4900 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4901 sv_catsv(buf_sv, upstream);
4905 IoLINES(datasv) = 0;
4906 SvREFCNT_dec(IoFMT_GV(datasv));
4908 SvREFCNT_dec(filter_state);
4909 IoTOP_GV(datasv) = NULL;
4912 SvREFCNT_dec(filter_sub);
4913 IoBOTTOM_GV(datasv) = NULL;
4915 filter_del(S_run_user_filter);
4917 if (status == 0 && read_from_cache) {
4918 /* If we read some data from the cache (and by getting here it implies
4919 that we emptied the cache) then we aren't yet at EOF, and mustn't
4920 report that to our caller. */
4926 /* perhaps someone can come up with a better name for
4927 this? it is not really "absolute", per se ... */
4929 S_path_is_absolute(const char *name)
4931 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4933 if (PERL_FILE_IS_ABSOLUTE(name)
4934 #ifdef MACOS_TRADITIONAL
4937 || (*name == '.' && (name[1] == '/' ||
4938 (name[1] == '.' && name[2] == '/')))
4950 * c-indentation-style: bsd
4952 * indent-tabs-mode: t
4955 * ex: set ts=8 sts=4 sw=4 noet: