3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
49 cxix = dopoptosub(cxstack_ix);
53 switch (cxstack[cxix].blk_gimme) {
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 MAGIC *mg = Null(MAGIC*);
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_setpvn(tmpstr, "", 0);
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 *sv = SvRV(tmpstr);
122 mg = mg_find(sv, PERL_MAGIC_qr);
125 regexp * const re = (regexp *)mg->mg_obj;
126 ReREFCNT_dec(PM_GETRE(pm));
127 PM_SETRE(pm, ReREFCNT_inc(re));
131 const char *t = SvPV_const(tmpstr, len);
133 /* Check against the last compiled regexp. */
134 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
135 PM_GETRE(pm)->prelen != (I32)len ||
136 memNE(PM_GETRE(pm)->precomp, t, len))
139 ReREFCNT_dec(PM_GETRE(pm));
140 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
142 if (PL_op->op_flags & OPf_SPECIAL)
143 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
145 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
147 pm->op_pmdynflags |= PMdf_DYN_UTF8;
149 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
150 if (pm->op_pmdynflags & PMdf_UTF8)
151 t = (char*)bytes_to_utf8((U8*)t, &len);
153 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
154 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
156 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
157 inside tie/overload accessors. */
161 #ifndef INCOMPLETE_TAINTS
164 pm->op_pmdynflags |= PMdf_TAINTED;
166 pm->op_pmdynflags &= ~PMdf_TAINTED;
170 if (!PM_GETRE(pm)->prelen && PL_curpm)
172 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
173 pm->op_pmflags |= PMf_WHITE;
175 pm->op_pmflags &= ~PMf_WHITE;
177 /* XXX runtime compiled output needs to move to the pad */
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 #if !defined(USE_ITHREADS)
181 /* XXX can't change the optree at runtime either */
182 cLOGOP->op_first->op_next = PL_op->op_next;
191 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
192 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
193 register SV * const dstr = cx->sb_dstr;
194 register char *s = cx->sb_s;
195 register char *m = cx->sb_m;
196 char *orig = cx->sb_orig;
197 register REGEXP * const rx = cx->sb_rx;
199 REGEXP *old = PM_GETRE(pm);
206 rxres_restore(&cx->sb_rxres, rx);
207 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
209 if (cx->sb_iters++) {
210 const I32 saviters = cx->sb_iters;
211 if (cx->sb_iters > cx->sb_maxiters)
212 DIE(aTHX_ "Substitution loop");
214 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
215 cx->sb_rxtainted |= 2;
216 sv_catsv(dstr, POPs);
219 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
220 s == m, cx->sb_targ, NULL,
221 ((cx->sb_rflags & REXEC_COPY_STR)
222 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
223 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
225 SV * const targ = cx->sb_targ;
227 assert(cx->sb_strend >= s);
228 if(cx->sb_strend > s) {
229 if (DO_UTF8(dstr) && !SvUTF8(targ))
230 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
232 sv_catpvn(dstr, s, cx->sb_strend - s);
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
236 #ifdef PERL_OLD_COPY_ON_WRITE
238 sv_force_normal_flags(targ, SV_COW_DROP_PV);
244 SvPV_set(targ, SvPVX(dstr));
245 SvCUR_set(targ, SvCUR(dstr));
246 SvLEN_set(targ, SvLEN(dstr));
249 SvPV_set(dstr, (char*)0);
252 TAINT_IF(cx->sb_rxtainted & 1);
253 PUSHs(sv_2mortal(newSViv(saviters - 1)));
255 (void)SvPOK_only_UTF8(targ);
256 TAINT_IF(cx->sb_rxtainted);
260 LEAVE_SCOPE(cx->sb_oldsave);
263 RETURNOP(pm->op_next);
265 cx->sb_iters = saviters;
267 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
270 cx->sb_orig = orig = rx->subbeg;
272 cx->sb_strend = s + (cx->sb_strend - m);
274 cx->sb_m = m = rx->startp[0] + orig;
276 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
277 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
279 sv_catpvn(dstr, s, m-s);
281 cx->sb_s = rx->endp[0] + orig;
282 { /* Update the pos() information. */
283 SV * const sv = cx->sb_targ;
286 if (SvTYPE(sv) < SVt_PVMG)
287 SvUPGRADE(sv, SVt_PVMG);
288 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
289 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
290 mg = mg_find(sv, PERL_MAGIC_regex_global);
298 (void)ReREFCNT_inc(rx);
299 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
300 rxres_save(&cx->sb_rxres, rx);
301 RETURNOP(pm->op_pmreplstart);
305 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
310 if (!p || p[1] < rx->nparens) {
311 #ifdef PERL_OLD_COPY_ON_WRITE
312 i = 7 + rx->nparens * 2;
314 i = 6 + rx->nparens * 2;
323 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
324 RX_MATCH_COPIED_off(rx);
326 #ifdef PERL_OLD_COPY_ON_WRITE
327 *p++ = PTR2UV(rx->saved_copy);
328 rx->saved_copy = Nullsv;
333 *p++ = PTR2UV(rx->subbeg);
334 *p++ = (UV)rx->sublen;
335 for (i = 0; i <= rx->nparens; ++i) {
336 *p++ = (UV)rx->startp[i];
337 *p++ = (UV)rx->endp[i];
342 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
347 RX_MATCH_COPY_FREE(rx);
348 RX_MATCH_COPIED_set(rx, *p);
351 #ifdef PERL_OLD_COPY_ON_WRITE
353 SvREFCNT_dec (rx->saved_copy);
354 rx->saved_copy = INT2PTR(SV*,*p);
360 rx->subbeg = INT2PTR(char*,*p++);
361 rx->sublen = (I32)(*p++);
362 for (i = 0; i <= rx->nparens; ++i) {
363 rx->startp[i] = (I32)(*p++);
364 rx->endp[i] = (I32)(*p++);
369 Perl_rxres_free(pTHX_ void **rsp)
371 UV * const p = (UV*)*rsp;
375 void *tmp = INT2PTR(char*,*p);
378 Poison(*p, 1, sizeof(*p));
380 Safefree(INT2PTR(char*,*p));
382 #ifdef PERL_OLD_COPY_ON_WRITE
384 SvREFCNT_dec (INT2PTR(SV*,p[1]));
394 dSP; dMARK; dORIGMARK;
395 register SV * const tmpForm = *++MARK;
400 register SV *sv = Nullsv;
401 const char *item = Nullch;
405 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
406 const char *chophere = Nullch;
407 char *linemark = Nullch;
409 bool gotsome = FALSE;
411 const STRLEN fudge = SvPOK(tmpForm)
412 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
413 bool item_is_utf8 = FALSE;
414 bool targ_is_utf8 = FALSE;
420 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
421 if (SvREADONLY(tmpForm)) {
422 SvREADONLY_off(tmpForm);
423 parseres = doparseform(tmpForm);
424 SvREADONLY_on(tmpForm);
427 parseres = doparseform(tmpForm);
431 SvPV_force(PL_formtarget, len);
432 if (DO_UTF8(PL_formtarget))
434 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
436 f = SvPV_const(tmpForm, len);
437 /* need to jump to the next word */
438 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
442 const char *name = "???";
445 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
446 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
447 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
448 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
449 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
451 case FF_CHECKNL: name = "CHECKNL"; break;
452 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
453 case FF_SPACE: name = "SPACE"; break;
454 case FF_HALFSPACE: name = "HALFSPACE"; break;
455 case FF_ITEM: name = "ITEM"; break;
456 case FF_CHOP: name = "CHOP"; break;
457 case FF_LINEGLOB: name = "LINEGLOB"; break;
458 case FF_NEWLINE: name = "NEWLINE"; break;
459 case FF_MORE: name = "MORE"; break;
460 case FF_LINEMARK: name = "LINEMARK"; break;
461 case FF_END: name = "END"; break;
462 case FF_0DECIMAL: name = "0DECIMAL"; break;
463 case FF_LINESNGL: name = "LINESNGL"; break;
466 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
468 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
479 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
480 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
482 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
483 t = SvEND(PL_formtarget);
486 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
487 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
489 sv_utf8_upgrade(PL_formtarget);
490 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
491 t = SvEND(PL_formtarget);
511 if (ckWARN(WARN_SYNTAX))
512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
519 const char *s = item = SvPV_const(sv, len);
522 itemsize = sv_len_utf8(sv);
523 if (itemsize != (I32)len) {
525 if (itemsize > fieldsize) {
526 itemsize = fieldsize;
527 itembytes = itemsize;
528 sv_pos_u2b(sv, &itembytes, 0);
532 send = chophere = s + itembytes;
542 sv_pos_b2u(sv, &itemsize);
546 item_is_utf8 = FALSE;
547 if (itemsize > fieldsize)
548 itemsize = fieldsize;
549 send = chophere = s + itemsize;
563 const char *s = item = SvPV_const(sv, len);
566 itemsize = sv_len_utf8(sv);
567 if (itemsize != (I32)len) {
569 if (itemsize <= fieldsize) {
570 const char *send = chophere = s + itemsize;
583 itemsize = fieldsize;
584 itembytes = itemsize;
585 sv_pos_u2b(sv, &itembytes, 0);
586 send = chophere = s + itembytes;
587 while (s < send || (s == send && isSPACE(*s))) {
597 if (strchr(PL_chopset, *s))
602 itemsize = chophere - item;
603 sv_pos_b2u(sv, &itemsize);
609 item_is_utf8 = FALSE;
610 if (itemsize <= fieldsize) {
611 const char *const send = chophere = s + itemsize;
624 itemsize = fieldsize;
625 send = chophere = s + itemsize;
626 while (s < send || (s == send && isSPACE(*s))) {
636 if (strchr(PL_chopset, *s))
641 itemsize = chophere - item;
647 arg = fieldsize - itemsize;
656 arg = fieldsize - itemsize;
667 const char *s = item;
671 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
673 sv_utf8_upgrade(PL_formtarget);
674 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
675 t = SvEND(PL_formtarget);
679 if (UTF8_IS_CONTINUED(*s)) {
680 STRLEN skip = UTF8SKIP(s);
697 if ( !((*t++ = *s++) & ~31) )
703 if (targ_is_utf8 && !item_is_utf8) {
704 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
706 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
707 for (; t < SvEND(PL_formtarget); t++) {
720 const int ch = *t++ = *s++;
723 if ( !((*t++ = *s++) & ~31) )
732 const char *s = chophere;
734 while (*s && isSPACE(*s))
750 const char *s = item = SvPV_const(sv, len);
752 if ((item_is_utf8 = DO_UTF8(sv)))
753 itemsize = sv_len_utf8(sv);
755 bool chopped = FALSE;
756 const char *const send = s + len;
758 chophere = s + itemsize;
774 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
776 SvUTF8_on(PL_formtarget);
778 SvCUR_set(sv, chophere - item);
779 sv_catsv(PL_formtarget, sv);
780 SvCUR_set(sv, itemsize);
782 sv_catsv(PL_formtarget, sv);
784 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
785 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
786 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
795 #if defined(USE_LONG_DOUBLE)
796 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
798 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
803 #if defined(USE_LONG_DOUBLE)
804 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
806 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
809 /* If the field is marked with ^ and the value is undefined,
811 if ((arg & 512) && !SvOK(sv)) {
819 /* overflow evidence */
820 if (num_overflow(value, fieldsize, arg)) {
826 /* Formats aren't yet marked for locales, so assume "yes". */
828 STORE_NUMERIC_STANDARD_SET_LOCAL();
829 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
830 RESTORE_NUMERIC_STANDARD();
837 while (t-- > linemark && *t == ' ') ;
845 if (arg) { /* repeat until fields exhausted? */
847 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
848 lines += FmLINES(PL_formtarget);
851 if (strnEQ(linemark, linemark - arg, arg))
852 DIE(aTHX_ "Runaway format");
855 SvUTF8_on(PL_formtarget);
856 FmLINES(PL_formtarget) = lines;
858 RETURNOP(cLISTOP->op_first);
869 const char *s = chophere;
870 const char *send = item + len;
872 while (*s && isSPACE(*s) && s < send)
877 arg = fieldsize - itemsize;
884 if (strnEQ(s1," ",3)) {
885 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
896 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
898 SvUTF8_on(PL_formtarget);
899 FmLINES(PL_formtarget) += lines;
911 if (PL_stack_base + *PL_markstack_ptr == SP) {
913 if (GIMME_V == G_SCALAR)
914 XPUSHs(sv_2mortal(newSViv(0)));
915 RETURNOP(PL_op->op_next->op_next);
917 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
918 pp_pushmark(); /* push dst */
919 pp_pushmark(); /* push src */
920 ENTER; /* enter outer scope */
923 if (PL_op->op_private & OPpGREP_LEX)
924 SAVESPTR(PAD_SVl(PL_op->op_targ));
927 ENTER; /* enter inner scope */
930 src = PL_stack_base[*PL_markstack_ptr];
932 if (PL_op->op_private & OPpGREP_LEX)
933 PAD_SVl(PL_op->op_targ) = src;
938 if (PL_op->op_type == OP_MAPSTART)
939 pp_pushmark(); /* push top */
940 return ((LOGOP*)PL_op->op_next)->op_other;
946 const I32 gimme = GIMME_V;
947 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
953 /* first, move source pointer to the next item in the source list */
954 ++PL_markstack_ptr[-1];
956 /* if there are new items, push them into the destination list */
957 if (items && gimme != G_VOID) {
958 /* might need to make room back there first */
959 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
960 /* XXX this implementation is very pessimal because the stack
961 * is repeatedly extended for every set of items. Is possible
962 * to do this without any stack extension or copying at all
963 * by maintaining a separate list over which the map iterates
964 * (like foreach does). --gsar */
966 /* everything in the stack after the destination list moves
967 * towards the end the stack by the amount of room needed */
968 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
970 /* items to shift up (accounting for the moved source pointer) */
971 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
973 /* This optimization is by Ben Tilly and it does
974 * things differently from what Sarathy (gsar)
975 * is describing. The downside of this optimization is
976 * that leaves "holes" (uninitialized and hopefully unused areas)
977 * to the Perl stack, but on the other hand this
978 * shouldn't be a problem. If Sarathy's idea gets
979 * implemented, this optimization should become
980 * irrelevant. --jhi */
982 shift = count; /* Avoid shifting too often --Ben Tilly */
987 PL_markstack_ptr[-1] += shift;
988 *PL_markstack_ptr += shift;
992 /* copy the new items down to the destination list */
993 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
994 if (gimme == G_ARRAY) {
996 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
999 /* scalar context: we don't care about which values map returns
1000 * (we use undef here). And so we certainly don't want to do mortal
1001 * copies of meaningless values. */
1002 while (items-- > 0) {
1004 *dst-- = &PL_sv_undef;
1008 LEAVE; /* exit inner scope */
1011 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1013 (void)POPMARK; /* pop top */
1014 LEAVE; /* exit outer scope */
1015 (void)POPMARK; /* pop src */
1016 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1017 (void)POPMARK; /* pop dst */
1018 SP = PL_stack_base + POPMARK; /* pop original mark */
1019 if (gimme == G_SCALAR) {
1020 if (PL_op->op_private & OPpGREP_LEX) {
1021 SV* sv = sv_newmortal();
1022 sv_setiv(sv, items);
1030 else if (gimme == G_ARRAY)
1037 ENTER; /* enter inner scope */
1040 /* set $_ to the new source item */
1041 src = PL_stack_base[PL_markstack_ptr[-1]];
1043 if (PL_op->op_private & OPpGREP_LEX)
1044 PAD_SVl(PL_op->op_targ) = src;
1048 RETURNOP(cLOGOP->op_other);
1056 if (GIMME == G_ARRAY)
1058 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1059 return cLOGOP->op_other;
1068 if (GIMME == G_ARRAY) {
1069 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1073 SV * const targ = PAD_SV(PL_op->op_targ);
1076 if (PL_op->op_private & OPpFLIP_LINENUM) {
1077 if (GvIO(PL_last_in_gv)) {
1078 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1081 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1083 flip = SvIV(sv) == SvIV(GvSV(gv));
1089 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1090 if (PL_op->op_flags & OPf_SPECIAL) {
1098 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1101 sv_setpvn(TARG, "", 0);
1107 /* This code tries to decide if "$left .. $right" should use the
1108 magical string increment, or if the range is numeric (we make
1109 an exception for .."0" [#18165]). AMS 20021031. */
1111 #define RANGE_IS_NUMERIC(left,right) ( \
1112 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1113 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1114 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1115 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1116 && (!SvOK(right) || looks_like_number(right))))
1122 if (GIMME == G_ARRAY) {
1128 if (RANGE_IS_NUMERIC(left,right)) {
1131 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1132 (SvOK(right) && SvNV(right) > IV_MAX))
1133 DIE(aTHX_ "Range iterator outside integer range");
1144 SV * const sv = sv_2mortal(newSViv(i++));
1149 SV * const final = sv_mortalcopy(right);
1151 const char * const tmps = SvPV_const(final, len);
1153 SV *sv = sv_mortalcopy(left);
1154 SvPV_force_nolen(sv);
1155 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1157 if (strEQ(SvPVX_const(sv),tmps))
1159 sv = sv_2mortal(newSVsv(sv));
1166 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1170 if (PL_op->op_private & OPpFLIP_LINENUM) {
1171 if (GvIO(PL_last_in_gv)) {
1172 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1175 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1176 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1184 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1185 sv_catpvn(targ, "E0", 2);
1195 static const char * const context_name[] = {
1206 S_dopoptolabel(pTHX_ const char *label)
1210 for (i = cxstack_ix; i >= 0; i--) {
1211 register const PERL_CONTEXT * const cx = &cxstack[i];
1212 switch (CxTYPE(cx)) {
1218 if (ckWARN(WARN_EXITING))
1219 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1220 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1221 if (CxTYPE(cx) == CXt_NULL)
1225 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1226 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1227 (long)i, cx->blk_loop.label));
1230 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1238 Perl_dowantarray(pTHX)
1240 const I32 gimme = block_gimme();
1241 return (gimme == G_VOID) ? G_SCALAR : gimme;
1245 Perl_block_gimme(pTHX)
1247 const I32 cxix = dopoptosub(cxstack_ix);
1251 switch (cxstack[cxix].blk_gimme) {
1259 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1266 Perl_is_lvalue_sub(pTHX)
1268 const I32 cxix = dopoptosub(cxstack_ix);
1269 assert(cxix >= 0); /* We should only be called from inside subs */
1271 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1272 return cxstack[cxix].blk_sub.lval;
1278 S_dopoptosub(pTHX_ I32 startingblock)
1280 return dopoptosub_at(cxstack, startingblock);
1284 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1287 for (i = startingblock; i >= 0; i--) {
1288 register const PERL_CONTEXT * const cx = &cxstk[i];
1289 switch (CxTYPE(cx)) {
1295 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1303 S_dopoptoeval(pTHX_ I32 startingblock)
1306 for (i = startingblock; i >= 0; i--) {
1307 register const PERL_CONTEXT *cx = &cxstack[i];
1308 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1323 for (i = startingblock; i >= 0; i--) {
1324 register const PERL_CONTEXT * const cx = &cxstack[i];
1325 switch (CxTYPE(cx)) {
1331 if (ckWARN(WARN_EXITING))
1332 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1333 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1334 if ((CxTYPE(cx)) == CXt_NULL)
1338 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1346 Perl_dounwind(pTHX_ I32 cxix)
1350 while (cxstack_ix > cxix) {
1352 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1353 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1354 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1355 /* Note: we don't need to restore the base context info till the end. */
1356 switch (CxTYPE(cx)) {
1359 continue; /* not break */
1378 PERL_UNUSED_VAR(optype);
1382 Perl_qerror(pTHX_ SV *err)
1385 sv_catsv(ERRSV, err);
1387 sv_catsv(PL_errors, err);
1389 Perl_warn(aTHX_ "%"SVf, err);
1394 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1403 if (PL_in_eval & EVAL_KEEPERR) {
1404 static const char prefix[] = "\t(in cleanup) ";
1405 SV * const err = ERRSV;
1406 const char *e = Nullch;
1408 sv_setpvn(err,"",0);
1409 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1411 e = SvPV_const(err, len);
1413 if (*e != *message || strNE(e,message))
1417 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1418 sv_catpvn(err, prefix, sizeof(prefix)-1);
1419 sv_catpvn(err, message, msglen);
1420 if (ckWARN(WARN_MISC)) {
1421 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1422 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1427 sv_setpvn(ERRSV, message, msglen);
1431 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1432 && PL_curstackinfo->si_prev)
1440 register PERL_CONTEXT *cx;
1443 if (cxix < cxstack_ix)
1446 POPBLOCK(cx,PL_curpm);
1447 if (CxTYPE(cx) != CXt_EVAL) {
1449 message = SvPVx_const(ERRSV, msglen);
1450 PerlIO_write(Perl_error_log, "panic: die ", 11);
1451 PerlIO_write(Perl_error_log, message, msglen);
1456 if (gimme == G_SCALAR)
1457 *++newsp = &PL_sv_undef;
1458 PL_stack_sp = newsp;
1462 /* LEAVE could clobber PL_curcop (see save_re_context())
1463 * XXX it might be better to find a way to avoid messing with
1464 * PL_curcop in save_re_context() instead, but this is a more
1465 * minimal fix --GSAR */
1466 PL_curcop = cx->blk_oldcop;
1468 if (optype == OP_REQUIRE) {
1469 const char* const msg = SvPVx_nolen_const(ERRSV);
1470 SV * const nsv = cx->blk_eval.old_namesv;
1471 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1473 DIE(aTHX_ "%sCompilation failed in require",
1474 *msg ? msg : "Unknown error\n");
1476 assert(CxTYPE(cx) == CXt_EVAL);
1477 return cx->blk_eval.retop;
1481 message = SvPVx_const(ERRSV, msglen);
1483 write_to_stderr(message, msglen);
1492 if (SvTRUE(left) != SvTRUE(right))
1504 RETURNOP(cLOGOP->op_other);
1513 RETURNOP(cLOGOP->op_other);
1522 if (!sv || !SvANY(sv)) {
1523 RETURNOP(cLOGOP->op_other);
1526 switch (SvTYPE(sv)) {
1528 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1532 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1536 if (CvROOT(sv) || CvXSUB(sv))
1545 RETURNOP(cLOGOP->op_other);
1551 register I32 cxix = dopoptosub(cxstack_ix);
1552 register const PERL_CONTEXT *cx;
1553 register const PERL_CONTEXT *ccstack = cxstack;
1554 const PERL_SI *top_si = PL_curstackinfo;
1556 const char *stashname;
1563 /* we may be in a higher stacklevel, so dig down deeper */
1564 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1565 top_si = top_si->si_prev;
1566 ccstack = top_si->si_cxstack;
1567 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1570 if (GIMME != G_ARRAY) {
1576 /* caller() should not report the automatic calls to &DB::sub */
1577 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1578 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1582 cxix = dopoptosub_at(ccstack, cxix - 1);
1585 cx = &ccstack[cxix];
1586 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1587 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1588 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1589 field below is defined for any cx. */
1590 /* caller() should not report the automatic calls to &DB::sub */
1591 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1592 cx = &ccstack[dbcxix];
1595 stashname = CopSTASHPV(cx->blk_oldcop);
1596 if (GIMME != G_ARRAY) {
1599 PUSHs(&PL_sv_undef);
1602 sv_setpv(TARG, stashname);
1611 PUSHs(&PL_sv_undef);
1613 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1614 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1615 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1618 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1619 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1620 /* So is ccstack[dbcxix]. */
1622 SV * const sv = NEWSV(49, 0);
1623 gv_efullname3(sv, cvgv, Nullch);
1624 PUSHs(sv_2mortal(sv));
1625 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1628 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1633 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1634 PUSHs(sv_2mortal(newSViv(0)));
1636 gimme = (I32)cx->blk_gimme;
1637 if (gimme == G_VOID)
1638 PUSHs(&PL_sv_undef);
1640 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1641 if (CxTYPE(cx) == CXt_EVAL) {
1643 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1644 PUSHs(cx->blk_eval.cur_text);
1648 else if (cx->blk_eval.old_namesv) {
1649 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1652 /* eval BLOCK (try blocks have old_namesv == 0) */
1654 PUSHs(&PL_sv_undef);
1655 PUSHs(&PL_sv_undef);
1659 PUSHs(&PL_sv_undef);
1660 PUSHs(&PL_sv_undef);
1662 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1663 && CopSTASH_eq(PL_curcop, PL_debstash))
1665 AV * const ary = cx->blk_sub.argarray;
1666 const int off = AvARRAY(ary) - AvALLOC(ary);
1670 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1673 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1676 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1677 av_extend(PL_dbargs, AvFILLp(ary) + off);
1678 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1679 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1681 /* XXX only hints propagated via op_private are currently
1682 * visible (others are not easily accessible, since they
1683 * use the global PL_hints) */
1684 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1685 HINT_PRIVATE_MASK)));
1688 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1690 if (old_warnings == pWARN_NONE ||
1691 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1692 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1693 else if (old_warnings == pWARN_ALL ||
1694 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1695 /* Get the bit mask for $warnings::Bits{all}, because
1696 * it could have been extended by warnings::register */
1698 HV *bits = get_hv("warnings::Bits", FALSE);
1699 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1700 mask = newSVsv(*bits_all);
1703 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1707 mask = newSVsv(old_warnings);
1708 PUSHs(sv_2mortal(mask));
1722 sv_reset(tmps, CopSTASH(PL_curcop));
1732 /* like pp_nextstate, but used instead when the debugger is active */
1737 PL_curcop = (COP*)PL_op;
1738 TAINT_NOT; /* Each statement is presumed innocent */
1739 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1742 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1743 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1747 register PERL_CONTEXT *cx;
1748 const I32 gimme = G_ARRAY;
1755 DIE(aTHX_ "No DB::DB routine defined");
1757 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1758 /* don't do recursive DB::DB call */
1773 (void)(*CvXSUB(cv))(aTHX_ cv);
1780 PUSHBLOCK(cx, CXt_SUB, SP);
1782 cx->blk_sub.retop = PL_op->op_next;
1785 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1786 RETURNOP(CvSTART(cv));
1801 register PERL_CONTEXT *cx;
1802 const I32 gimme = GIMME_V;
1804 U32 cxtype = CXt_LOOP;
1812 if (PL_op->op_targ) {
1813 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1814 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1815 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1816 SVs_PADSTALE, SVs_PADSTALE);
1818 #ifndef USE_ITHREADS
1819 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1822 SAVEPADSV(PL_op->op_targ);
1823 iterdata = INT2PTR(void*, PL_op->op_targ);
1824 cxtype |= CXp_PADVAR;
1829 svp = &GvSV(gv); /* symbol table variable */
1830 SAVEGENERICSV(*svp);
1833 iterdata = (void*)gv;
1839 PUSHBLOCK(cx, cxtype, SP);
1841 PUSHLOOP(cx, iterdata, MARK);
1843 PUSHLOOP(cx, svp, MARK);
1845 if (PL_op->op_flags & OPf_STACKED) {
1846 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1847 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1849 SV *right = (SV*)cx->blk_loop.iterary;
1852 if (RANGE_IS_NUMERIC(sv,right)) {
1853 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1854 (SvOK(right) && SvNV(right) >= IV_MAX))
1855 DIE(aTHX_ "Range iterator outside integer range");
1856 cx->blk_loop.iterix = SvIV(sv);
1857 cx->blk_loop.itermax = SvIV(right);
1859 /* for correct -Dstv display */
1860 cx->blk_oldsp = sp - PL_stack_base;
1864 cx->blk_loop.iterlval = newSVsv(sv);
1865 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1866 (void) SvPV_nolen_const(right);
1869 else if (PL_op->op_private & OPpITER_REVERSED) {
1870 cx->blk_loop.itermax = -1;
1871 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1876 cx->blk_loop.iterary = PL_curstack;
1877 AvFILLp(PL_curstack) = SP - PL_stack_base;
1878 if (PL_op->op_private & OPpITER_REVERSED) {
1879 cx->blk_loop.itermax = MARK - PL_stack_base;
1880 cx->blk_loop.iterix = cx->blk_oldsp;
1883 cx->blk_loop.iterix = MARK - PL_stack_base;
1893 register PERL_CONTEXT *cx;
1894 const I32 gimme = GIMME_V;
1900 PUSHBLOCK(cx, CXt_LOOP, SP);
1901 PUSHLOOP(cx, 0, SP);
1909 register PERL_CONTEXT *cx;
1916 assert(CxTYPE(cx) == CXt_LOOP);
1918 newsp = PL_stack_base + cx->blk_loop.resetsp;
1921 if (gimme == G_VOID)
1923 else if (gimme == G_SCALAR) {
1925 *++newsp = sv_mortalcopy(*SP);
1927 *++newsp = &PL_sv_undef;
1931 *++newsp = sv_mortalcopy(*++mark);
1932 TAINT_NOT; /* Each item is independent */
1938 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1939 PL_curpm = newpm; /* ... and pop $1 et al */
1951 register PERL_CONTEXT *cx;
1952 bool popsub2 = FALSE;
1953 bool clear_errsv = FALSE;
1961 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1962 if (cxstack_ix == PL_sortcxix
1963 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1965 if (cxstack_ix > PL_sortcxix)
1966 dounwind(PL_sortcxix);
1967 AvARRAY(PL_curstack)[1] = *SP;
1968 PL_stack_sp = PL_stack_base + 1;
1973 cxix = dopoptosub(cxstack_ix);
1975 DIE(aTHX_ "Can't return outside a subroutine");
1976 if (cxix < cxstack_ix)
1980 switch (CxTYPE(cx)) {
1983 retop = cx->blk_sub.retop;
1984 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1987 if (!(PL_in_eval & EVAL_KEEPERR))
1990 retop = cx->blk_eval.retop;
1994 if (optype == OP_REQUIRE &&
1995 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1997 /* Unassume the success we assumed earlier. */
1998 SV * const nsv = cx->blk_eval.old_namesv;
1999 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2000 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2005 retop = cx->blk_sub.retop;
2008 DIE(aTHX_ "panic: return");
2012 if (gimme == G_SCALAR) {
2015 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2017 *++newsp = SvREFCNT_inc(*SP);
2022 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2024 *++newsp = sv_mortalcopy(sv);
2029 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2032 *++newsp = sv_mortalcopy(*SP);
2035 *++newsp = &PL_sv_undef;
2037 else if (gimme == G_ARRAY) {
2038 while (++MARK <= SP) {
2039 *++newsp = (popsub2 && SvTEMP(*MARK))
2040 ? *MARK : sv_mortalcopy(*MARK);
2041 TAINT_NOT; /* Each item is independent */
2044 PL_stack_sp = newsp;
2047 /* Stack values are safe: */
2050 POPSUB(cx,sv); /* release CV and @_ ... */
2054 PL_curpm = newpm; /* ... and pop $1 et al */
2058 sv_setpvn(ERRSV,"",0);
2066 register PERL_CONTEXT *cx;
2077 if (PL_op->op_flags & OPf_SPECIAL) {
2078 cxix = dopoptoloop(cxstack_ix);
2080 DIE(aTHX_ "Can't \"last\" outside a loop block");
2083 cxix = dopoptolabel(cPVOP->op_pv);
2085 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2087 if (cxix < cxstack_ix)
2091 cxstack_ix++; /* temporarily protect top context */
2093 switch (CxTYPE(cx)) {
2096 newsp = PL_stack_base + cx->blk_loop.resetsp;
2097 nextop = cx->blk_loop.last_op->op_next;
2101 nextop = cx->blk_sub.retop;
2105 nextop = cx->blk_eval.retop;
2109 nextop = cx->blk_sub.retop;
2112 DIE(aTHX_ "panic: last");
2116 if (gimme == G_SCALAR) {
2118 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2119 ? *SP : sv_mortalcopy(*SP);
2121 *++newsp = &PL_sv_undef;
2123 else if (gimme == G_ARRAY) {
2124 while (++MARK <= SP) {
2125 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2126 ? *MARK : sv_mortalcopy(*MARK);
2127 TAINT_NOT; /* Each item is independent */
2135 /* Stack values are safe: */
2138 POPLOOP(cx); /* release loop vars ... */
2142 POPSUB(cx,sv); /* release CV and @_ ... */
2145 PL_curpm = newpm; /* ... and pop $1 et al */
2148 PERL_UNUSED_VAR(optype);
2149 PERL_UNUSED_VAR(gimme);
2157 register PERL_CONTEXT *cx;
2160 if (PL_op->op_flags & OPf_SPECIAL) {
2161 cxix = dopoptoloop(cxstack_ix);
2163 DIE(aTHX_ "Can't \"next\" outside a loop block");
2166 cxix = dopoptolabel(cPVOP->op_pv);
2168 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2170 if (cxix < cxstack_ix)
2173 /* clear off anything above the scope we're re-entering, but
2174 * save the rest until after a possible continue block */
2175 inner = PL_scopestack_ix;
2177 if (PL_scopestack_ix < inner)
2178 leave_scope(PL_scopestack[PL_scopestack_ix]);
2179 PL_curcop = cx->blk_oldcop;
2180 return cx->blk_loop.next_op;
2187 register PERL_CONTEXT *cx;
2191 if (PL_op->op_flags & OPf_SPECIAL) {
2192 cxix = dopoptoloop(cxstack_ix);
2194 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2197 cxix = dopoptolabel(cPVOP->op_pv);
2199 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2201 if (cxix < cxstack_ix)
2204 redo_op = cxstack[cxix].blk_loop.redo_op;
2205 if (redo_op->op_type == OP_ENTER) {
2206 /* pop one less context to avoid $x being freed in while (my $x..) */
2208 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2209 redo_op = redo_op->op_next;
2213 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2214 LEAVE_SCOPE(oldsave);
2216 PL_curcop = cx->blk_oldcop;
2221 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2224 static const char too_deep[] = "Target of goto is too deeply nested";
2227 Perl_croak(aTHX_ too_deep);
2228 if (o->op_type == OP_LEAVE ||
2229 o->op_type == OP_SCOPE ||
2230 o->op_type == OP_LEAVELOOP ||
2231 o->op_type == OP_LEAVESUB ||
2232 o->op_type == OP_LEAVETRY)
2234 *ops++ = cUNOPo->op_first;
2236 Perl_croak(aTHX_ too_deep);
2239 if (o->op_flags & OPf_KIDS) {
2241 /* First try all the kids at this level, since that's likeliest. */
2242 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2243 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2244 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2247 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2248 if (kid == PL_lastgotoprobe)
2250 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2253 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2254 ops[-1]->op_type == OP_DBSTATE)
2259 if ((o = dofindlabel(kid, label, ops, oplimit)))
2278 register PERL_CONTEXT *cx;
2279 #define GOTO_DEPTH 64
2280 OP *enterops[GOTO_DEPTH];
2281 const char *label = 0;
2282 const bool do_dump = (PL_op->op_type == OP_DUMP);
2283 static const char must_have_label[] = "goto must have label";
2285 if (PL_op->op_flags & OPf_STACKED) {
2286 SV * const sv = POPs;
2288 /* This egregious kludge implements goto &subroutine */
2289 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2291 register PERL_CONTEXT *cx;
2292 CV* cv = (CV*)SvRV(sv);
2299 if (!CvROOT(cv) && !CvXSUB(cv)) {
2300 const GV * const gv = CvGV(cv);
2304 /* autoloaded stub? */
2305 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2307 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2308 GvNAMELEN(gv), FALSE);
2309 if (autogv && (cv = GvCV(autogv)))
2311 tmpstr = sv_newmortal();
2312 gv_efullname3(tmpstr, gv, Nullch);
2313 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2315 DIE(aTHX_ "Goto undefined subroutine");
2318 /* First do some returnish stuff. */
2319 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2321 cxix = dopoptosub(cxstack_ix);
2323 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2324 if (cxix < cxstack_ix)
2328 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2329 if (CxTYPE(cx) == CXt_EVAL) {
2331 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2333 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2335 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2336 /* put @_ back onto stack */
2337 AV* av = cx->blk_sub.argarray;
2339 items = AvFILLp(av) + 1;
2340 EXTEND(SP, items+1); /* @_ could have been extended. */
2341 Copy(AvARRAY(av), SP + 1, items, SV*);
2342 SvREFCNT_dec(GvAV(PL_defgv));
2343 GvAV(PL_defgv) = cx->blk_sub.savearray;
2345 /* abandon @_ if it got reified */
2350 av_extend(av, items-1);
2352 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2355 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2356 AV* const av = GvAV(PL_defgv);
2357 items = AvFILLp(av) + 1;
2358 EXTEND(SP, items+1); /* @_ could have been extended. */
2359 Copy(AvARRAY(av), SP + 1, items, SV*);
2363 if (CxTYPE(cx) == CXt_SUB &&
2364 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2365 SvREFCNT_dec(cx->blk_sub.cv);
2366 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2367 LEAVE_SCOPE(oldsave);
2369 /* Now do some callish stuff. */
2371 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2373 OP* retop = cx->blk_sub.retop;
2376 for (index=0; index<items; index++)
2377 sv_2mortal(SP[-index]);
2379 #ifdef PERL_XSUB_OLDSTYLE
2380 if (CvOLDSTYLE(cv)) {
2381 I32 (*fp3)(int,int,int);
2386 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2387 items = (*fp3)(CvXSUBANY(cv).any_i32,
2388 mark - PL_stack_base + 1,
2390 SP = PL_stack_base + items;
2393 #endif /* PERL_XSUB_OLDSTYLE */
2398 /* XS subs don't have a CxSUB, so pop it */
2399 POPBLOCK(cx, PL_curpm);
2400 /* Push a mark for the start of arglist */
2403 (void)(*CvXSUB(cv))(aTHX_ cv);
2404 /* Put these at the bottom since the vars are set but not used */
2405 PERL_UNUSED_VAR(newsp);
2406 PERL_UNUSED_VAR(gimme);
2412 AV* padlist = CvPADLIST(cv);
2413 if (CxTYPE(cx) == CXt_EVAL) {
2414 PL_in_eval = cx->blk_eval.old_in_eval;
2415 PL_eval_root = cx->blk_eval.old_eval_root;
2416 cx->cx_type = CXt_SUB;
2417 cx->blk_sub.hasargs = 0;
2419 cx->blk_sub.cv = cv;
2420 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2423 if (CvDEPTH(cv) < 2)
2424 (void)SvREFCNT_inc(cv);
2426 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2427 sub_crush_depth(cv);
2428 pad_push(padlist, CvDEPTH(cv));
2431 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2432 if (cx->blk_sub.hasargs)
2434 AV* av = (AV*)PAD_SVl(0);
2437 cx->blk_sub.savearray = GvAV(PL_defgv);
2438 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2439 CX_CURPAD_SAVE(cx->blk_sub);
2440 cx->blk_sub.argarray = av;
2442 if (items >= AvMAX(av) + 1) {
2444 if (AvARRAY(av) != ary) {
2445 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2446 SvPV_set(av, (char*)ary);
2448 if (items >= AvMAX(av) + 1) {
2449 AvMAX(av) = items - 1;
2450 Renew(ary,items+1,SV*);
2452 SvPV_set(av, (char*)ary);
2456 Copy(mark,AvARRAY(av),items,SV*);
2457 AvFILLp(av) = items - 1;
2458 assert(!AvREAL(av));
2460 /* transfer 'ownership' of refcnts to new @_ */
2470 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2472 * We do not care about using sv to call CV;
2473 * it's for informational purposes only.
2475 SV * const sv = GvSV(PL_DBsub);
2479 if (PERLDB_SUB_NN) {
2480 const int type = SvTYPE(sv);
2481 if (type < SVt_PVIV && type != SVt_IV)
2482 sv_upgrade(sv, SVt_PVIV);
2484 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2486 gv_efullname3(sv, CvGV(cv), Nullch);
2489 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2490 PUSHMARK( PL_stack_sp );
2491 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2495 RETURNOP(CvSTART(cv));
2499 label = SvPV_nolen_const(sv);
2500 if (!(do_dump || *label))
2501 DIE(aTHX_ must_have_label);
2504 else if (PL_op->op_flags & OPf_SPECIAL) {
2506 DIE(aTHX_ must_have_label);
2509 label = cPVOP->op_pv;
2511 if (label && *label) {
2513 bool leaving_eval = FALSE;
2514 bool in_block = FALSE;
2515 PERL_CONTEXT *last_eval_cx = 0;
2519 PL_lastgotoprobe = 0;
2521 for (ix = cxstack_ix; ix >= 0; ix--) {
2523 switch (CxTYPE(cx)) {
2525 leaving_eval = TRUE;
2526 if (!CxTRYBLOCK(cx)) {
2527 gotoprobe = (last_eval_cx ?
2528 last_eval_cx->blk_eval.old_eval_root :
2533 /* else fall through */
2535 gotoprobe = cx->blk_oldcop->op_sibling;
2541 gotoprobe = cx->blk_oldcop->op_sibling;
2544 gotoprobe = PL_main_root;
2547 if (CvDEPTH(cx->blk_sub.cv)) {
2548 gotoprobe = CvROOT(cx->blk_sub.cv);
2554 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2557 DIE(aTHX_ "panic: goto");
2558 gotoprobe = PL_main_root;
2562 retop = dofindlabel(gotoprobe, label,
2563 enterops, enterops + GOTO_DEPTH);
2567 PL_lastgotoprobe = gotoprobe;
2570 DIE(aTHX_ "Can't find label %s", label);
2572 /* if we're leaving an eval, check before we pop any frames
2573 that we're not going to punt, otherwise the error
2576 if (leaving_eval && *enterops && enterops[1]) {
2578 for (i = 1; enterops[i]; i++)
2579 if (enterops[i]->op_type == OP_ENTERITER)
2580 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2583 /* pop unwanted frames */
2585 if (ix < cxstack_ix) {
2592 oldsave = PL_scopestack[PL_scopestack_ix];
2593 LEAVE_SCOPE(oldsave);
2596 /* push wanted frames */
2598 if (*enterops && enterops[1]) {
2600 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2601 for (; enterops[ix]; ix++) {
2602 PL_op = enterops[ix];
2603 /* Eventually we may want to stack the needed arguments
2604 * for each op. For now, we punt on the hard ones. */
2605 if (PL_op->op_type == OP_ENTERITER)
2606 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2607 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2615 if (!retop) retop = PL_main_start;
2617 PL_restartop = retop;
2618 PL_do_undump = TRUE;
2622 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2623 PL_do_undump = FALSE;
2639 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2641 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2644 PL_exit_flags |= PERL_EXIT_EXPECTED;
2646 PUSHs(&PL_sv_undef);
2654 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2655 register I32 match = I_32(value);
2658 if (((NV)match) > value)
2659 --match; /* was fractional--truncate other way */
2661 match -= cCOP->uop.scop.scop_offset;
2664 else if (match > cCOP->uop.scop.scop_max)
2665 match = cCOP->uop.scop.scop_max;
2666 PL_op = cCOP->uop.scop.scop_next[match];
2676 PL_op = PL_op->op_next; /* can't assume anything */
2678 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2679 match -= cCOP->uop.scop.scop_offset;
2682 else if (match > cCOP->uop.scop.scop_max)
2683 match = cCOP->uop.scop.scop_max;
2684 PL_op = cCOP->uop.scop.scop_next[match];
2693 S_save_lines(pTHX_ AV *array, SV *sv)
2695 const char *s = SvPVX_const(sv);
2696 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2699 while (s && s < send) {
2701 SV * const tmpstr = NEWSV(85,0);
2703 sv_upgrade(tmpstr, SVt_PVMG);
2704 t = strchr(s, '\n');
2710 sv_setpvn(tmpstr, s, t - s);
2711 av_store(array, line++, tmpstr);
2717 S_docatch_body(pTHX)
2724 S_docatch(pTHX_ OP *o)
2727 OP * const oldop = PL_op;
2731 assert(CATCH_GET == TRUE);
2738 assert(cxstack_ix >= 0);
2739 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2740 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2745 /* die caught by an inner eval - continue inner loop */
2747 /* NB XXX we rely on the old popped CxEVAL still being at the top
2748 * of the stack; the way die_where() currently works, this
2749 * assumption is valid. In theory The cur_top_env value should be
2750 * returned in another global, the way retop (aka PL_restartop)
2752 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2755 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2757 PL_op = PL_restartop;
2774 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2775 /* sv Text to convert to OP tree. */
2776 /* startop op_free() this to undo. */
2777 /* code Short string id of the caller. */
2779 dVAR; dSP; /* Make POPBLOCK work. */
2786 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2787 char *tmpbuf = tbuf;
2790 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2795 /* switch to eval mode */
2797 if (IN_PERL_COMPILETIME) {
2798 SAVECOPSTASH_FREE(&PL_compiling);
2799 CopSTASH_set(&PL_compiling, PL_curstash);
2801 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2802 SV * const sv = sv_newmortal();
2803 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2804 code, (unsigned long)++PL_evalseq,
2805 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2809 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2810 SAVECOPFILE_FREE(&PL_compiling);
2811 CopFILE_set(&PL_compiling, tmpbuf+2);
2812 SAVECOPLINE(&PL_compiling);
2813 CopLINE_set(&PL_compiling, 1);
2814 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2815 deleting the eval's FILEGV from the stash before gv_check() runs
2816 (i.e. before run-time proper). To work around the coredump that
2817 ensues, we always turn GvMULTI_on for any globals that were
2818 introduced within evals. See force_ident(). GSAR 96-10-12 */
2819 safestr = savepv(tmpbuf);
2820 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2822 #ifdef OP_IN_REGISTER
2828 /* we get here either during compilation, or via pp_regcomp at runtime */
2829 runtime = IN_PERL_RUNTIME;
2831 runcv = find_runcv(NULL);
2834 PL_op->op_type = OP_ENTEREVAL;
2835 PL_op->op_flags = 0; /* Avoid uninit warning. */
2836 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2837 PUSHEVAL(cx, 0, Nullgv);
2840 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2842 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2843 POPBLOCK(cx,PL_curpm);
2846 (*startop)->op_type = OP_NULL;
2847 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2849 /* XXX DAPM do this properly one year */
2850 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2852 if (IN_PERL_COMPILETIME)
2853 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2854 #ifdef OP_IN_REGISTER
2857 PERL_UNUSED_VAR(newsp);
2858 PERL_UNUSED_VAR(optype);
2865 =for apidoc find_runcv
2867 Locate the CV corresponding to the currently executing sub or eval.
2868 If db_seqp is non_null, skip CVs that are in the DB package and populate
2869 *db_seqp with the cop sequence number at the point that the DB:: code was
2870 entered. (allows debuggers to eval in the scope of the breakpoint rather
2871 than in the scope of the debugger itself).
2877 Perl_find_runcv(pTHX_ U32 *db_seqp)
2882 *db_seqp = PL_curcop->cop_seq;
2883 for (si = PL_curstackinfo; si; si = si->si_prev) {
2885 for (ix = si->si_cxix; ix >= 0; ix--) {
2886 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2887 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2888 CV * const cv = cx->blk_sub.cv;
2889 /* skip DB:: code */
2890 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2891 *db_seqp = cx->blk_oldcop->cop_seq;
2896 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2904 /* Compile a require/do, an eval '', or a /(?{...})/.
2905 * In the last case, startop is non-null, and contains the address of
2906 * a pointer that should be set to the just-compiled code.
2907 * outside is the lexically enclosing CV (if any) that invoked us.
2910 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2912 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2915 OP * const saveop = PL_op;
2917 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2918 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2923 SAVESPTR(PL_compcv);
2924 PL_compcv = (CV*)NEWSV(1104,0);
2925 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2926 CvEVAL_on(PL_compcv);
2927 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2928 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2930 CvOUTSIDE_SEQ(PL_compcv) = seq;
2931 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2933 /* set up a scratch pad */
2935 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2938 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2940 /* make sure we compile in the right package */
2942 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2943 SAVESPTR(PL_curstash);
2944 PL_curstash = CopSTASH(PL_curcop);
2946 SAVESPTR(PL_beginav);
2947 PL_beginav = newAV();
2948 SAVEFREESV(PL_beginav);
2949 SAVEI32(PL_error_count);
2951 /* try to compile it */
2953 PL_eval_root = Nullop;
2955 PL_curcop = &PL_compiling;
2956 PL_curcop->cop_arybase = 0;
2957 if (saveop && saveop->op_flags & OPf_SPECIAL)
2958 PL_in_eval |= EVAL_KEEPERR;
2960 sv_setpvn(ERRSV,"",0);
2961 if (yyparse() || PL_error_count || !PL_eval_root) {
2962 SV **newsp; /* Used by POPBLOCK. */
2963 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2964 I32 optype = 0; /* Might be reset by POPEVAL. */
2969 op_free(PL_eval_root);
2970 PL_eval_root = Nullop;
2972 SP = PL_stack_base + POPMARK; /* pop original mark */
2974 POPBLOCK(cx,PL_curpm);
2980 msg = SvPVx_nolen_const(ERRSV);
2981 if (optype == OP_REQUIRE) {
2982 const SV * const nsv = cx->blk_eval.old_namesv;
2983 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2985 DIE(aTHX_ "%sCompilation failed in require",
2986 *msg ? msg : "Unknown error\n");
2989 POPBLOCK(cx,PL_curpm);
2991 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2992 (*msg ? msg : "Unknown error\n"));
2996 sv_setpv(ERRSV, "Compilation error");
2999 PERL_UNUSED_VAR(newsp);
3002 CopLINE_set(&PL_compiling, 0);
3004 *startop = PL_eval_root;
3006 SAVEFREEOP(PL_eval_root);
3008 /* Set the context for this new optree.
3009 * If the last op is an OP_REQUIRE, force scalar context.
3010 * Otherwise, propagate the context from the eval(). */
3011 if (PL_eval_root->op_type == OP_LEAVEEVAL
3012 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3013 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3015 scalar(PL_eval_root);
3016 else if (gimme & G_VOID)
3017 scalarvoid(PL_eval_root);
3018 else if (gimme & G_ARRAY)
3021 scalar(PL_eval_root);
3023 DEBUG_x(dump_eval());
3025 /* Register with debugger: */
3026 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3027 CV * const cv = get_cv("DB::postponed", FALSE);
3031 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3033 call_sv((SV*)cv, G_DISCARD);
3037 /* compiled okay, so do it */
3039 CvDEPTH(PL_compcv) = 1;
3040 SP = PL_stack_base + POPMARK; /* pop original mark */
3041 PL_op = saveop; /* The caller may need it. */
3042 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3044 RETURNOP(PL_eval_start);
3048 S_doopen_pm(pTHX_ const char *name, const char *mode)
3050 #ifndef PERL_DISABLE_PMC
3051 const STRLEN namelen = strlen(name);
3054 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3055 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3056 const char * const pmc = SvPV_nolen_const(pmcsv);
3058 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3059 fp = PerlIO_open(name, mode);
3063 if (PerlLIO_stat(name, &pmstat) < 0 ||
3064 pmstat.st_mtime < pmcstat.st_mtime)
3066 fp = PerlIO_open(pmc, mode);
3069 fp = PerlIO_open(name, mode);
3072 SvREFCNT_dec(pmcsv);
3075 fp = PerlIO_open(name, mode);
3079 return PerlIO_open(name, mode);
3080 #endif /* !PERL_DISABLE_PMC */
3086 register PERL_CONTEXT *cx;
3090 const char *tryname = Nullch;
3091 SV *namesv = Nullsv;
3092 const I32 gimme = GIMME_V;
3093 PerlIO *tryrsfp = 0;
3094 int filter_has_file = 0;
3095 GV *filter_child_proc = 0;
3096 SV *filter_state = 0;
3103 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3104 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3105 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3106 "v-string in use/require non-portable");
3108 sv = new_version(sv);
3109 if (!sv_derived_from(PL_patchlevel, "version"))
3110 (void *)upg_version(PL_patchlevel);
3111 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3112 if ( vcmp(sv,PL_patchlevel) < 0 )
3113 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3114 vnormal(sv), vnormal(PL_patchlevel));
3117 if ( vcmp(sv,PL_patchlevel) > 0 )
3118 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3119 vnormal(sv), vnormal(PL_patchlevel));
3124 name = SvPV_const(sv, len);
3125 if (!(name && len > 0 && *name))
3126 DIE(aTHX_ "Null filename used");
3127 TAINT_PROPER("require");
3128 if (PL_op->op_type == OP_REQUIRE) {
3129 SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3131 if (*svp != &PL_sv_undef)
3134 DIE(aTHX_ "Compilation failed in require");
3138 /* prepare to compile file */
3140 if (path_is_absolute(name)) {
3142 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3144 #ifdef MACOS_TRADITIONAL
3148 MacPerl_CanonDir(name, newname, 1);
3149 if (path_is_absolute(newname)) {
3151 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3156 AV * const ar = GvAVn(PL_incgv);
3160 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3163 namesv = NEWSV(806, 0);
3164 for (i = 0; i <= AvFILL(ar); i++) {
3165 SV *dirsv = *av_fetch(ar, i, TRUE);
3171 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3172 && !sv_isobject(loader))
3174 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3177 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3178 PTR2UV(SvRV(dirsv)), name);
3179 tryname = SvPVX_const(namesv);
3190 if (sv_isobject(loader))
3191 count = call_method("INC", G_ARRAY);
3193 count = call_sv(loader, G_ARRAY);
3203 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3207 if (SvTYPE(arg) == SVt_PVGV) {
3208 IO *io = GvIO((GV *)arg);
3213 tryrsfp = IoIFP(io);
3214 if (IoTYPE(io) == IoTYPE_PIPE) {
3215 /* reading from a child process doesn't
3216 nest -- when returning from reading
3217 the inner module, the outer one is
3218 unreadable (closed?) I've tried to
3219 save the gv to manage the lifespan of
3220 the pipe, but this didn't help. XXX */
3221 filter_child_proc = (GV *)arg;
3222 (void)SvREFCNT_inc(filter_child_proc);
3225 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3226 PerlIO_close(IoOFP(io));
3238 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3240 (void)SvREFCNT_inc(filter_sub);
3243 filter_state = SP[i];
3244 (void)SvREFCNT_inc(filter_state);
3248 tryrsfp = PerlIO_open("/dev/null",
3264 filter_has_file = 0;
3265 if (filter_child_proc) {
3266 SvREFCNT_dec(filter_child_proc);
3267 filter_child_proc = 0;
3270 SvREFCNT_dec(filter_state);
3274 SvREFCNT_dec(filter_sub);
3279 if (!path_is_absolute(name)
3280 #ifdef MACOS_TRADITIONAL
3281 /* We consider paths of the form :a:b ambiguous and interpret them first
3282 as global then as local
3284 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3287 const char *dir = SvPVx_nolen_const(dirsv);
3288 #ifdef MACOS_TRADITIONAL
3292 MacPerl_CanonDir(name, buf2, 1);
3293 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3297 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3299 sv_setpv(namesv, unixdir);
3300 sv_catpv(namesv, unixname);
3302 # ifdef __SYMBIAN32__
3303 if (PL_origfilename[0] &&
3304 PL_origfilename[1] == ':' &&
3305 !(dir[0] && dir[1] == ':'))
3306 Perl_sv_setpvf(aTHX_ namesv,
3311 Perl_sv_setpvf(aTHX_ namesv,
3315 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3319 TAINT_PROPER("require");
3320 tryname = SvPVX_const(namesv);
3321 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3323 if (tryname[0] == '.' && tryname[1] == '/')
3332 SAVECOPFILE_FREE(&PL_compiling);
3333 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3334 SvREFCNT_dec(namesv);
3336 if (PL_op->op_type == OP_REQUIRE) {
3337 const char *msgstr = name;
3338 if(errno == EMFILE) {
3339 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3340 sv_catpv(msg, ": ");
3341 sv_catpv(msg, Strerror(errno));
3342 msgstr = SvPV_nolen_const(msg);
3344 if (namesv) { /* did we lookup @INC? */
3345 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3346 SV * const dirmsgsv = NEWSV(0, 0);
3347 AV * const ar = GvAVn(PL_incgv);
3349 sv_catpvn(msg, " in @INC", 8);
3350 if (instr(SvPVX_const(msg), ".h "))
3351 sv_catpv(msg, " (change .h to .ph maybe?)");
3352 if (instr(SvPVX_const(msg), ".ph "))
3353 sv_catpv(msg, " (did you run h2ph?)");
3354 sv_catpv(msg, " (@INC contains:");
3355 for (i = 0; i <= AvFILL(ar); i++) {
3356 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3357 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3358 sv_catsv(msg, dirmsgsv);
3360 sv_catpvn(msg, ")", 1);
3361 SvREFCNT_dec(dirmsgsv);
3362 msgstr = SvPV_nolen_const(msg);
3365 DIE(aTHX_ "Can't locate %s", msgstr);
3371 SETERRNO(0, SS_NORMAL);
3373 /* Assume success here to prevent recursive requirement. */
3375 /* Check whether a hook in @INC has already filled %INC */
3377 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3379 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3381 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3386 lex_start(sv_2mortal(newSVpvn("",0)));
3387 SAVEGENERICSV(PL_rsfp_filters);
3388 PL_rsfp_filters = Nullav;
3393 SAVESPTR(PL_compiling.cop_warnings);
3394 if (PL_dowarn & G_WARN_ALL_ON)
3395 PL_compiling.cop_warnings = pWARN_ALL ;
3396 else if (PL_dowarn & G_WARN_ALL_OFF)
3397 PL_compiling.cop_warnings = pWARN_NONE ;
3398 else if (PL_taint_warn)
3399 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3401 PL_compiling.cop_warnings = pWARN_STD ;
3402 SAVESPTR(PL_compiling.cop_io);
3403 PL_compiling.cop_io = Nullsv;
3405 if (filter_sub || filter_child_proc) {
3406 SV * const datasv = filter_add(run_user_filter, Nullsv);
3407 IoLINES(datasv) = filter_has_file;
3408 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3409 IoTOP_GV(datasv) = (GV *)filter_state;
3410 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3413 /* switch to eval mode */
3414 PUSHBLOCK(cx, CXt_EVAL, SP);
3415 PUSHEVAL(cx, name, Nullgv);
3416 cx->blk_eval.retop = PL_op->op_next;
3418 SAVECOPLINE(&PL_compiling);
3419 CopLINE_set(&PL_compiling, 0);
3423 /* Store and reset encoding. */
3424 encoding = PL_encoding;
3425 PL_encoding = Nullsv;
3427 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3429 /* Restore encoding. */
3430 PL_encoding = encoding;
3437 return pp_require();
3443 register PERL_CONTEXT *cx;
3445 const I32 gimme = GIMME_V;
3446 const I32 was = PL_sub_generation;
3447 char tbuf[TYPE_DIGITS(long) + 12];
3448 char *tmpbuf = tbuf;
3455 if (!SvPV_const(sv,len))
3457 TAINT_PROPER("eval");
3463 /* switch to eval mode */
3465 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3466 SV * const sv = sv_newmortal();
3467 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3468 (unsigned long)++PL_evalseq,
3469 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3473 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3474 SAVECOPFILE_FREE(&PL_compiling);
3475 CopFILE_set(&PL_compiling, tmpbuf+2);
3476 SAVECOPLINE(&PL_compiling);
3477 CopLINE_set(&PL_compiling, 1);
3478 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3479 deleting the eval's FILEGV from the stash before gv_check() runs
3480 (i.e. before run-time proper). To work around the coredump that
3481 ensues, we always turn GvMULTI_on for any globals that were
3482 introduced within evals. See force_ident(). GSAR 96-10-12 */
3483 safestr = savepv(tmpbuf);
3484 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3486 PL_hints = PL_op->op_targ;
3487 SAVESPTR(PL_compiling.cop_warnings);
3488 if (specialWARN(PL_curcop->cop_warnings))
3489 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3491 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3492 SAVEFREESV(PL_compiling.cop_warnings);
3494 SAVESPTR(PL_compiling.cop_io);
3495 if (specialCopIO(PL_curcop->cop_io))
3496 PL_compiling.cop_io = PL_curcop->cop_io;
3498 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3499 SAVEFREESV(PL_compiling.cop_io);
3501 /* special case: an eval '' executed within the DB package gets lexically
3502 * placed in the first non-DB CV rather than the current CV - this
3503 * allows the debugger to execute code, find lexicals etc, in the
3504 * scope of the code being debugged. Passing &seq gets find_runcv
3505 * to do the dirty work for us */
3506 runcv = find_runcv(&seq);
3508 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3509 PUSHEVAL(cx, 0, Nullgv);
3510 cx->blk_eval.retop = PL_op->op_next;
3512 /* prepare to compile string */
3514 if (PERLDB_LINE && PL_curstash != PL_debstash)
3515 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3517 ret = doeval(gimme, NULL, runcv, seq);
3518 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3519 && ret != PL_op->op_next) { /* Successive compilation. */
3520 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3522 return DOCATCH(ret);
3532 register PERL_CONTEXT *cx;
3534 const U8 save_flags = PL_op -> op_flags;
3539 retop = cx->blk_eval.retop;
3542 if (gimme == G_VOID)
3544 else if (gimme == G_SCALAR) {
3547 if (SvFLAGS(TOPs) & SVs_TEMP)
3550 *MARK = sv_mortalcopy(TOPs);
3554 *MARK = &PL_sv_undef;
3559 /* in case LEAVE wipes old return values */
3560 for (mark = newsp + 1; mark <= SP; mark++) {
3561 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3562 *mark = sv_mortalcopy(*mark);
3563 TAINT_NOT; /* Each item is independent */
3567 PL_curpm = newpm; /* Don't pop $1 et al till now */
3570 assert(CvDEPTH(PL_compcv) == 1);
3572 CvDEPTH(PL_compcv) = 0;
3575 if (optype == OP_REQUIRE &&
3576 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3578 /* Unassume the success we assumed earlier. */
3579 SV * const nsv = cx->blk_eval.old_namesv;
3580 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3581 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3582 /* die_where() did LEAVE, or we won't be here */
3586 if (!(save_flags & OPf_SPECIAL))
3587 sv_setpvn(ERRSV,"",0);
3596 register PERL_CONTEXT *cx;
3597 const I32 gimme = GIMME_V;
3602 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3604 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3606 PL_in_eval = EVAL_INEVAL;
3607 sv_setpvn(ERRSV,"",0);
3609 return DOCATCH(PL_op->op_next);
3619 register PERL_CONTEXT *cx;
3624 PERL_UNUSED_VAR(optype);
3627 if (gimme == G_VOID)
3629 else if (gimme == G_SCALAR) {
3632 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3635 *MARK = sv_mortalcopy(TOPs);
3639 *MARK = &PL_sv_undef;
3644 /* in case LEAVE wipes old return values */
3645 for (mark = newsp + 1; mark <= SP; mark++) {
3646 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3647 *mark = sv_mortalcopy(*mark);
3648 TAINT_NOT; /* Each item is independent */
3652 PL_curpm = newpm; /* Don't pop $1 et al till now */
3655 sv_setpvn(ERRSV,"",0);
3660 S_doparseform(pTHX_ SV *sv)
3663 register char *s = SvPV_force(sv, len);
3664 register char *send = s + len;
3665 register char *base = Nullch;
3666 register I32 skipspaces = 0;
3667 bool noblank = FALSE;
3668 bool repeat = FALSE;
3669 bool postspace = FALSE;
3675 bool unchopnum = FALSE;
3676 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3679 Perl_croak(aTHX_ "Null picture in formline");
3681 /* estimate the buffer size needed */
3682 for (base = s; s <= send; s++) {
3683 if (*s == '\n' || *s == '@' || *s == '^')
3689 Newx(fops, maxops, U32);
3694 *fpc++ = FF_LINEMARK;
3695 noblank = repeat = FALSE;
3713 case ' ': case '\t':
3720 } /* else FALL THROUGH */
3728 *fpc++ = FF_LITERAL;
3736 *fpc++ = (U16)skipspaces;
3740 *fpc++ = FF_NEWLINE;
3744 arg = fpc - linepc + 1;
3751 *fpc++ = FF_LINEMARK;
3752 noblank = repeat = FALSE;
3761 ischop = s[-1] == '^';
3767 arg = (s - base) - 1;
3769 *fpc++ = FF_LITERAL;
3777 *fpc++ = 2; /* skip the @* or ^* */
3779 *fpc++ = FF_LINESNGL;
3782 *fpc++ = FF_LINEGLOB;
3784 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3785 arg = ischop ? 512 : 0;
3790 const char * const f = ++s;
3793 arg |= 256 + (s - f);
3795 *fpc++ = s - base; /* fieldsize for FETCH */
3796 *fpc++ = FF_DECIMAL;
3798 unchopnum |= ! ischop;
3800 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3801 arg = ischop ? 512 : 0;
3803 s++; /* skip the '0' first */
3807 const char * const f = ++s;
3810 arg |= 256 + (s - f);
3812 *fpc++ = s - base; /* fieldsize for FETCH */
3813 *fpc++ = FF_0DECIMAL;
3815 unchopnum |= ! ischop;
3819 bool ismore = FALSE;
3822 while (*++s == '>') ;
3823 prespace = FF_SPACE;
3825 else if (*s == '|') {
3826 while (*++s == '|') ;
3827 prespace = FF_HALFSPACE;
3832 while (*++s == '<') ;
3835 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3839 *fpc++ = s - base; /* fieldsize for FETCH */
3841 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3844 *fpc++ = (U16)prespace;
3858 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3860 { /* need to jump to the next word */
3862 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3863 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3864 s = SvPVX(sv) + SvCUR(sv) + z;
3866 Copy(fops, s, arg, U32);
3868 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3871 if (unchopnum && repeat)
3872 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3878 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3880 /* Can value be printed in fldsize chars, using %*.*f ? */
3884 int intsize = fldsize - (value < 0 ? 1 : 0);
3891 while (intsize--) pwr *= 10.0;
3892 while (frcsize--) eps /= 10.0;
3895 if (value + eps >= pwr)
3898 if (value - eps <= -pwr)
3905 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3908 SV *datasv = FILTER_DATA(idx);
3909 const int filter_has_file = IoLINES(datasv);
3910 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3911 SV *filter_state = (SV *)IoTOP_GV(datasv);
3912 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3915 /* I was having segfault trouble under Linux 2.2.5 after a
3916 parse error occured. (Had to hack around it with a test
3917 for PL_error_count == 0.) Solaris doesn't segfault --
3918 not sure where the trouble is yet. XXX */
3920 if (filter_has_file) {
3921 len = FILTER_READ(idx+1, buf_sv, maxlen);
3924 if (filter_sub && len >= 0) {
3935 PUSHs(sv_2mortal(newSViv(maxlen)));
3937 PUSHs(filter_state);
3940 count = call_sv(filter_sub, G_SCALAR);
3956 IoLINES(datasv) = 0;
3957 if (filter_child_proc) {
3958 SvREFCNT_dec(filter_child_proc);
3959 IoFMT_GV(datasv) = Nullgv;
3962 SvREFCNT_dec(filter_state);
3963 IoTOP_GV(datasv) = Nullgv;
3966 SvREFCNT_dec(filter_sub);
3967 IoBOTTOM_GV(datasv) = Nullgv;
3969 filter_del(run_user_filter);
3975 /* perhaps someone can come up with a better name for
3976 this? it is not really "absolute", per se ... */
3978 S_path_is_absolute(pTHX_ const char *name)
3980 if (PERL_FILE_IS_ABSOLUTE(name)
3981 #ifdef MACOS_TRADITIONAL
3984 || (*name == '.' && (name[1] == '/' ||
3985 (name[1] == '.' && name[2] == '/'))))
3996 * c-indentation-style: bsd
3998 * indent-tabs-mode: t
4001 * ex: set ts=8 sts=4 sw=4 noet: