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);
236 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
240 if (CxONCE(cx) || s < orig ||
241 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
242 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
243 ((cx->sb_rflags & REXEC_COPY_STR)
244 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
245 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
247 SV * const targ = cx->sb_targ;
249 assert(cx->sb_strend >= s);
250 if(cx->sb_strend > s) {
251 if (DO_UTF8(dstr) && !SvUTF8(targ))
252 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
254 sv_catpvn(dstr, s, cx->sb_strend - s);
256 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
258 #ifdef PERL_OLD_COPY_ON_WRITE
260 sv_force_normal_flags(targ, SV_COW_DROP_PV);
266 SvPV_set(targ, SvPVX(dstr));
267 SvCUR_set(targ, SvCUR(dstr));
268 SvLEN_set(targ, SvLEN(dstr));
271 SvPV_set(dstr, NULL);
273 TAINT_IF(cx->sb_rxtainted & 1);
274 mPUSHi(saviters - 1);
276 (void)SvPOK_only_UTF8(targ);
277 TAINT_IF(cx->sb_rxtainted);
281 LEAVE_SCOPE(cx->sb_oldsave);
283 RETURNOP(pm->op_next);
285 cx->sb_iters = saviters;
287 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
290 cx->sb_orig = orig = RX_SUBBEG(rx);
292 cx->sb_strend = s + (cx->sb_strend - m);
294 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
296 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
297 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
299 sv_catpvn(dstr, s, m-s);
301 cx->sb_s = RX_OFFS(rx)[0].end + orig;
302 { /* Update the pos() information. */
303 SV * const sv = cx->sb_targ;
305 SvUPGRADE(sv, SVt_PVMG);
306 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
307 #ifdef PERL_OLD_COPY_ON_WRITE
309 sv_force_normal_flags(sv, 0);
311 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
314 mg->mg_len = m - orig;
317 (void)ReREFCNT_inc(rx);
318 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
319 rxres_save(&cx->sb_rxres, rx);
320 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
324 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
329 PERL_ARGS_ASSERT_RXRES_SAVE;
332 if (!p || p[1] < RX_NPARENS(rx)) {
333 #ifdef PERL_OLD_COPY_ON_WRITE
334 i = 7 + RX_NPARENS(rx) * 2;
336 i = 6 + RX_NPARENS(rx) * 2;
345 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
346 RX_MATCH_COPIED_off(rx);
348 #ifdef PERL_OLD_COPY_ON_WRITE
349 *p++ = PTR2UV(RX_SAVED_COPY(rx));
350 RX_SAVED_COPY(rx) = NULL;
353 *p++ = RX_NPARENS(rx);
355 *p++ = PTR2UV(RX_SUBBEG(rx));
356 *p++ = (UV)RX_SUBLEN(rx);
357 for (i = 0; i <= RX_NPARENS(rx); ++i) {
358 *p++ = (UV)RX_OFFS(rx)[i].start;
359 *p++ = (UV)RX_OFFS(rx)[i].end;
364 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
369 PERL_ARGS_ASSERT_RXRES_RESTORE;
372 RX_MATCH_COPY_FREE(rx);
373 RX_MATCH_COPIED_set(rx, *p);
376 #ifdef PERL_OLD_COPY_ON_WRITE
377 if (RX_SAVED_COPY(rx))
378 SvREFCNT_dec (RX_SAVED_COPY(rx));
379 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
383 RX_NPARENS(rx) = *p++;
385 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
386 RX_SUBLEN(rx) = (I32)(*p++);
387 for (i = 0; i <= RX_NPARENS(rx); ++i) {
388 RX_OFFS(rx)[i].start = (I32)(*p++);
389 RX_OFFS(rx)[i].end = (I32)(*p++);
394 S_rxres_free(pTHX_ void **rsp)
396 UV * const p = (UV*)*rsp;
398 PERL_ARGS_ASSERT_RXRES_FREE;
403 void *tmp = INT2PTR(char*,*p);
406 PoisonFree(*p, 1, sizeof(*p));
408 Safefree(INT2PTR(char*,*p));
410 #ifdef PERL_OLD_COPY_ON_WRITE
412 SvREFCNT_dec (INT2PTR(SV*,p[1]));
422 dVAR; dSP; dMARK; dORIGMARK;
423 register SV * const tmpForm = *++MARK;
428 register SV *sv = NULL;
429 const char *item = NULL;
433 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
434 const char *chophere = NULL;
435 char *linemark = NULL;
437 bool gotsome = FALSE;
439 const STRLEN fudge = SvPOK(tmpForm)
440 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
441 bool item_is_utf8 = FALSE;
442 bool targ_is_utf8 = FALSE;
444 OP * parseres = NULL;
447 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
448 if (SvREADONLY(tmpForm)) {
449 SvREADONLY_off(tmpForm);
450 parseres = doparseform(tmpForm);
451 SvREADONLY_on(tmpForm);
454 parseres = doparseform(tmpForm);
458 SvPV_force(PL_formtarget, len);
459 if (DO_UTF8(PL_formtarget))
461 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
463 f = SvPV_const(tmpForm, len);
464 /* need to jump to the next word */
465 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
469 const char *name = "???";
472 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
473 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
474 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
475 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
476 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
478 case FF_CHECKNL: name = "CHECKNL"; break;
479 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
480 case FF_SPACE: name = "SPACE"; break;
481 case FF_HALFSPACE: name = "HALFSPACE"; break;
482 case FF_ITEM: name = "ITEM"; break;
483 case FF_CHOP: name = "CHOP"; break;
484 case FF_LINEGLOB: name = "LINEGLOB"; break;
485 case FF_NEWLINE: name = "NEWLINE"; break;
486 case FF_MORE: name = "MORE"; break;
487 case FF_LINEMARK: name = "LINEMARK"; break;
488 case FF_END: name = "END"; break;
489 case FF_0DECIMAL: name = "0DECIMAL"; break;
490 case FF_LINESNGL: name = "LINESNGL"; break;
493 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
495 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
506 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
507 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
509 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
510 t = SvEND(PL_formtarget);
514 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
515 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
517 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
518 t = SvEND(PL_formtarget);
538 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
545 const char *s = item = SvPV_const(sv, len);
548 itemsize = sv_len_utf8(sv);
549 if (itemsize != (I32)len) {
551 if (itemsize > fieldsize) {
552 itemsize = fieldsize;
553 itembytes = itemsize;
554 sv_pos_u2b(sv, &itembytes, 0);
558 send = chophere = s + itembytes;
568 sv_pos_b2u(sv, &itemsize);
572 item_is_utf8 = FALSE;
573 if (itemsize > fieldsize)
574 itemsize = fieldsize;
575 send = chophere = s + itemsize;
589 const char *s = item = SvPV_const(sv, len);
592 itemsize = sv_len_utf8(sv);
593 if (itemsize != (I32)len) {
595 if (itemsize <= fieldsize) {
596 const char *send = chophere = s + itemsize;
609 itemsize = fieldsize;
610 itembytes = itemsize;
611 sv_pos_u2b(sv, &itembytes, 0);
612 send = chophere = s + itembytes;
613 while (s < send || (s == send && isSPACE(*s))) {
623 if (strchr(PL_chopset, *s))
628 itemsize = chophere - item;
629 sv_pos_b2u(sv, &itemsize);
635 item_is_utf8 = FALSE;
636 if (itemsize <= fieldsize) {
637 const char *const send = chophere = s + itemsize;
650 itemsize = fieldsize;
651 send = chophere = s + itemsize;
652 while (s < send || (s == send && isSPACE(*s))) {
662 if (strchr(PL_chopset, *s))
667 itemsize = chophere - item;
673 arg = fieldsize - itemsize;
682 arg = fieldsize - itemsize;
693 const char *s = item;
697 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
699 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
701 t = SvEND(PL_formtarget);
705 if (UTF8_IS_CONTINUED(*s)) {
706 STRLEN skip = UTF8SKIP(s);
723 if ( !((*t++ = *s++) & ~31) )
729 if (targ_is_utf8 && !item_is_utf8) {
730 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
732 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
733 for (; t < SvEND(PL_formtarget); t++) {
746 const int ch = *t++ = *s++;
749 if ( !((*t++ = *s++) & ~31) )
758 const char *s = chophere;
772 const bool oneline = fpc[-1] == FF_LINESNGL;
773 const char *s = item = SvPV_const(sv, len);
774 item_is_utf8 = DO_UTF8(sv);
777 STRLEN to_copy = itemsize;
778 const char *const send = s + len;
779 const U8 *source = (const U8 *) s;
783 chophere = s + itemsize;
787 to_copy = s - SvPVX_const(sv) - 1;
799 if (targ_is_utf8 && !item_is_utf8) {
800 source = tmp = bytes_to_utf8(source, &to_copy);
801 SvCUR_set(PL_formtarget,
802 t - SvPVX_const(PL_formtarget));
804 if (item_is_utf8 && !targ_is_utf8) {
805 /* Upgrade targ to UTF8, and then we reduce it to
806 a problem we have a simple solution for. */
807 SvCUR_set(PL_formtarget,
808 t - SvPVX_const(PL_formtarget));
810 /* Don't need get magic. */
811 sv_utf8_upgrade_nomg(PL_formtarget);
813 SvCUR_set(PL_formtarget,
814 t - SvPVX_const(PL_formtarget));
817 /* Easy. They agree. */
818 assert (item_is_utf8 == targ_is_utf8);
820 SvGROW(PL_formtarget,
821 SvCUR(PL_formtarget) + to_copy + fudge + 1);
822 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
824 Copy(source, t, to_copy, char);
826 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
828 if (SvGMAGICAL(sv)) {
829 /* Mustn't call sv_pos_b2u() as it does a second
830 mg_get(). Is this a bug? Do we need a _flags()
832 itemsize = utf8_length(source, source + itemsize);
834 sv_pos_b2u(sv, &itemsize);
846 #if defined(USE_LONG_DOUBLE)
849 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
853 "%#0*.*f" : "%0*.*f");
858 #if defined(USE_LONG_DOUBLE)
860 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
863 ((arg & 256) ? "%#*.*f" : "%*.*f");
866 /* If the field is marked with ^ and the value is undefined,
868 if ((arg & 512) && !SvOK(sv)) {
876 /* overflow evidence */
877 if (num_overflow(value, fieldsize, arg)) {
883 /* Formats aren't yet marked for locales, so assume "yes". */
885 STORE_NUMERIC_STANDARD_SET_LOCAL();
886 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
887 RESTORE_NUMERIC_STANDARD();
894 while (t-- > linemark && *t == ' ') ;
902 if (arg) { /* repeat until fields exhausted? */
904 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
905 lines += FmLINES(PL_formtarget);
908 if (strnEQ(linemark, linemark - arg, arg))
909 DIE(aTHX_ "Runaway format");
912 SvUTF8_on(PL_formtarget);
913 FmLINES(PL_formtarget) = lines;
915 RETURNOP(cLISTOP->op_first);
926 const char *s = chophere;
927 const char *send = item + len;
929 while (isSPACE(*s) && (s < send))
934 arg = fieldsize - itemsize;
941 if (strnEQ(s1," ",3)) {
942 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
953 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
955 SvUTF8_on(PL_formtarget);
956 FmLINES(PL_formtarget) += lines;
968 if (PL_stack_base + *PL_markstack_ptr == SP) {
970 if (GIMME_V == G_SCALAR)
972 RETURNOP(PL_op->op_next->op_next);
974 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
975 pp_pushmark(); /* push dst */
976 pp_pushmark(); /* push src */
977 ENTER; /* enter outer scope */
980 if (PL_op->op_private & OPpGREP_LEX)
981 SAVESPTR(PAD_SVl(PL_op->op_targ));
984 ENTER; /* enter inner scope */
987 src = PL_stack_base[*PL_markstack_ptr];
989 if (PL_op->op_private & OPpGREP_LEX)
990 PAD_SVl(PL_op->op_targ) = src;
995 if (PL_op->op_type == OP_MAPSTART)
996 pp_pushmark(); /* push top */
997 return ((LOGOP*)PL_op->op_next)->op_other;
1003 const I32 gimme = GIMME_V;
1004 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1010 /* first, move source pointer to the next item in the source list */
1011 ++PL_markstack_ptr[-1];
1013 /* if there are new items, push them into the destination list */
1014 if (items && gimme != G_VOID) {
1015 /* might need to make room back there first */
1016 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1017 /* XXX this implementation is very pessimal because the stack
1018 * is repeatedly extended for every set of items. Is possible
1019 * to do this without any stack extension or copying at all
1020 * by maintaining a separate list over which the map iterates
1021 * (like foreach does). --gsar */
1023 /* everything in the stack after the destination list moves
1024 * towards the end the stack by the amount of room needed */
1025 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1027 /* items to shift up (accounting for the moved source pointer) */
1028 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1030 /* This optimization is by Ben Tilly and it does
1031 * things differently from what Sarathy (gsar)
1032 * is describing. The downside of this optimization is
1033 * that leaves "holes" (uninitialized and hopefully unused areas)
1034 * to the Perl stack, but on the other hand this
1035 * shouldn't be a problem. If Sarathy's idea gets
1036 * implemented, this optimization should become
1037 * irrelevant. --jhi */
1039 shift = count; /* Avoid shifting too often --Ben Tilly */
1043 dst = (SP += shift);
1044 PL_markstack_ptr[-1] += shift;
1045 *PL_markstack_ptr += shift;
1049 /* copy the new items down to the destination list */
1050 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1051 if (gimme == G_ARRAY) {
1053 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1056 /* scalar context: we don't care about which values map returns
1057 * (we use undef here). And so we certainly don't want to do mortal
1058 * copies of meaningless values. */
1059 while (items-- > 0) {
1061 *dst-- = &PL_sv_undef;
1065 LEAVE; /* exit inner scope */
1068 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1070 (void)POPMARK; /* pop top */
1071 LEAVE; /* exit outer scope */
1072 (void)POPMARK; /* pop src */
1073 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1074 (void)POPMARK; /* pop dst */
1075 SP = PL_stack_base + POPMARK; /* pop original mark */
1076 if (gimme == G_SCALAR) {
1077 if (PL_op->op_private & OPpGREP_LEX) {
1078 SV* sv = sv_newmortal();
1079 sv_setiv(sv, items);
1087 else if (gimme == G_ARRAY)
1094 ENTER; /* enter inner scope */
1097 /* set $_ to the new source item */
1098 src = PL_stack_base[PL_markstack_ptr[-1]];
1100 if (PL_op->op_private & OPpGREP_LEX)
1101 PAD_SVl(PL_op->op_targ) = src;
1105 RETURNOP(cLOGOP->op_other);
1114 if (GIMME == G_ARRAY)
1116 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1117 return cLOGOP->op_other;
1127 if (GIMME == G_ARRAY) {
1128 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1132 SV * const targ = PAD_SV(PL_op->op_targ);
1135 if (PL_op->op_private & OPpFLIP_LINENUM) {
1136 if (GvIO(PL_last_in_gv)) {
1137 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1140 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1142 flip = SvIV(sv) == SvIV(GvSV(gv));
1148 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1149 if (PL_op->op_flags & OPf_SPECIAL) {
1157 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1160 sv_setpvs(TARG, "");
1166 /* This code tries to decide if "$left .. $right" should use the
1167 magical string increment, or if the range is numeric (we make
1168 an exception for .."0" [#18165]). AMS 20021031. */
1170 #define RANGE_IS_NUMERIC(left,right) ( \
1171 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1172 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1173 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1174 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1175 && (!SvOK(right) || looks_like_number(right))))
1181 if (GIMME == G_ARRAY) {
1187 if (RANGE_IS_NUMERIC(left,right)) {
1190 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1191 (SvOK(right) && SvNV(right) > IV_MAX))
1192 DIE(aTHX_ "Range iterator outside integer range");
1203 SV * const sv = sv_2mortal(newSViv(i++));
1208 SV * const final = sv_mortalcopy(right);
1210 const char * const tmps = SvPV_const(final, len);
1212 SV *sv = sv_mortalcopy(left);
1213 SvPV_force_nolen(sv);
1214 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1216 if (strEQ(SvPVX_const(sv),tmps))
1218 sv = sv_2mortal(newSVsv(sv));
1225 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1229 if (PL_op->op_private & OPpFLIP_LINENUM) {
1230 if (GvIO(PL_last_in_gv)) {
1231 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1234 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1235 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1243 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1244 sv_catpvs(targ, "E0");
1254 static const char * const context_name[] = {
1256 NULL, /* CXt_WHEN never actually needs "block" */
1257 NULL, /* CXt_BLOCK never actually needs "block" */
1258 NULL, /* CXt_GIVEN never actually needs "block" */
1259 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1260 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1261 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1262 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1270 S_dopoptolabel(pTHX_ const char *label)
1275 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1277 for (i = cxstack_ix; i >= 0; i--) {
1278 register const PERL_CONTEXT * const cx = &cxstack[i];
1279 switch (CxTYPE(cx)) {
1285 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1286 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1287 if (CxTYPE(cx) == CXt_NULL)
1290 case CXt_LOOP_LAZYIV:
1291 case CXt_LOOP_LAZYSV:
1293 case CXt_LOOP_PLAIN:
1294 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1295 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1296 (long)i, CxLABEL(cx)));
1299 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1309 Perl_dowantarray(pTHX)
1312 const I32 gimme = block_gimme();
1313 return (gimme == G_VOID) ? G_SCALAR : gimme;
1317 Perl_block_gimme(pTHX)
1320 const I32 cxix = dopoptosub(cxstack_ix);
1324 switch (cxstack[cxix].blk_gimme) {
1332 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1339 Perl_is_lvalue_sub(pTHX)
1342 const I32 cxix = dopoptosub(cxstack_ix);
1343 assert(cxix >= 0); /* We should only be called from inside subs */
1345 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1346 return CxLVAL(cxstack + cxix);
1352 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1357 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1359 for (i = startingblock; i >= 0; i--) {
1360 register const PERL_CONTEXT * const cx = &cxstk[i];
1361 switch (CxTYPE(cx)) {
1367 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1375 S_dopoptoeval(pTHX_ I32 startingblock)
1379 for (i = startingblock; i >= 0; i--) {
1380 register const PERL_CONTEXT *cx = &cxstack[i];
1381 switch (CxTYPE(cx)) {
1385 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1393 S_dopoptoloop(pTHX_ I32 startingblock)
1397 for (i = startingblock; i >= 0; i--) {
1398 register const PERL_CONTEXT * const cx = &cxstack[i];
1399 switch (CxTYPE(cx)) {
1405 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1406 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1407 if ((CxTYPE(cx)) == CXt_NULL)
1410 case CXt_LOOP_LAZYIV:
1411 case CXt_LOOP_LAZYSV:
1413 case CXt_LOOP_PLAIN:
1414 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1422 S_dopoptogiven(pTHX_ I32 startingblock)
1426 for (i = startingblock; i >= 0; i--) {
1427 register const PERL_CONTEXT *cx = &cxstack[i];
1428 switch (CxTYPE(cx)) {
1432 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1434 case CXt_LOOP_PLAIN:
1435 assert(!CxFOREACHDEF(cx));
1437 case CXt_LOOP_LAZYIV:
1438 case CXt_LOOP_LAZYSV:
1440 if (CxFOREACHDEF(cx)) {
1441 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1450 S_dopoptowhen(pTHX_ I32 startingblock)
1454 for (i = startingblock; i >= 0; i--) {
1455 register const PERL_CONTEXT *cx = &cxstack[i];
1456 switch (CxTYPE(cx)) {
1460 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1468 Perl_dounwind(pTHX_ I32 cxix)
1473 while (cxstack_ix > cxix) {
1475 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1476 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1477 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1478 /* Note: we don't need to restore the base context info till the end. */
1479 switch (CxTYPE(cx)) {
1482 continue; /* not break */
1490 case CXt_LOOP_LAZYIV:
1491 case CXt_LOOP_LAZYSV:
1493 case CXt_LOOP_PLAIN:
1504 PERL_UNUSED_VAR(optype);
1508 Perl_qerror(pTHX_ SV *err)
1512 PERL_ARGS_ASSERT_QERROR;
1515 sv_catsv(ERRSV, err);
1517 sv_catsv(PL_errors, err);
1519 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1521 ++PL_parser->error_count;
1525 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1534 if (PL_in_eval & EVAL_KEEPERR) {
1535 static const char prefix[] = "\t(in cleanup) ";
1536 SV * const err = ERRSV;
1537 const char *e = NULL;
1540 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1542 e = SvPV_const(err, len);
1544 if (*e != *message || strNE(e,message))
1549 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1550 sv_catpvn(err, prefix, sizeof(prefix)-1);
1551 sv_catpvn(err, message, msglen);
1552 start = SvCUR(err)-msglen-sizeof(prefix)+1;
1553 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1554 SvPVX_const(err)+start);
1558 sv_setpvn(ERRSV, message, msglen);
1562 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1563 && PL_curstackinfo->si_prev)
1571 register PERL_CONTEXT *cx;
1574 if (cxix < cxstack_ix)
1577 POPBLOCK(cx,PL_curpm);
1578 if (CxTYPE(cx) != CXt_EVAL) {
1580 message = SvPVx_const(ERRSV, msglen);
1581 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1582 PerlIO_write(Perl_error_log, message, msglen);
1587 if (gimme == G_SCALAR)
1588 *++newsp = &PL_sv_undef;
1589 PL_stack_sp = newsp;
1593 /* LEAVE could clobber PL_curcop (see save_re_context())
1594 * XXX it might be better to find a way to avoid messing with
1595 * PL_curcop in save_re_context() instead, but this is a more
1596 * minimal fix --GSAR */
1597 PL_curcop = cx->blk_oldcop;
1599 if (optype == OP_REQUIRE) {
1600 const char* const msg = SvPVx_nolen_const(ERRSV);
1601 SV * const nsv = cx->blk_eval.old_namesv;
1602 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1604 DIE(aTHX_ "%sCompilation failed in require",
1605 *msg ? msg : "Unknown error\n");
1607 assert(CxTYPE(cx) == CXt_EVAL);
1608 return cx->blk_eval.retop;
1612 message = SvPVx_const(ERRSV, msglen);
1614 write_to_stderr(message, msglen);
1622 dVAR; dSP; dPOPTOPssrl;
1623 if (SvTRUE(left) != SvTRUE(right))
1633 register I32 cxix = dopoptosub(cxstack_ix);
1634 register const PERL_CONTEXT *cx;
1635 register const PERL_CONTEXT *ccstack = cxstack;
1636 const PERL_SI *top_si = PL_curstackinfo;
1638 const char *stashname;
1645 /* we may be in a higher stacklevel, so dig down deeper */
1646 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1647 top_si = top_si->si_prev;
1648 ccstack = top_si->si_cxstack;
1649 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1652 if (GIMME != G_ARRAY) {
1658 /* caller() should not report the automatic calls to &DB::sub */
1659 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1660 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1664 cxix = dopoptosub_at(ccstack, cxix - 1);
1667 cx = &ccstack[cxix];
1668 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1669 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1670 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1671 field below is defined for any cx. */
1672 /* caller() should not report the automatic calls to &DB::sub */
1673 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1674 cx = &ccstack[dbcxix];
1677 stashname = CopSTASHPV(cx->blk_oldcop);
1678 if (GIMME != G_ARRAY) {
1681 PUSHs(&PL_sv_undef);
1684 sv_setpv(TARG, stashname);
1693 PUSHs(&PL_sv_undef);
1695 mPUSHs(newSVpv(stashname, 0));
1696 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1697 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1700 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1701 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1702 /* So is ccstack[dbcxix]. */
1704 SV * const sv = newSV(0);
1705 gv_efullname3(sv, cvgv, NULL);
1707 PUSHs(boolSV(CxHASARGS(cx)));
1710 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1711 PUSHs(boolSV(CxHASARGS(cx)));
1715 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1718 gimme = (I32)cx->blk_gimme;
1719 if (gimme == G_VOID)
1720 PUSHs(&PL_sv_undef);
1722 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1723 if (CxTYPE(cx) == CXt_EVAL) {
1725 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1726 PUSHs(cx->blk_eval.cur_text);
1730 else if (cx->blk_eval.old_namesv) {
1731 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1734 /* eval BLOCK (try blocks have old_namesv == 0) */
1736 PUSHs(&PL_sv_undef);
1737 PUSHs(&PL_sv_undef);
1741 PUSHs(&PL_sv_undef);
1742 PUSHs(&PL_sv_undef);
1744 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1745 && CopSTASH_eq(PL_curcop, PL_debstash))
1747 AV * const ary = cx->blk_sub.argarray;
1748 const int off = AvARRAY(ary) - AvALLOC(ary);
1751 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1753 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1756 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1757 av_extend(PL_dbargs, AvFILLp(ary) + off);
1758 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1759 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1761 /* XXX only hints propagated via op_private are currently
1762 * visible (others are not easily accessible, since they
1763 * use the global PL_hints) */
1764 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1767 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1769 if (old_warnings == pWARN_NONE ||
1770 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1771 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1772 else if (old_warnings == pWARN_ALL ||
1773 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1774 /* Get the bit mask for $warnings::Bits{all}, because
1775 * it could have been extended by warnings::register */
1777 HV * const bits = get_hv("warnings::Bits", 0);
1778 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1779 mask = newSVsv(*bits_all);
1782 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1786 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1790 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1791 sv_2mortal(newRV_noinc(
1792 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1793 cx->blk_oldcop->cop_hints_hash))))
1802 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1803 sv_reset(tmps, CopSTASH(PL_curcop));
1808 /* like pp_nextstate, but used instead when the debugger is active */
1813 PL_curcop = (COP*)PL_op;
1814 TAINT_NOT; /* Each statement is presumed innocent */
1815 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1818 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1819 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1822 register PERL_CONTEXT *cx;
1823 const I32 gimme = G_ARRAY;
1825 GV * const gv = PL_DBgv;
1826 register CV * const cv = GvCV(gv);
1829 DIE(aTHX_ "No DB::DB routine defined");
1831 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1832 /* don't do recursive DB::DB call */
1847 (void)(*CvXSUB(cv))(aTHX_ cv);
1854 PUSHBLOCK(cx, CXt_SUB, SP);
1856 cx->blk_sub.retop = PL_op->op_next;
1859 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1860 RETURNOP(CvSTART(cv));
1870 register PERL_CONTEXT *cx;
1871 const I32 gimme = GIMME_V;
1873 U8 cxtype = CXt_LOOP_FOR;
1881 if (PL_op->op_targ) {
1882 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1883 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1884 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1885 SVs_PADSTALE, SVs_PADSTALE);
1887 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1888 #ifndef USE_ITHREADS
1889 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1895 GV * const gv = MUTABLE_GV(POPs);
1896 svp = &GvSV(gv); /* symbol table variable */
1897 SAVEGENERICSV(*svp);
1900 iterdata = (PAD*)gv;
1904 if (PL_op->op_private & OPpITER_DEF)
1905 cxtype |= CXp_FOR_DEF;
1909 PUSHBLOCK(cx, cxtype, SP);
1911 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1913 PUSHLOOP_FOR(cx, svp, MARK, 0);
1915 if (PL_op->op_flags & OPf_STACKED) {
1916 SV *maybe_ary = POPs;
1917 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1919 SV * const right = maybe_ary;
1922 if (RANGE_IS_NUMERIC(sv,right)) {
1923 cx->cx_type &= ~CXTYPEMASK;
1924 cx->cx_type |= CXt_LOOP_LAZYIV;
1925 /* Make sure that no-one re-orders cop.h and breaks our
1927 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1928 #ifdef NV_PRESERVES_UV
1929 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1930 (SvNV(sv) > (NV)IV_MAX)))
1932 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1933 (SvNV(right) < (NV)IV_MIN))))
1935 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1938 ((SvUV(sv) > (UV)IV_MAX) ||
1939 (SvNV(sv) > (NV)UV_MAX)))))
1941 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1943 ((SvNV(right) > 0) &&
1944 ((SvUV(right) > (UV)IV_MAX) ||
1945 (SvNV(right) > (NV)UV_MAX))))))
1947 DIE(aTHX_ "Range iterator outside integer range");
1948 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1949 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1951 /* for correct -Dstv display */
1952 cx->blk_oldsp = sp - PL_stack_base;
1956 cx->cx_type &= ~CXTYPEMASK;
1957 cx->cx_type |= CXt_LOOP_LAZYSV;
1958 /* Make sure that no-one re-orders cop.h and breaks our
1960 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1961 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1962 cx->blk_loop.state_u.lazysv.end = right;
1963 SvREFCNT_inc(right);
1964 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1965 /* This will do the upgrade to SVt_PV, and warn if the value
1966 is uninitialised. */
1967 (void) SvPV_nolen_const(right);
1968 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1969 to replace !SvOK() with a pointer to "". */
1971 SvREFCNT_dec(right);
1972 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1976 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1977 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1978 SvREFCNT_inc(maybe_ary);
1979 cx->blk_loop.state_u.ary.ix =
1980 (PL_op->op_private & OPpITER_REVERSED) ?
1981 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1985 else { /* iterating over items on the stack */
1986 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1987 if (PL_op->op_private & OPpITER_REVERSED) {
1988 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1991 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2001 register PERL_CONTEXT *cx;
2002 const I32 gimme = GIMME_V;
2008 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2009 PUSHLOOP_PLAIN(cx, SP);
2017 register PERL_CONTEXT *cx;
2024 assert(CxTYPE_is_LOOP(cx));
2026 newsp = PL_stack_base + cx->blk_loop.resetsp;
2029 if (gimme == G_VOID)
2031 else if (gimme == G_SCALAR) {
2033 *++newsp = sv_mortalcopy(*SP);
2035 *++newsp = &PL_sv_undef;
2039 *++newsp = sv_mortalcopy(*++mark);
2040 TAINT_NOT; /* Each item is independent */
2046 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2047 PL_curpm = newpm; /* ... and pop $1 et al */
2058 register PERL_CONTEXT *cx;
2059 bool popsub2 = FALSE;
2060 bool clear_errsv = FALSE;
2068 const I32 cxix = dopoptosub(cxstack_ix);
2071 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2072 * sort block, which is a CXt_NULL
2075 PL_stack_base[1] = *PL_stack_sp;
2076 PL_stack_sp = PL_stack_base + 1;
2080 DIE(aTHX_ "Can't return outside a subroutine");
2082 if (cxix < cxstack_ix)
2085 if (CxMULTICALL(&cxstack[cxix])) {
2086 gimme = cxstack[cxix].blk_gimme;
2087 if (gimme == G_VOID)
2088 PL_stack_sp = PL_stack_base;
2089 else if (gimme == G_SCALAR) {
2090 PL_stack_base[1] = *PL_stack_sp;
2091 PL_stack_sp = PL_stack_base + 1;
2097 switch (CxTYPE(cx)) {
2100 retop = cx->blk_sub.retop;
2101 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2104 if (!(PL_in_eval & EVAL_KEEPERR))
2107 retop = cx->blk_eval.retop;
2111 if (optype == OP_REQUIRE &&
2112 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2114 /* Unassume the success we assumed earlier. */
2115 SV * const nsv = cx->blk_eval.old_namesv;
2116 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2117 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2122 retop = cx->blk_sub.retop;
2125 DIE(aTHX_ "panic: return");
2129 if (gimme == G_SCALAR) {
2132 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2134 *++newsp = SvREFCNT_inc(*SP);
2139 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2141 *++newsp = sv_mortalcopy(sv);
2146 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2149 *++newsp = sv_mortalcopy(*SP);
2152 *++newsp = &PL_sv_undef;
2154 else if (gimme == G_ARRAY) {
2155 while (++MARK <= SP) {
2156 *++newsp = (popsub2 && SvTEMP(*MARK))
2157 ? *MARK : sv_mortalcopy(*MARK);
2158 TAINT_NOT; /* Each item is independent */
2161 PL_stack_sp = newsp;
2164 /* Stack values are safe: */
2167 POPSUB(cx,sv); /* release CV and @_ ... */
2171 PL_curpm = newpm; /* ... and pop $1 et al */
2184 register PERL_CONTEXT *cx;
2195 if (PL_op->op_flags & OPf_SPECIAL) {
2196 cxix = dopoptoloop(cxstack_ix);
2198 DIE(aTHX_ "Can't \"last\" outside a loop block");
2201 cxix = dopoptolabel(cPVOP->op_pv);
2203 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2205 if (cxix < cxstack_ix)
2209 cxstack_ix++; /* temporarily protect top context */
2211 switch (CxTYPE(cx)) {
2212 case CXt_LOOP_LAZYIV:
2213 case CXt_LOOP_LAZYSV:
2215 case CXt_LOOP_PLAIN:
2217 newsp = PL_stack_base + cx->blk_loop.resetsp;
2218 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2222 nextop = cx->blk_sub.retop;
2226 nextop = cx->blk_eval.retop;
2230 nextop = cx->blk_sub.retop;
2233 DIE(aTHX_ "panic: last");
2237 if (gimme == G_SCALAR) {
2239 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2240 ? *SP : sv_mortalcopy(*SP);
2242 *++newsp = &PL_sv_undef;
2244 else if (gimme == G_ARRAY) {
2245 while (++MARK <= SP) {
2246 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2247 ? *MARK : sv_mortalcopy(*MARK);
2248 TAINT_NOT; /* Each item is independent */
2256 /* Stack values are safe: */
2258 case CXt_LOOP_LAZYIV:
2259 case CXt_LOOP_PLAIN:
2260 case CXt_LOOP_LAZYSV:
2262 POPLOOP(cx); /* release loop vars ... */
2266 POPSUB(cx,sv); /* release CV and @_ ... */
2269 PL_curpm = newpm; /* ... and pop $1 et al */
2272 PERL_UNUSED_VAR(optype);
2273 PERL_UNUSED_VAR(gimme);
2281 register PERL_CONTEXT *cx;
2284 if (PL_op->op_flags & OPf_SPECIAL) {
2285 cxix = dopoptoloop(cxstack_ix);
2287 DIE(aTHX_ "Can't \"next\" outside a loop block");
2290 cxix = dopoptolabel(cPVOP->op_pv);
2292 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2294 if (cxix < cxstack_ix)
2297 /* clear off anything above the scope we're re-entering, but
2298 * save the rest until after a possible continue block */
2299 inner = PL_scopestack_ix;
2301 if (PL_scopestack_ix < inner)
2302 leave_scope(PL_scopestack[PL_scopestack_ix]);
2303 PL_curcop = cx->blk_oldcop;
2304 return CX_LOOP_NEXTOP_GET(cx);
2311 register PERL_CONTEXT *cx;
2315 if (PL_op->op_flags & OPf_SPECIAL) {
2316 cxix = dopoptoloop(cxstack_ix);
2318 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2321 cxix = dopoptolabel(cPVOP->op_pv);
2323 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2325 if (cxix < cxstack_ix)
2328 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2329 if (redo_op->op_type == OP_ENTER) {
2330 /* pop one less context to avoid $x being freed in while (my $x..) */
2332 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2333 redo_op = redo_op->op_next;
2337 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2338 LEAVE_SCOPE(oldsave);
2340 PL_curcop = cx->blk_oldcop;
2345 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2349 static const char too_deep[] = "Target of goto is too deeply nested";
2351 PERL_ARGS_ASSERT_DOFINDLABEL;
2354 Perl_croak(aTHX_ too_deep);
2355 if (o->op_type == OP_LEAVE ||
2356 o->op_type == OP_SCOPE ||
2357 o->op_type == OP_LEAVELOOP ||
2358 o->op_type == OP_LEAVESUB ||
2359 o->op_type == OP_LEAVETRY)
2361 *ops++ = cUNOPo->op_first;
2363 Perl_croak(aTHX_ too_deep);
2366 if (o->op_flags & OPf_KIDS) {
2368 /* First try all the kids at this level, since that's likeliest. */
2369 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2370 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2371 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2374 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2375 if (kid == PL_lastgotoprobe)
2377 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2380 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2381 ops[-1]->op_type == OP_DBSTATE)
2386 if ((o = dofindlabel(kid, label, ops, oplimit)))
2399 register PERL_CONTEXT *cx;
2400 #define GOTO_DEPTH 64
2401 OP *enterops[GOTO_DEPTH];
2402 const char *label = NULL;
2403 const bool do_dump = (PL_op->op_type == OP_DUMP);
2404 static const char must_have_label[] = "goto must have label";
2406 if (PL_op->op_flags & OPf_STACKED) {
2407 SV * const sv = POPs;
2409 /* This egregious kludge implements goto &subroutine */
2410 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2412 register PERL_CONTEXT *cx;
2413 CV *cv = MUTABLE_CV(SvRV(sv));
2420 if (!CvROOT(cv) && !CvXSUB(cv)) {
2421 const GV * const gv = CvGV(cv);
2425 /* autoloaded stub? */
2426 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2428 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2429 GvNAMELEN(gv), FALSE);
2430 if (autogv && (cv = GvCV(autogv)))
2432 tmpstr = sv_newmortal();
2433 gv_efullname3(tmpstr, gv, NULL);
2434 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2436 DIE(aTHX_ "Goto undefined subroutine");
2439 /* First do some returnish stuff. */
2440 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2442 cxix = dopoptosub(cxstack_ix);
2444 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2445 if (cxix < cxstack_ix)
2449 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2450 if (CxTYPE(cx) == CXt_EVAL) {
2452 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2454 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2456 else if (CxMULTICALL(cx))
2457 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2458 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2459 /* put @_ back onto stack */
2460 AV* av = cx->blk_sub.argarray;
2462 items = AvFILLp(av) + 1;
2463 EXTEND(SP, items+1); /* @_ could have been extended. */
2464 Copy(AvARRAY(av), SP + 1, items, SV*);
2465 SvREFCNT_dec(GvAV(PL_defgv));
2466 GvAV(PL_defgv) = cx->blk_sub.savearray;
2468 /* abandon @_ if it got reified */
2473 av_extend(av, items-1);
2475 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2478 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2479 AV* const av = GvAV(PL_defgv);
2480 items = AvFILLp(av) + 1;
2481 EXTEND(SP, items+1); /* @_ could have been extended. */
2482 Copy(AvARRAY(av), SP + 1, items, SV*);
2486 if (CxTYPE(cx) == CXt_SUB &&
2487 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2488 SvREFCNT_dec(cx->blk_sub.cv);
2489 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2490 LEAVE_SCOPE(oldsave);
2492 /* Now do some callish stuff. */
2494 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2496 OP* const retop = cx->blk_sub.retop;
2501 for (index=0; index<items; index++)
2502 sv_2mortal(SP[-index]);
2505 /* XS subs don't have a CxSUB, so pop it */
2506 POPBLOCK(cx, PL_curpm);
2507 /* Push a mark for the start of arglist */
2510 (void)(*CvXSUB(cv))(aTHX_ cv);
2515 AV* const padlist = CvPADLIST(cv);
2516 if (CxTYPE(cx) == CXt_EVAL) {
2517 PL_in_eval = CxOLD_IN_EVAL(cx);
2518 PL_eval_root = cx->blk_eval.old_eval_root;
2519 cx->cx_type = CXt_SUB;
2521 cx->blk_sub.cv = cv;
2522 cx->blk_sub.olddepth = CvDEPTH(cv);
2525 if (CvDEPTH(cv) < 2)
2526 SvREFCNT_inc_simple_void_NN(cv);
2528 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2529 sub_crush_depth(cv);
2530 pad_push(padlist, CvDEPTH(cv));
2533 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2536 AV *const av = MUTABLE_AV(PAD_SVl(0));
2538 cx->blk_sub.savearray = GvAV(PL_defgv);
2539 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2540 CX_CURPAD_SAVE(cx->blk_sub);
2541 cx->blk_sub.argarray = av;
2543 if (items >= AvMAX(av) + 1) {
2544 SV **ary = AvALLOC(av);
2545 if (AvARRAY(av) != ary) {
2546 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2549 if (items >= AvMAX(av) + 1) {
2550 AvMAX(av) = items - 1;
2551 Renew(ary,items+1,SV*);
2557 Copy(mark,AvARRAY(av),items,SV*);
2558 AvFILLp(av) = items - 1;
2559 assert(!AvREAL(av));
2561 /* transfer 'ownership' of refcnts to new @_ */
2571 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2572 Perl_get_db_sub(aTHX_ NULL, cv);
2574 CV * const gotocv = get_cvs("DB::goto", 0);
2576 PUSHMARK( PL_stack_sp );
2577 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2582 RETURNOP(CvSTART(cv));
2586 label = SvPV_nolen_const(sv);
2587 if (!(do_dump || *label))
2588 DIE(aTHX_ must_have_label);
2591 else if (PL_op->op_flags & OPf_SPECIAL) {
2593 DIE(aTHX_ must_have_label);
2596 label = cPVOP->op_pv;
2598 if (label && *label) {
2599 OP *gotoprobe = NULL;
2600 bool leaving_eval = FALSE;
2601 bool in_block = FALSE;
2602 PERL_CONTEXT *last_eval_cx = NULL;
2606 PL_lastgotoprobe = NULL;
2608 for (ix = cxstack_ix; ix >= 0; ix--) {
2610 switch (CxTYPE(cx)) {
2612 leaving_eval = TRUE;
2613 if (!CxTRYBLOCK(cx)) {
2614 gotoprobe = (last_eval_cx ?
2615 last_eval_cx->blk_eval.old_eval_root :
2620 /* else fall through */
2621 case CXt_LOOP_LAZYIV:
2622 case CXt_LOOP_LAZYSV:
2624 case CXt_LOOP_PLAIN:
2627 gotoprobe = cx->blk_oldcop->op_sibling;
2633 gotoprobe = cx->blk_oldcop->op_sibling;
2636 gotoprobe = PL_main_root;
2639 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2640 gotoprobe = CvROOT(cx->blk_sub.cv);
2646 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2649 DIE(aTHX_ "panic: goto");
2650 gotoprobe = PL_main_root;
2654 retop = dofindlabel(gotoprobe, label,
2655 enterops, enterops + GOTO_DEPTH);
2659 PL_lastgotoprobe = gotoprobe;
2662 DIE(aTHX_ "Can't find label %s", label);
2664 /* if we're leaving an eval, check before we pop any frames
2665 that we're not going to punt, otherwise the error
2668 if (leaving_eval && *enterops && enterops[1]) {
2670 for (i = 1; enterops[i]; i++)
2671 if (enterops[i]->op_type == OP_ENTERITER)
2672 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2675 /* pop unwanted frames */
2677 if (ix < cxstack_ix) {
2684 oldsave = PL_scopestack[PL_scopestack_ix];
2685 LEAVE_SCOPE(oldsave);
2688 /* push wanted frames */
2690 if (*enterops && enterops[1]) {
2691 OP * const oldop = PL_op;
2692 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2693 for (; enterops[ix]; ix++) {
2694 PL_op = enterops[ix];
2695 /* Eventually we may want to stack the needed arguments
2696 * for each op. For now, we punt on the hard ones. */
2697 if (PL_op->op_type == OP_ENTERITER)
2698 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2699 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2707 if (!retop) retop = PL_main_start;
2709 PL_restartop = retop;
2710 PL_do_undump = TRUE;
2714 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2715 PL_do_undump = FALSE;
2732 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2734 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2737 PL_exit_flags |= PERL_EXIT_EXPECTED;
2739 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2740 if (anum || !(PL_minus_c && PL_madskills))
2745 PUSHs(&PL_sv_undef);
2752 S_save_lines(pTHX_ AV *array, SV *sv)
2754 const char *s = SvPVX_const(sv);
2755 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2758 PERL_ARGS_ASSERT_SAVE_LINES;
2760 while (s && s < send) {
2762 SV * const tmpstr = newSV_type(SVt_PVMG);
2764 t = (const char *)memchr(s, '\n', send - s);
2770 sv_setpvn(tmpstr, s, t - s);
2771 av_store(array, line++, tmpstr);
2777 S_docatch(pTHX_ OP *o)
2781 OP * const oldop = PL_op;
2785 assert(CATCH_GET == TRUE);
2792 assert(cxstack_ix >= 0);
2793 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2794 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2799 /* die caught by an inner eval - continue inner loop */
2801 /* NB XXX we rely on the old popped CxEVAL still being at the top
2802 * of the stack; the way die_where() currently works, this
2803 * assumption is valid. In theory The cur_top_env value should be
2804 * returned in another global, the way retop (aka PL_restartop)
2806 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2809 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2811 PL_op = PL_restartop;
2828 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2829 /* sv Text to convert to OP tree. */
2830 /* startop op_free() this to undo. */
2831 /* code Short string id of the caller. */
2833 /* FIXME - how much of this code is common with pp_entereval? */
2834 dVAR; dSP; /* Make POPBLOCK work. */
2840 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2841 char *tmpbuf = tbuf;
2844 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2847 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2850 lex_start(sv, NULL, FALSE);
2852 /* switch to eval mode */
2854 if (IN_PERL_COMPILETIME) {
2855 SAVECOPSTASH_FREE(&PL_compiling);
2856 CopSTASH_set(&PL_compiling, PL_curstash);
2858 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2859 SV * const sv = sv_newmortal();
2860 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2861 code, (unsigned long)++PL_evalseq,
2862 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2867 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2868 (unsigned long)++PL_evalseq);
2869 SAVECOPFILE_FREE(&PL_compiling);
2870 CopFILE_set(&PL_compiling, tmpbuf+2);
2871 SAVECOPLINE(&PL_compiling);
2872 CopLINE_set(&PL_compiling, 1);
2873 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2874 deleting the eval's FILEGV from the stash before gv_check() runs
2875 (i.e. before run-time proper). To work around the coredump that
2876 ensues, we always turn GvMULTI_on for any globals that were
2877 introduced within evals. See force_ident(). GSAR 96-10-12 */
2878 safestr = savepvn(tmpbuf, len);
2879 SAVEDELETE(PL_defstash, safestr, len);
2881 #ifdef OP_IN_REGISTER
2887 /* we get here either during compilation, or via pp_regcomp at runtime */
2888 runtime = IN_PERL_RUNTIME;
2890 runcv = find_runcv(NULL);
2893 PL_op->op_type = OP_ENTEREVAL;
2894 PL_op->op_flags = 0; /* Avoid uninit warning. */
2895 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2899 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2901 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2902 POPBLOCK(cx,PL_curpm);
2905 (*startop)->op_type = OP_NULL;
2906 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2908 /* XXX DAPM do this properly one year */
2909 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2911 if (IN_PERL_COMPILETIME)
2912 CopHINTS_set(&PL_compiling, PL_hints);
2913 #ifdef OP_IN_REGISTER
2916 PERL_UNUSED_VAR(newsp);
2917 PERL_UNUSED_VAR(optype);
2919 return PL_eval_start;
2924 =for apidoc find_runcv
2926 Locate the CV corresponding to the currently executing sub or eval.
2927 If db_seqp is non_null, skip CVs that are in the DB package and populate
2928 *db_seqp with the cop sequence number at the point that the DB:: code was
2929 entered. (allows debuggers to eval in the scope of the breakpoint rather
2930 than in the scope of the debugger itself).
2936 Perl_find_runcv(pTHX_ U32 *db_seqp)
2942 *db_seqp = PL_curcop->cop_seq;
2943 for (si = PL_curstackinfo; si; si = si->si_prev) {
2945 for (ix = si->si_cxix; ix >= 0; ix--) {
2946 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2947 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2948 CV * const cv = cx->blk_sub.cv;
2949 /* skip DB:: code */
2950 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2951 *db_seqp = cx->blk_oldcop->cop_seq;
2956 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2964 /* Compile a require/do, an eval '', or a /(?{...})/.
2965 * In the last case, startop is non-null, and contains the address of
2966 * a pointer that should be set to the just-compiled code.
2967 * outside is the lexically enclosing CV (if any) that invoked us.
2968 * Returns a bool indicating whether the compile was successful; if so,
2969 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2970 * pushes undef (also croaks if startop != NULL).
2974 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2977 OP * const saveop = PL_op;
2979 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2980 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2985 SAVESPTR(PL_compcv);
2986 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2987 CvEVAL_on(PL_compcv);
2988 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2989 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2991 CvOUTSIDE_SEQ(PL_compcv) = seq;
2992 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2994 /* set up a scratch pad */
2996 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2997 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3001 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3003 /* make sure we compile in the right package */
3005 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3006 SAVESPTR(PL_curstash);
3007 PL_curstash = CopSTASH(PL_curcop);
3009 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3010 SAVESPTR(PL_beginav);
3011 PL_beginav = newAV();
3012 SAVEFREESV(PL_beginav);
3013 SAVESPTR(PL_unitcheckav);
3014 PL_unitcheckav = newAV();
3015 SAVEFREESV(PL_unitcheckav);
3018 SAVEBOOL(PL_madskills);
3022 /* try to compile it */
3024 PL_eval_root = NULL;
3025 PL_curcop = &PL_compiling;
3026 CopARYBASE_set(PL_curcop, 0);
3027 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3028 PL_in_eval |= EVAL_KEEPERR;
3031 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3032 SV **newsp; /* Used by POPBLOCK. */
3033 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3034 I32 optype = 0; /* Might be reset by POPEVAL. */
3039 op_free(PL_eval_root);
3040 PL_eval_root = NULL;
3042 SP = PL_stack_base + POPMARK; /* pop original mark */
3044 POPBLOCK(cx,PL_curpm);
3048 LEAVE; /* pp_entereval knows about this LEAVE. */
3050 msg = SvPVx_nolen_const(ERRSV);
3051 if (optype == OP_REQUIRE) {
3052 const SV * const nsv = cx->blk_eval.old_namesv;
3053 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3055 Perl_croak(aTHX_ "%sCompilation failed in require",
3056 *msg ? msg : "Unknown error\n");
3059 POPBLOCK(cx,PL_curpm);
3061 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3062 (*msg ? msg : "Unknown error\n"));
3066 sv_setpvs(ERRSV, "Compilation error");
3069 PERL_UNUSED_VAR(newsp);
3070 PUSHs(&PL_sv_undef);
3074 CopLINE_set(&PL_compiling, 0);
3076 *startop = PL_eval_root;
3078 SAVEFREEOP(PL_eval_root);
3080 /* Set the context for this new optree.
3081 * If the last op is an OP_REQUIRE, force scalar context.
3082 * Otherwise, propagate the context from the eval(). */
3083 if (PL_eval_root->op_type == OP_LEAVEEVAL
3084 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3085 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3087 scalar(PL_eval_root);
3088 else if ((gimme & G_WANT) == G_VOID)
3089 scalarvoid(PL_eval_root);
3090 else if ((gimme & G_WANT) == G_ARRAY)
3093 scalar(PL_eval_root);
3095 DEBUG_x(dump_eval());
3097 /* Register with debugger: */
3098 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3099 CV * const cv = get_cvs("DB::postponed", 0);
3103 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3105 call_sv(MUTABLE_SV(cv), G_DISCARD);
3110 call_list(PL_scopestack_ix, PL_unitcheckav);
3112 /* compiled okay, so do it */
3114 CvDEPTH(PL_compcv) = 1;
3115 SP = PL_stack_base + POPMARK; /* pop original mark */
3116 PL_op = saveop; /* The caller may need it. */
3117 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3124 S_check_type_and_open(pTHX_ const char *name)
3127 const int st_rc = PerlLIO_stat(name, &st);
3129 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3131 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3135 return PerlIO_open(name, PERL_SCRIPT_MODE);
3138 #ifndef PERL_DISABLE_PMC
3140 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3144 PERL_ARGS_ASSERT_DOOPEN_PM;
3146 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3147 SV *const pmcsv = newSV(namelen + 2);
3148 char *const pmc = SvPVX(pmcsv);
3151 memcpy(pmc, name, namelen);
3153 pmc[namelen + 1] = '\0';
3155 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3156 fp = check_type_and_open(name);
3159 fp = check_type_and_open(pmc);
3161 SvREFCNT_dec(pmcsv);
3164 fp = check_type_and_open(name);
3169 # define doopen_pm(name, namelen) check_type_and_open(name)
3170 #endif /* !PERL_DISABLE_PMC */
3175 register PERL_CONTEXT *cx;
3182 int vms_unixname = 0;
3184 const char *tryname = NULL;
3186 const I32 gimme = GIMME_V;
3187 int filter_has_file = 0;
3188 PerlIO *tryrsfp = NULL;
3189 SV *filter_cache = NULL;
3190 SV *filter_state = NULL;
3191 SV *filter_sub = NULL;
3197 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3198 sv = new_version(sv);
3199 if (!sv_derived_from(PL_patchlevel, "version"))
3200 upg_version(PL_patchlevel, TRUE);
3201 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3202 if ( vcmp(sv,PL_patchlevel) <= 0 )
3203 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3204 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3207 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3210 SV * const req = SvRV(sv);
3211 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3213 /* get the left hand term */
3214 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3216 first = SvIV(*av_fetch(lav,0,0));
3217 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3218 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3219 || av_len(lav) > 1 /* FP with > 3 digits */
3220 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3222 DIE(aTHX_ "Perl %"SVf" required--this is only "
3223 "%"SVf", stopped", SVfARG(vnormal(req)),
3224 SVfARG(vnormal(PL_patchlevel)));
3226 else { /* probably 'use 5.10' or 'use 5.8' */
3227 SV * hintsv = newSV(0);
3231 second = SvIV(*av_fetch(lav,1,0));
3233 second /= second >= 600 ? 100 : 10;
3234 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3235 (int)first, (int)second,0);
3236 upg_version(hintsv, TRUE);
3238 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3239 "--this is only %"SVf", stopped",
3240 SVfARG(vnormal(req)),
3241 SVfARG(vnormal(hintsv)),
3242 SVfARG(vnormal(PL_patchlevel)));
3247 /* We do this only with use, not require. */
3249 /* If we request a version >= 5.9.5, load feature.pm with the
3250 * feature bundle that corresponds to the required version. */
3251 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3252 SV *const importsv = vnormal(sv);
3253 *SvPVX_mutable(importsv) = ':';
3255 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3258 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3260 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3261 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3266 name = SvPV_const(sv, len);
3267 if (!(name && len > 0 && *name))
3268 DIE(aTHX_ "Null filename used");
3269 TAINT_PROPER("require");
3273 /* The key in the %ENV hash is in the syntax of file passed as the argument
3274 * usually this is in UNIX format, but sometimes in VMS format, which
3275 * can result in a module being pulled in more than once.
3276 * To prevent this, the key must be stored in UNIX format if the VMS
3277 * name can be translated to UNIX.
3279 if ((unixname = tounixspec(name, NULL)) != NULL) {
3280 unixlen = strlen(unixname);
3286 /* if not VMS or VMS name can not be translated to UNIX, pass it
3289 unixname = (char *) name;
3292 if (PL_op->op_type == OP_REQUIRE) {
3293 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3294 unixname, unixlen, 0);
3296 if (*svp != &PL_sv_undef)
3299 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3300 "Compilation failed in require", unixname);
3304 /* prepare to compile file */
3306 if (path_is_absolute(name)) {
3308 tryrsfp = doopen_pm(name, len);
3311 AV * const ar = GvAVn(PL_incgv);
3317 namesv = newSV_type(SVt_PV);
3318 for (i = 0; i <= AvFILL(ar); i++) {
3319 SV * const dirsv = *av_fetch(ar, i, TRUE);
3321 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3328 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3329 && !sv_isobject(loader))
3331 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3334 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3335 PTR2UV(SvRV(dirsv)), name);
3336 tryname = SvPVX_const(namesv);
3347 if (sv_isobject(loader))
3348 count = call_method("INC", G_ARRAY);
3350 count = call_sv(loader, G_ARRAY);
3353 /* Adjust file name if the hook has set an %INC entry */
3354 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3356 tryname = SvPV_nolen_const(*svp);
3365 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3366 && !isGV_with_GP(SvRV(arg))) {
3367 filter_cache = SvRV(arg);
3368 SvREFCNT_inc_simple_void_NN(filter_cache);
3375 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3379 if (isGV_with_GP(arg)) {
3380 IO * const io = GvIO((const GV *)arg);
3385 tryrsfp = IoIFP(io);
3386 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3387 PerlIO_close(IoOFP(io));
3398 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3400 SvREFCNT_inc_simple_void_NN(filter_sub);
3403 filter_state = SP[i];
3404 SvREFCNT_inc_simple_void(filter_state);
3408 if (!tryrsfp && (filter_cache || filter_sub)) {
3409 tryrsfp = PerlIO_open(BIT_BUCKET,
3424 filter_has_file = 0;
3426 SvREFCNT_dec(filter_cache);
3427 filter_cache = NULL;
3430 SvREFCNT_dec(filter_state);
3431 filter_state = NULL;
3434 SvREFCNT_dec(filter_sub);
3439 if (!path_is_absolute(name)
3445 dir = SvPV_const(dirsv, dirlen);
3453 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3455 sv_setpv(namesv, unixdir);
3456 sv_catpv(namesv, unixname);
3458 # ifdef __SYMBIAN32__
3459 if (PL_origfilename[0] &&
3460 PL_origfilename[1] == ':' &&
3461 !(dir[0] && dir[1] == ':'))
3462 Perl_sv_setpvf(aTHX_ namesv,
3467 Perl_sv_setpvf(aTHX_ namesv,
3471 /* The equivalent of
3472 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3473 but without the need to parse the format string, or
3474 call strlen on either pointer, and with the correct
3475 allocation up front. */
3477 char *tmp = SvGROW(namesv, dirlen + len + 2);
3479 memcpy(tmp, dir, dirlen);
3482 /* name came from an SV, so it will have a '\0' at the
3483 end that we can copy as part of this memcpy(). */
3484 memcpy(tmp, name, len + 1);
3486 SvCUR_set(namesv, dirlen + len + 1);
3488 /* Don't even actually have to turn SvPOK_on() as we
3489 access it directly with SvPVX() below. */
3493 TAINT_PROPER("require");
3494 tryname = SvPVX_const(namesv);
3495 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3497 if (tryname[0] == '.' && tryname[1] == '/') {
3499 while (*++tryname == '/');
3503 else if (errno == EMFILE)
3504 /* no point in trying other paths if out of handles */
3511 SAVECOPFILE_FREE(&PL_compiling);
3512 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3513 SvREFCNT_dec(namesv);
3515 if (PL_op->op_type == OP_REQUIRE) {
3516 const char *msgstr = name;
3517 if(errno == EMFILE) {
3519 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3521 msgstr = SvPV_nolen_const(msg);
3523 if (namesv) { /* did we lookup @INC? */
3524 AV * const ar = GvAVn(PL_incgv);
3526 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3527 "%s in @INC%s%s (@INC contains:",
3529 (instr(msgstr, ".h ")
3530 ? " (change .h to .ph maybe?)" : ""),
3531 (instr(msgstr, ".ph ")
3532 ? " (did you run h2ph?)" : "")
3535 for (i = 0; i <= AvFILL(ar); i++) {
3536 sv_catpvs(msg, " ");
3537 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3539 sv_catpvs(msg, ")");
3540 msgstr = SvPV_nolen_const(msg);
3543 DIE(aTHX_ "Can't locate %s", msgstr);
3549 SETERRNO(0, SS_NORMAL);
3551 /* Assume success here to prevent recursive requirement. */
3552 /* name is never assigned to again, so len is still strlen(name) */
3553 /* Check whether a hook in @INC has already filled %INC */
3555 (void)hv_store(GvHVn(PL_incgv),
3556 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3558 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3560 (void)hv_store(GvHVn(PL_incgv),
3561 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3566 lex_start(NULL, tryrsfp, TRUE);
3570 hv_clear(GvHV(PL_hintgv));
3572 SAVECOMPILEWARNINGS();
3573 if (PL_dowarn & G_WARN_ALL_ON)
3574 PL_compiling.cop_warnings = pWARN_ALL ;
3575 else if (PL_dowarn & G_WARN_ALL_OFF)
3576 PL_compiling.cop_warnings = pWARN_NONE ;
3578 PL_compiling.cop_warnings = pWARN_STD ;
3580 if (filter_sub || filter_cache) {
3581 SV * const datasv = filter_add(S_run_user_filter, NULL);
3582 IoLINES(datasv) = filter_has_file;
3583 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3584 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3585 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3588 /* switch to eval mode */
3589 PUSHBLOCK(cx, CXt_EVAL, SP);
3591 cx->blk_eval.retop = PL_op->op_next;
3593 SAVECOPLINE(&PL_compiling);
3594 CopLINE_set(&PL_compiling, 0);
3598 /* Store and reset encoding. */
3599 encoding = PL_encoding;
3602 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3603 op = DOCATCH(PL_eval_start);
3605 op = PL_op->op_next;
3607 /* Restore encoding. */
3608 PL_encoding = encoding;
3613 /* This is a op added to hold the hints hash for
3614 pp_entereval. The hash can be modified by the code
3615 being eval'ed, so we return a copy instead. */
3621 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3629 register PERL_CONTEXT *cx;
3631 const I32 gimme = GIMME_V;
3632 const U32 was = PL_breakable_sub_gen;
3633 char tbuf[TYPE_DIGITS(long) + 12];
3634 char *tmpbuf = tbuf;
3638 HV *saved_hh = NULL;
3640 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3641 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3645 TAINT_IF(SvTAINTED(sv));
3646 TAINT_PROPER("eval");
3649 lex_start(sv, NULL, FALSE);
3652 /* switch to eval mode */
3654 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3655 SV * const temp_sv = sv_newmortal();
3656 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3657 (unsigned long)++PL_evalseq,
3658 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3659 tmpbuf = SvPVX(temp_sv);
3660 len = SvCUR(temp_sv);
3663 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3664 SAVECOPFILE_FREE(&PL_compiling);
3665 CopFILE_set(&PL_compiling, tmpbuf+2);
3666 SAVECOPLINE(&PL_compiling);
3667 CopLINE_set(&PL_compiling, 1);
3668 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3669 deleting the eval's FILEGV from the stash before gv_check() runs
3670 (i.e. before run-time proper). To work around the coredump that
3671 ensues, we always turn GvMULTI_on for any globals that were
3672 introduced within evals. See force_ident(). GSAR 96-10-12 */
3674 PL_hints = PL_op->op_targ;
3676 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3677 SvREFCNT_dec(GvHV(PL_hintgv));
3678 GvHV(PL_hintgv) = saved_hh;
3680 SAVECOMPILEWARNINGS();
3681 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3682 if (PL_compiling.cop_hints_hash) {
3683 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3685 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3686 if (PL_compiling.cop_hints_hash) {
3688 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3689 HINTS_REFCNT_UNLOCK;
3691 /* special case: an eval '' executed within the DB package gets lexically
3692 * placed in the first non-DB CV rather than the current CV - this
3693 * allows the debugger to execute code, find lexicals etc, in the
3694 * scope of the code being debugged. Passing &seq gets find_runcv
3695 * to do the dirty work for us */
3696 runcv = find_runcv(&seq);
3698 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3700 cx->blk_eval.retop = PL_op->op_next;
3702 /* prepare to compile string */
3704 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3705 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3708 if (doeval(gimme, NULL, runcv, seq)) {
3709 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3710 ? (PERLDB_LINE || PERLDB_SAVESRC)
3711 : PERLDB_SAVESRC_NOSUBS) {
3712 /* Retain the filegv we created. */
3714 char *const safestr = savepvn(tmpbuf, len);
3715 SAVEDELETE(PL_defstash, safestr, len);
3717 return DOCATCH(PL_eval_start);
3719 /* We have already left the scope set up earler thanks to the LEAVE
3721 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3722 ? (PERLDB_LINE || PERLDB_SAVESRC)
3723 : PERLDB_SAVESRC_INVALID) {
3724 /* Retain the filegv we created. */
3726 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3728 return PL_op->op_next;
3739 register PERL_CONTEXT *cx;
3741 const U8 save_flags = PL_op -> op_flags;
3746 retop = cx->blk_eval.retop;
3749 if (gimme == G_VOID)
3751 else if (gimme == G_SCALAR) {
3754 if (SvFLAGS(TOPs) & SVs_TEMP)
3757 *MARK = sv_mortalcopy(TOPs);
3761 *MARK = &PL_sv_undef;
3766 /* in case LEAVE wipes old return values */
3767 for (mark = newsp + 1; mark <= SP; mark++) {
3768 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3769 *mark = sv_mortalcopy(*mark);
3770 TAINT_NOT; /* Each item is independent */
3774 PL_curpm = newpm; /* Don't pop $1 et al till now */
3777 assert(CvDEPTH(PL_compcv) == 1);
3779 CvDEPTH(PL_compcv) = 0;
3782 if (optype == OP_REQUIRE &&
3783 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3785 /* Unassume the success we assumed earlier. */
3786 SV * const nsv = cx->blk_eval.old_namesv;
3787 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3788 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3789 /* die_where() did LEAVE, or we won't be here */
3793 if (!(save_flags & OPf_SPECIAL)) {
3801 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3802 close to the related Perl_create_eval_scope. */
3804 Perl_delete_eval_scope(pTHX)
3809 register PERL_CONTEXT *cx;
3816 PERL_UNUSED_VAR(newsp);
3817 PERL_UNUSED_VAR(gimme);
3818 PERL_UNUSED_VAR(optype);
3821 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3822 also needed by Perl_fold_constants. */
3824 Perl_create_eval_scope(pTHX_ U32 flags)
3827 const I32 gimme = GIMME_V;
3832 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3835 PL_in_eval = EVAL_INEVAL;
3836 if (flags & G_KEEPERR)
3837 PL_in_eval |= EVAL_KEEPERR;
3840 if (flags & G_FAKINGEVAL) {
3841 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3849 PERL_CONTEXT * const cx = create_eval_scope(0);
3850 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3851 return DOCATCH(PL_op->op_next);
3860 register PERL_CONTEXT *cx;
3865 PERL_UNUSED_VAR(optype);
3868 if (gimme == G_VOID)
3870 else if (gimme == G_SCALAR) {
3874 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3877 *MARK = sv_mortalcopy(TOPs);
3881 *MARK = &PL_sv_undef;
3886 /* in case LEAVE wipes old return values */
3888 for (mark = newsp + 1; mark <= SP; mark++) {
3889 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3890 *mark = sv_mortalcopy(*mark);
3891 TAINT_NOT; /* Each item is independent */
3895 PL_curpm = newpm; /* Don't pop $1 et al till now */
3905 register PERL_CONTEXT *cx;
3906 const I32 gimme = GIMME_V;
3911 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3913 PUSHBLOCK(cx, CXt_GIVEN, SP);
3922 register PERL_CONTEXT *cx;
3926 PERL_UNUSED_CONTEXT;
3929 assert(CxTYPE(cx) == CXt_GIVEN);
3934 PL_curpm = newpm; /* pop $1 et al */
3941 /* Helper routines used by pp_smartmatch */
3943 S_make_matcher(pTHX_ REGEXP *re)
3946 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3948 PERL_ARGS_ASSERT_MAKE_MATCHER;
3950 PM_SETRE(matcher, ReREFCNT_inc(re));
3952 SAVEFREEOP((OP *) matcher);
3959 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3964 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3966 PL_op = (OP *) matcher;
3971 return (SvTRUEx(POPs));
3975 S_destroy_matcher(pTHX_ PMOP *matcher)
3979 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3980 PERL_UNUSED_ARG(matcher);
3986 /* Do a smart match */
3989 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
3990 return do_smartmatch(NULL, NULL);
3993 /* This version of do_smartmatch() implements the
3994 * table of smart matches that is found in perlsyn.
3997 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4002 bool object_on_left = FALSE;
4003 SV *e = TOPs; /* e is for 'expression' */
4004 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4006 /* First of all, handle overload magic of the rightmost argument */
4009 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4010 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4012 tmpsv = amagic_call(d, e, smart_amg, 0);
4019 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4022 SP -= 2; /* Pop the values */
4024 /* Take care only to invoke mg_get() once for each argument.
4025 * Currently we do this by copying the SV if it's magical. */
4028 d = sv_mortalcopy(d);
4035 e = sv_mortalcopy(e);
4039 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4046 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4047 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4048 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4050 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4051 object_on_left = TRUE;
4054 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4056 if (object_on_left) {
4057 goto sm_any_sub; /* Treat objects like scalars */
4059 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4060 /* Test sub truth for each key */
4062 bool andedresults = TRUE;
4063 HV *hv = (HV*) SvRV(d);
4064 I32 numkeys = hv_iterinit(hv);
4065 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4068 while ( (he = hv_iternext(hv)) ) {
4069 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4073 PUSHs(hv_iterkeysv(he));
4075 c = call_sv(e, G_SCALAR);
4078 andedresults = FALSE;
4080 andedresults = SvTRUEx(POPs) && andedresults;
4089 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4090 /* Test sub truth for each element */
4092 bool andedresults = TRUE;
4093 AV *av = (AV*) SvRV(d);
4094 const I32 len = av_len(av);
4095 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4098 for (i = 0; i <= len; ++i) {
4099 SV * const * const svp = av_fetch(av, i, FALSE);
4100 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4107 c = call_sv(e, G_SCALAR);
4110 andedresults = FALSE;
4112 andedresults = SvTRUEx(POPs) && andedresults;
4123 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4129 c = call_sv(e, G_SCALAR);
4133 else if (SvTEMP(TOPs))
4134 SvREFCNT_inc_void(TOPs);
4141 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4142 if (object_on_left) {
4143 goto sm_any_hash; /* Treat objects like scalars */
4145 else if (!SvOK(d)) {
4146 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4149 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4150 /* Check that the key-sets are identical */
4152 HV *other_hv = MUTABLE_HV(SvRV(d));
4154 bool other_tied = FALSE;
4155 U32 this_key_count = 0,
4156 other_key_count = 0;
4157 HV *hv = MUTABLE_HV(SvRV(e));
4159 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4160 /* Tied hashes don't know how many keys they have. */
4161 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4164 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4165 HV * const temp = other_hv;
4170 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4173 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4176 /* The hashes have the same number of keys, so it suffices
4177 to check that one is a subset of the other. */
4178 (void) hv_iterinit(hv);
4179 while ( (he = hv_iternext(hv)) ) {
4180 SV *key = hv_iterkeysv(he);
4182 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4185 if(!hv_exists_ent(other_hv, key, 0)) {
4186 (void) hv_iterinit(hv); /* reset iterator */
4192 (void) hv_iterinit(other_hv);
4193 while ( hv_iternext(other_hv) )
4197 other_key_count = HvUSEDKEYS(other_hv);
4199 if (this_key_count != other_key_count)
4204 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4205 AV * const other_av = MUTABLE_AV(SvRV(d));
4206 const I32 other_len = av_len(other_av) + 1;
4208 HV *hv = MUTABLE_HV(SvRV(e));
4210 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4211 for (i = 0; i < other_len; ++i) {
4212 SV ** const svp = av_fetch(other_av, i, FALSE);
4213 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4214 if (svp) { /* ??? When can this not happen? */
4215 if (hv_exists_ent(hv, *svp, 0))
4221 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4222 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4225 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4227 HV *hv = MUTABLE_HV(SvRV(e));
4229 (void) hv_iterinit(hv);
4230 while ( (he = hv_iternext(hv)) ) {
4231 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4232 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4233 (void) hv_iterinit(hv);
4234 destroy_matcher(matcher);
4238 destroy_matcher(matcher);
4244 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4245 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4252 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4253 if (object_on_left) {
4254 goto sm_any_array; /* Treat objects like scalars */
4256 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4257 AV * const other_av = MUTABLE_AV(SvRV(e));
4258 const I32 other_len = av_len(other_av) + 1;
4261 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4262 for (i = 0; i < other_len; ++i) {
4263 SV ** const svp = av_fetch(other_av, i, FALSE);
4265 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4266 if (svp) { /* ??? When can this not happen? */
4267 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4273 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4274 AV *other_av = MUTABLE_AV(SvRV(d));
4275 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4276 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4280 const I32 other_len = av_len(other_av);
4282 if (NULL == seen_this) {
4283 seen_this = newHV();
4284 (void) sv_2mortal(MUTABLE_SV(seen_this));
4286 if (NULL == seen_other) {
4287 seen_this = newHV();
4288 (void) sv_2mortal(MUTABLE_SV(seen_other));
4290 for(i = 0; i <= other_len; ++i) {
4291 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4292 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4294 if (!this_elem || !other_elem) {
4295 if (this_elem || other_elem)
4298 else if (hv_exists_ent(seen_this,
4299 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4300 hv_exists_ent(seen_other,
4301 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4303 if (*this_elem != *other_elem)
4307 (void)hv_store_ent(seen_this,
4308 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4310 (void)hv_store_ent(seen_other,
4311 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4317 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4318 (void) do_smartmatch(seen_this, seen_other);
4320 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4329 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4330 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4333 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4334 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4337 for(i = 0; i <= this_len; ++i) {
4338 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4339 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4340 if (svp && matcher_matches_sv(matcher, *svp)) {
4341 destroy_matcher(matcher);
4345 destroy_matcher(matcher);
4349 else if (!SvOK(d)) {
4350 /* undef ~~ array */
4351 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4354 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4355 for (i = 0; i <= this_len; ++i) {
4356 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4357 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4358 if (!svp || !SvOK(*svp))
4367 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4369 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4370 for (i = 0; i <= this_len; ++i) {
4371 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4378 /* infinite recursion isn't supposed to happen here */
4379 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4380 (void) do_smartmatch(NULL, NULL);
4382 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4391 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4392 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4393 SV *t = d; d = e; e = t;
4394 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4397 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4398 SV *t = d; d = e; e = t;
4399 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4400 goto sm_regex_array;
4403 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4405 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4407 PUSHs(matcher_matches_sv(matcher, d)
4410 destroy_matcher(matcher);
4415 /* See if there is overload magic on left */
4416 else if (object_on_left && SvAMAGIC(d)) {
4418 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4419 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4422 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4430 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4433 else if (!SvOK(d)) {
4434 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4435 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4440 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4441 DEBUG_M(if (SvNIOK(e))
4442 Perl_deb(aTHX_ " applying rule Any-Num\n");
4444 Perl_deb(aTHX_ " applying rule Num-numish\n");
4446 /* numeric comparison */
4449 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4460 /* As a last resort, use string comparison */
4461 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4470 register PERL_CONTEXT *cx;
4471 const I32 gimme = GIMME_V;
4473 /* This is essentially an optimization: if the match
4474 fails, we don't want to push a context and then
4475 pop it again right away, so we skip straight
4476 to the op that follows the leavewhen.
4478 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4479 return cLOGOP->op_other->op_next;
4484 PUSHBLOCK(cx, CXt_WHEN, SP);
4493 register PERL_CONTEXT *cx;
4499 assert(CxTYPE(cx) == CXt_WHEN);
4504 PL_curpm = newpm; /* pop $1 et al */
4514 register PERL_CONTEXT *cx;
4517 cxix = dopoptowhen(cxstack_ix);
4519 DIE(aTHX_ "Can't \"continue\" outside a when block");
4520 if (cxix < cxstack_ix)
4523 /* clear off anything above the scope we're re-entering */
4524 inner = PL_scopestack_ix;
4526 if (PL_scopestack_ix < inner)
4527 leave_scope(PL_scopestack[PL_scopestack_ix]);
4528 PL_curcop = cx->blk_oldcop;
4529 return cx->blk_givwhen.leave_op;
4536 register PERL_CONTEXT *cx;
4539 cxix = dopoptogiven(cxstack_ix);
4541 if (PL_op->op_flags & OPf_SPECIAL)
4542 DIE(aTHX_ "Can't use when() outside a topicalizer");
4544 DIE(aTHX_ "Can't \"break\" outside a given block");
4546 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4547 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4549 if (cxix < cxstack_ix)
4552 /* clear off anything above the scope we're re-entering */
4553 inner = PL_scopestack_ix;
4555 if (PL_scopestack_ix < inner)
4556 leave_scope(PL_scopestack[PL_scopestack_ix]);
4557 PL_curcop = cx->blk_oldcop;
4560 return CX_LOOP_NEXTOP_GET(cx);
4562 return cx->blk_givwhen.leave_op;
4566 S_doparseform(pTHX_ SV *sv)
4569 register char *s = SvPV_force(sv, len);
4570 register char * const send = s + len;
4571 register char *base = NULL;
4572 register I32 skipspaces = 0;
4573 bool noblank = FALSE;
4574 bool repeat = FALSE;
4575 bool postspace = FALSE;
4581 bool unchopnum = FALSE;
4582 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4584 PERL_ARGS_ASSERT_DOPARSEFORM;
4587 Perl_croak(aTHX_ "Null picture in formline");
4589 /* estimate the buffer size needed */
4590 for (base = s; s <= send; s++) {
4591 if (*s == '\n' || *s == '@' || *s == '^')
4597 Newx(fops, maxops, U32);
4602 *fpc++ = FF_LINEMARK;
4603 noblank = repeat = FALSE;
4621 case ' ': case '\t':
4628 } /* else FALL THROUGH */
4636 *fpc++ = FF_LITERAL;
4644 *fpc++ = (U16)skipspaces;
4648 *fpc++ = FF_NEWLINE;
4652 arg = fpc - linepc + 1;
4659 *fpc++ = FF_LINEMARK;
4660 noblank = repeat = FALSE;
4669 ischop = s[-1] == '^';
4675 arg = (s - base) - 1;
4677 *fpc++ = FF_LITERAL;
4685 *fpc++ = 2; /* skip the @* or ^* */
4687 *fpc++ = FF_LINESNGL;
4690 *fpc++ = FF_LINEGLOB;
4692 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4693 arg = ischop ? 512 : 0;
4698 const char * const f = ++s;
4701 arg |= 256 + (s - f);
4703 *fpc++ = s - base; /* fieldsize for FETCH */
4704 *fpc++ = FF_DECIMAL;
4706 unchopnum |= ! ischop;
4708 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4709 arg = ischop ? 512 : 0;
4711 s++; /* skip the '0' first */
4715 const char * const f = ++s;
4718 arg |= 256 + (s - f);
4720 *fpc++ = s - base; /* fieldsize for FETCH */
4721 *fpc++ = FF_0DECIMAL;
4723 unchopnum |= ! ischop;
4727 bool ismore = FALSE;
4730 while (*++s == '>') ;
4731 prespace = FF_SPACE;
4733 else if (*s == '|') {
4734 while (*++s == '|') ;
4735 prespace = FF_HALFSPACE;
4740 while (*++s == '<') ;
4743 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4747 *fpc++ = s - base; /* fieldsize for FETCH */
4749 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4752 *fpc++ = (U16)prespace;
4766 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4768 { /* need to jump to the next word */
4770 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4771 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4772 s = SvPVX(sv) + SvCUR(sv) + z;
4774 Copy(fops, s, arg, U32);
4776 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4779 if (unchopnum && repeat)
4780 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4786 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4788 /* Can value be printed in fldsize chars, using %*.*f ? */
4792 int intsize = fldsize - (value < 0 ? 1 : 0);
4799 while (intsize--) pwr *= 10.0;
4800 while (frcsize--) eps /= 10.0;
4803 if (value + eps >= pwr)
4806 if (value - eps <= -pwr)
4813 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4816 SV * const datasv = FILTER_DATA(idx);
4817 const int filter_has_file = IoLINES(datasv);
4818 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4819 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4823 const char *got_p = NULL;
4824 const char *prune_from = NULL;
4825 bool read_from_cache = FALSE;
4828 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4830 assert(maxlen >= 0);
4833 /* I was having segfault trouble under Linux 2.2.5 after a
4834 parse error occured. (Had to hack around it with a test
4835 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4836 not sure where the trouble is yet. XXX */
4838 if (IoFMT_GV(datasv)) {
4839 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4842 const char *cache_p = SvPV(cache, cache_len);
4846 /* Running in block mode and we have some cached data already.
4848 if (cache_len >= umaxlen) {
4849 /* In fact, so much data we don't even need to call
4854 const char *const first_nl =
4855 (const char *)memchr(cache_p, '\n', cache_len);
4857 take = first_nl + 1 - cache_p;
4861 sv_catpvn(buf_sv, cache_p, take);
4862 sv_chop(cache, cache_p + take);
4863 /* Definately not EOF */
4867 sv_catsv(buf_sv, cache);
4869 umaxlen -= cache_len;
4872 read_from_cache = TRUE;
4876 /* Filter API says that the filter appends to the contents of the buffer.
4877 Usually the buffer is "", so the details don't matter. But if it's not,
4878 then clearly what it contains is already filtered by this filter, so we
4879 don't want to pass it in a second time.
4880 I'm going to use a mortal in case the upstream filter croaks. */
4881 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4882 ? sv_newmortal() : buf_sv;
4883 SvUPGRADE(upstream, SVt_PV);
4885 if (filter_has_file) {
4886 status = FILTER_READ(idx+1, upstream, 0);
4889 if (filter_sub && status >= 0) {
4898 DEFSV_set(upstream);
4902 PUSHs(filter_state);
4905 count = call_sv(filter_sub, G_SCALAR);
4920 if(SvOK(upstream)) {
4921 got_p = SvPV(upstream, got_len);
4923 if (got_len > umaxlen) {
4924 prune_from = got_p + umaxlen;
4927 const char *const first_nl =
4928 (const char *)memchr(got_p, '\n', got_len);
4929 if (first_nl && first_nl + 1 < got_p + got_len) {
4930 /* There's a second line here... */
4931 prune_from = first_nl + 1;
4936 /* Oh. Too long. Stuff some in our cache. */
4937 STRLEN cached_len = got_p + got_len - prune_from;
4938 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4941 IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4942 } else if (SvOK(cache)) {
4943 /* Cache should be empty. */
4944 assert(!SvCUR(cache));
4947 sv_setpvn(cache, prune_from, cached_len);
4948 /* If you ask for block mode, you may well split UTF-8 characters.
4949 "If it breaks, you get to keep both parts"
4950 (Your code is broken if you don't put them back together again
4951 before something notices.) */
4952 if (SvUTF8(upstream)) {
4955 SvCUR_set(upstream, got_len - cached_len);
4956 /* Can't yet be EOF */
4961 /* If they are at EOF but buf_sv has something in it, then they may never
4962 have touched the SV upstream, so it may be undefined. If we naively
4963 concatenate it then we get a warning about use of uninitialised value.
4965 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4966 sv_catsv(buf_sv, upstream);
4970 IoLINES(datasv) = 0;
4971 SvREFCNT_dec(IoFMT_GV(datasv));
4973 SvREFCNT_dec(filter_state);
4974 IoTOP_GV(datasv) = NULL;
4977 SvREFCNT_dec(filter_sub);
4978 IoBOTTOM_GV(datasv) = NULL;
4980 filter_del(S_run_user_filter);
4982 if (status == 0 && read_from_cache) {
4983 /* If we read some data from the cache (and by getting here it implies
4984 that we emptied the cache) then we aren't yet at EOF, and mustn't
4985 report that to our caller. */
4991 /* perhaps someone can come up with a better name for
4992 this? it is not really "absolute", per se ... */
4994 S_path_is_absolute(const char *name)
4996 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4998 if (PERL_FILE_IS_ABSOLUTE(name)
5000 || (*name == '.' && ((name[1] == '/' ||
5001 (name[1] == '.' && name[2] == '/'))
5002 || (name[1] == '\\' ||
5003 ( name[1] == '.' && name[2] == '\\')))
5006 || (*name == '.' && (name[1] == '/' ||
5007 (name[1] == '.' && name[2] == '/')))
5019 * c-indentation-style: bsd
5021 * indent-tabs-mode: t
5024 * ex: set ts=8 sts=4 sw=4 noet: