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))
47 cxix = dopoptosub(cxstack_ix);
51 switch (cxstack[cxix].blk_gimme) {
63 /* XXXX Should store the old value to allow for tie/overload - and
64 restore in regcomp, where marked with XXXX. */
73 register PMOP *pm = (PMOP*)cLOGOP->op_other;
75 MAGIC *mg = Null(MAGIC*);
77 /* prevent recompiling under /o and ithreads. */
78 #if defined(USE_ITHREADS)
79 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
80 if (PL_op->op_flags & OPf_STACKED) {
89 if (PL_op->op_flags & OPf_STACKED) {
90 /* multiple args; concatentate them */
92 tmpstr = PAD_SV(ARGTARG);
93 sv_setpvn(tmpstr, "", 0);
94 while (++MARK <= SP) {
95 if (PL_amagic_generation) {
97 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
98 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
100 sv_setsv(tmpstr, sv);
104 sv_catsv(tmpstr, *MARK);
113 SV *sv = SvRV(tmpstr);
115 mg = mg_find(sv, PERL_MAGIC_qr);
118 regexp * const re = (regexp *)mg->mg_obj;
119 ReREFCNT_dec(PM_GETRE(pm));
120 PM_SETRE(pm, ReREFCNT_inc(re));
124 const char *t = SvPV_const(tmpstr, len);
126 /* Check against the last compiled regexp. */
127 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
128 PM_GETRE(pm)->prelen != (I32)len ||
129 memNE(PM_GETRE(pm)->precomp, t, len))
132 ReREFCNT_dec(PM_GETRE(pm));
133 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
135 if (PL_op->op_flags & OPf_SPECIAL)
136 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
138 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
140 pm->op_pmdynflags |= PMdf_DYN_UTF8;
142 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
143 if (pm->op_pmdynflags & PMdf_UTF8)
144 t = (char*)bytes_to_utf8((U8*)t, &len);
146 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
147 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
149 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
150 inside tie/overload accessors. */
154 #ifndef INCOMPLETE_TAINTS
157 pm->op_pmdynflags |= PMdf_TAINTED;
159 pm->op_pmdynflags &= ~PMdf_TAINTED;
163 if (!PM_GETRE(pm)->prelen && PL_curpm)
165 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
166 pm->op_pmflags |= PMf_WHITE;
168 pm->op_pmflags &= ~PMf_WHITE;
170 /* XXX runtime compiled output needs to move to the pad */
171 if (pm->op_pmflags & PMf_KEEP) {
172 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
173 #if !defined(USE_ITHREADS)
174 /* XXX can't change the optree at runtime either */
175 cLOGOP->op_first->op_next = PL_op->op_next;
184 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
185 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
186 register SV * const dstr = cx->sb_dstr;
187 register char *s = cx->sb_s;
188 register char *m = cx->sb_m;
189 char *orig = cx->sb_orig;
190 register REGEXP * const rx = cx->sb_rx;
192 REGEXP *old = PM_GETRE(pm);
199 rxres_restore(&cx->sb_rxres, rx);
200 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
202 if (cx->sb_iters++) {
203 const I32 saviters = cx->sb_iters;
204 if (cx->sb_iters > cx->sb_maxiters)
205 DIE(aTHX_ "Substitution loop");
207 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
208 cx->sb_rxtainted |= 2;
209 sv_catsv(dstr, POPs);
210 FREETMPS; /* Prevent excess tmp stack */
213 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
214 s == m, cx->sb_targ, NULL,
215 ((cx->sb_rflags & REXEC_COPY_STR)
216 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
217 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
219 SV * const targ = cx->sb_targ;
221 assert(cx->sb_strend >= s);
222 if(cx->sb_strend > s) {
223 if (DO_UTF8(dstr) && !SvUTF8(targ))
224 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
226 sv_catpvn(dstr, s, cx->sb_strend - s);
228 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
230 #ifdef PERL_OLD_COPY_ON_WRITE
232 sv_force_normal_flags(targ, SV_COW_DROP_PV);
238 SvPV_set(targ, SvPVX(dstr));
239 SvCUR_set(targ, SvCUR(dstr));
240 SvLEN_set(targ, SvLEN(dstr));
243 SvPV_set(dstr, (char*)0);
246 TAINT_IF(cx->sb_rxtainted & 1);
247 PUSHs(sv_2mortal(newSViv(saviters - 1)));
249 (void)SvPOK_only_UTF8(targ);
250 TAINT_IF(cx->sb_rxtainted);
254 LEAVE_SCOPE(cx->sb_oldsave);
257 RETURNOP(pm->op_next);
259 cx->sb_iters = saviters;
261 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
264 cx->sb_orig = orig = rx->subbeg;
266 cx->sb_strend = s + (cx->sb_strend - m);
268 cx->sb_m = m = rx->startp[0] + orig;
270 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
271 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
273 sv_catpvn(dstr, s, m-s);
275 cx->sb_s = rx->endp[0] + orig;
276 { /* Update the pos() information. */
277 SV * const sv = cx->sb_targ;
280 if (SvTYPE(sv) < SVt_PVMG)
281 SvUPGRADE(sv, SVt_PVMG);
282 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
283 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
284 mg = mg_find(sv, PERL_MAGIC_regex_global);
292 (void)ReREFCNT_inc(rx);
293 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
294 rxres_save(&cx->sb_rxres, rx);
295 RETURNOP(pm->op_pmreplstart);
299 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
304 if (!p || p[1] < rx->nparens) {
305 #ifdef PERL_OLD_COPY_ON_WRITE
306 i = 7 + rx->nparens * 2;
308 i = 6 + rx->nparens * 2;
317 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
318 RX_MATCH_COPIED_off(rx);
320 #ifdef PERL_OLD_COPY_ON_WRITE
321 *p++ = PTR2UV(rx->saved_copy);
322 rx->saved_copy = Nullsv;
327 *p++ = PTR2UV(rx->subbeg);
328 *p++ = (UV)rx->sublen;
329 for (i = 0; i <= rx->nparens; ++i) {
330 *p++ = (UV)rx->startp[i];
331 *p++ = (UV)rx->endp[i];
336 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
341 RX_MATCH_COPY_FREE(rx);
342 RX_MATCH_COPIED_set(rx, *p);
345 #ifdef PERL_OLD_COPY_ON_WRITE
347 SvREFCNT_dec (rx->saved_copy);
348 rx->saved_copy = INT2PTR(SV*,*p);
354 rx->subbeg = INT2PTR(char*,*p++);
355 rx->sublen = (I32)(*p++);
356 for (i = 0; i <= rx->nparens; ++i) {
357 rx->startp[i] = (I32)(*p++);
358 rx->endp[i] = (I32)(*p++);
363 Perl_rxres_free(pTHX_ void **rsp)
365 UV * const p = (UV*)*rsp;
369 void *tmp = INT2PTR(char*,*p);
372 Poison(*p, 1, sizeof(*p));
374 Safefree(INT2PTR(char*,*p));
376 #ifdef PERL_OLD_COPY_ON_WRITE
378 SvREFCNT_dec (INT2PTR(SV*,p[1]));
388 dSP; dMARK; dORIGMARK;
389 register SV * const tmpForm = *++MARK;
394 register SV *sv = Nullsv;
395 const char *item = Nullch;
399 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
400 const char *chophere = Nullch;
401 char *linemark = Nullch;
403 bool gotsome = FALSE;
405 const STRLEN fudge = SvPOK(tmpForm)
406 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
407 bool item_is_utf8 = FALSE;
408 bool targ_is_utf8 = FALSE;
414 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
415 if (SvREADONLY(tmpForm)) {
416 SvREADONLY_off(tmpForm);
417 parseres = doparseform(tmpForm);
418 SvREADONLY_on(tmpForm);
421 parseres = doparseform(tmpForm);
425 SvPV_force(PL_formtarget, len);
426 if (DO_UTF8(PL_formtarget))
428 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
430 f = SvPV_const(tmpForm, len);
431 /* need to jump to the next word */
432 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
436 const char *name = "???";
439 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
440 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
441 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
442 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
443 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
445 case FF_CHECKNL: name = "CHECKNL"; break;
446 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
447 case FF_SPACE: name = "SPACE"; break;
448 case FF_HALFSPACE: name = "HALFSPACE"; break;
449 case FF_ITEM: name = "ITEM"; break;
450 case FF_CHOP: name = "CHOP"; break;
451 case FF_LINEGLOB: name = "LINEGLOB"; break;
452 case FF_NEWLINE: name = "NEWLINE"; break;
453 case FF_MORE: name = "MORE"; break;
454 case FF_LINEMARK: name = "LINEMARK"; break;
455 case FF_END: name = "END"; break;
456 case FF_0DECIMAL: name = "0DECIMAL"; break;
457 case FF_LINESNGL: name = "LINESNGL"; break;
460 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
462 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
473 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
474 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
476 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
477 t = SvEND(PL_formtarget);
480 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
481 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
483 sv_utf8_upgrade(PL_formtarget);
484 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
485 t = SvEND(PL_formtarget);
505 if (ckWARN(WARN_SYNTAX))
506 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
513 const char *s = item = SvPV_const(sv, len);
516 itemsize = sv_len_utf8(sv);
517 if (itemsize != (I32)len) {
519 if (itemsize > fieldsize) {
520 itemsize = fieldsize;
521 itembytes = itemsize;
522 sv_pos_u2b(sv, &itembytes, 0);
526 send = chophere = s + itembytes;
536 sv_pos_b2u(sv, &itemsize);
540 item_is_utf8 = FALSE;
541 if (itemsize > fieldsize)
542 itemsize = fieldsize;
543 send = chophere = s + itemsize;
557 const char *s = item = SvPV_const(sv, len);
560 itemsize = sv_len_utf8(sv);
561 if (itemsize != (I32)len) {
563 if (itemsize <= fieldsize) {
564 const char *send = chophere = s + itemsize;
577 itemsize = fieldsize;
578 itembytes = itemsize;
579 sv_pos_u2b(sv, &itembytes, 0);
580 send = chophere = s + itembytes;
581 while (s < send || (s == send && isSPACE(*s))) {
591 if (strchr(PL_chopset, *s))
596 itemsize = chophere - item;
597 sv_pos_b2u(sv, &itemsize);
603 item_is_utf8 = FALSE;
604 if (itemsize <= fieldsize) {
605 const char *const send = chophere = s + itemsize;
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
630 if (strchr(PL_chopset, *s))
635 itemsize = chophere - item;
641 arg = fieldsize - itemsize;
650 arg = fieldsize - itemsize;
661 const char *s = item;
665 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
667 sv_utf8_upgrade(PL_formtarget);
668 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
669 t = SvEND(PL_formtarget);
673 if (UTF8_IS_CONTINUED(*s)) {
674 STRLEN skip = UTF8SKIP(s);
691 if ( !((*t++ = *s++) & ~31) )
697 if (targ_is_utf8 && !item_is_utf8) {
698 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
700 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
701 for (; t < SvEND(PL_formtarget); t++) {
714 const int ch = *t++ = *s++;
717 if ( !((*t++ = *s++) & ~31) )
726 const char *s = chophere;
744 const char *s = item = SvPV_const(sv, len);
746 if ((item_is_utf8 = DO_UTF8(sv)))
747 itemsize = sv_len_utf8(sv);
749 bool chopped = FALSE;
750 const char *const send = s + len;
752 chophere = s + itemsize;
768 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
770 SvUTF8_on(PL_formtarget);
772 SvCUR_set(sv, chophere - item);
773 sv_catsv(PL_formtarget, sv);
774 SvCUR_set(sv, itemsize);
776 sv_catsv(PL_formtarget, sv);
778 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
779 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
780 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
789 #if defined(USE_LONG_DOUBLE)
790 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
792 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
797 #if defined(USE_LONG_DOUBLE)
798 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
800 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
803 /* If the field is marked with ^ and the value is undefined,
805 if ((arg & 512) && !SvOK(sv)) {
813 /* overflow evidence */
814 if (num_overflow(value, fieldsize, arg)) {
820 /* Formats aren't yet marked for locales, so assume "yes". */
822 STORE_NUMERIC_STANDARD_SET_LOCAL();
823 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
824 RESTORE_NUMERIC_STANDARD();
831 while (t-- > linemark && *t == ' ') ;
839 if (arg) { /* repeat until fields exhausted? */
841 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
842 lines += FmLINES(PL_formtarget);
845 if (strnEQ(linemark, linemark - arg, arg))
846 DIE(aTHX_ "Runaway format");
849 SvUTF8_on(PL_formtarget);
850 FmLINES(PL_formtarget) = lines;
852 RETURNOP(cLISTOP->op_first);
863 const char *s = chophere;
864 const char *send = item + len;
866 while (isSPACE(*s) && (s < send))
871 arg = fieldsize - itemsize;
878 if (strnEQ(s1," ",3)) {
879 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
890 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
892 SvUTF8_on(PL_formtarget);
893 FmLINES(PL_formtarget) += lines;
905 if (PL_stack_base + *PL_markstack_ptr == SP) {
907 if (GIMME_V == G_SCALAR)
908 XPUSHs(sv_2mortal(newSViv(0)));
909 RETURNOP(PL_op->op_next->op_next);
911 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
912 pp_pushmark(); /* push dst */
913 pp_pushmark(); /* push src */
914 ENTER; /* enter outer scope */
917 if (PL_op->op_private & OPpGREP_LEX)
918 SAVESPTR(PAD_SVl(PL_op->op_targ));
921 ENTER; /* enter inner scope */
924 src = PL_stack_base[*PL_markstack_ptr];
926 if (PL_op->op_private & OPpGREP_LEX)
927 PAD_SVl(PL_op->op_targ) = src;
932 if (PL_op->op_type == OP_MAPSTART)
933 pp_pushmark(); /* push top */
934 return ((LOGOP*)PL_op->op_next)->op_other;
940 const I32 gimme = GIMME_V;
941 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
947 /* first, move source pointer to the next item in the source list */
948 ++PL_markstack_ptr[-1];
950 /* if there are new items, push them into the destination list */
951 if (items && gimme != G_VOID) {
952 /* might need to make room back there first */
953 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
954 /* XXX this implementation is very pessimal because the stack
955 * is repeatedly extended for every set of items. Is possible
956 * to do this without any stack extension or copying at all
957 * by maintaining a separate list over which the map iterates
958 * (like foreach does). --gsar */
960 /* everything in the stack after the destination list moves
961 * towards the end the stack by the amount of room needed */
962 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
964 /* items to shift up (accounting for the moved source pointer) */
965 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
967 /* This optimization is by Ben Tilly and it does
968 * things differently from what Sarathy (gsar)
969 * is describing. The downside of this optimization is
970 * that leaves "holes" (uninitialized and hopefully unused areas)
971 * to the Perl stack, but on the other hand this
972 * shouldn't be a problem. If Sarathy's idea gets
973 * implemented, this optimization should become
974 * irrelevant. --jhi */
976 shift = count; /* Avoid shifting too often --Ben Tilly */
981 PL_markstack_ptr[-1] += shift;
982 *PL_markstack_ptr += shift;
986 /* copy the new items down to the destination list */
987 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
988 if (gimme == G_ARRAY) {
990 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
993 /* scalar context: we don't care about which values map returns
994 * (we use undef here). And so we certainly don't want to do mortal
995 * copies of meaningless values. */
996 while (items-- > 0) {
998 *dst-- = &PL_sv_undef;
1002 LEAVE; /* exit inner scope */
1005 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1007 (void)POPMARK; /* pop top */
1008 LEAVE; /* exit outer scope */
1009 (void)POPMARK; /* pop src */
1010 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1011 (void)POPMARK; /* pop dst */
1012 SP = PL_stack_base + POPMARK; /* pop original mark */
1013 if (gimme == G_SCALAR) {
1014 if (PL_op->op_private & OPpGREP_LEX) {
1015 SV* sv = sv_newmortal();
1016 sv_setiv(sv, items);
1024 else if (gimme == G_ARRAY)
1031 ENTER; /* enter inner scope */
1034 /* set $_ to the new source item */
1035 src = PL_stack_base[PL_markstack_ptr[-1]];
1037 if (PL_op->op_private & OPpGREP_LEX)
1038 PAD_SVl(PL_op->op_targ) = src;
1042 RETURNOP(cLOGOP->op_other);
1050 if (GIMME == G_ARRAY)
1052 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1053 return cLOGOP->op_other;
1062 if (GIMME == G_ARRAY) {
1063 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1067 SV * const targ = PAD_SV(PL_op->op_targ);
1070 if (PL_op->op_private & OPpFLIP_LINENUM) {
1071 if (GvIO(PL_last_in_gv)) {
1072 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1075 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1077 flip = SvIV(sv) == SvIV(GvSV(gv));
1083 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1084 if (PL_op->op_flags & OPf_SPECIAL) {
1092 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1095 sv_setpvn(TARG, "", 0);
1101 /* This code tries to decide if "$left .. $right" should use the
1102 magical string increment, or if the range is numeric (we make
1103 an exception for .."0" [#18165]). AMS 20021031. */
1105 #define RANGE_IS_NUMERIC(left,right) ( \
1106 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1107 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1108 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1109 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1110 && (!SvOK(right) || looks_like_number(right))))
1116 if (GIMME == G_ARRAY) {
1122 if (RANGE_IS_NUMERIC(left,right)) {
1125 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1126 (SvOK(right) && SvNV(right) > IV_MAX))
1127 DIE(aTHX_ "Range iterator outside integer range");
1138 SV * const sv = sv_2mortal(newSViv(i++));
1143 SV * const final = sv_mortalcopy(right);
1145 const char * const tmps = SvPV_const(final, len);
1147 SV *sv = sv_mortalcopy(left);
1148 SvPV_force_nolen(sv);
1149 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1151 if (strEQ(SvPVX_const(sv),tmps))
1153 sv = sv_2mortal(newSVsv(sv));
1160 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1164 if (PL_op->op_private & OPpFLIP_LINENUM) {
1165 if (GvIO(PL_last_in_gv)) {
1166 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1169 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1170 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1178 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1179 sv_catpvn(targ, "E0", 2);
1189 static const char * const context_name[] = {
1200 S_dopoptolabel(pTHX_ const char *label)
1204 for (i = cxstack_ix; i >= 0; i--) {
1205 register const PERL_CONTEXT * const cx = &cxstack[i];
1206 switch (CxTYPE(cx)) {
1212 if (ckWARN(WARN_EXITING))
1213 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1214 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1215 if (CxTYPE(cx) == CXt_NULL)
1219 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1221 (long)i, cx->blk_loop.label));
1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1232 Perl_dowantarray(pTHX)
1234 const I32 gimme = block_gimme();
1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1239 Perl_block_gimme(pTHX)
1241 const I32 cxix = dopoptosub(cxstack_ix);
1245 switch (cxstack[cxix].blk_gimme) {
1253 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1260 Perl_is_lvalue_sub(pTHX)
1262 const I32 cxix = dopoptosub(cxstack_ix);
1263 assert(cxix >= 0); /* We should only be called from inside subs */
1265 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1266 return cxstack[cxix].blk_sub.lval;
1272 S_dopoptosub(pTHX_ I32 startingblock)
1274 return dopoptosub_at(cxstack, startingblock);
1278 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1281 for (i = startingblock; i >= 0; i--) {
1282 register const PERL_CONTEXT * const cx = &cxstk[i];
1283 switch (CxTYPE(cx)) {
1289 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1297 S_dopoptoeval(pTHX_ I32 startingblock)
1300 for (i = startingblock; i >= 0; i--) {
1301 register const PERL_CONTEXT *cx = &cxstack[i];
1302 switch (CxTYPE(cx)) {
1306 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1314 S_dopoptoloop(pTHX_ I32 startingblock)
1317 for (i = startingblock; i >= 0; i--) {
1318 register const PERL_CONTEXT * const cx = &cxstack[i];
1319 switch (CxTYPE(cx)) {
1325 if (ckWARN(WARN_EXITING))
1326 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1327 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1328 if ((CxTYPE(cx)) == CXt_NULL)
1332 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1340 Perl_dounwind(pTHX_ I32 cxix)
1344 while (cxstack_ix > cxix) {
1346 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1347 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1348 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1349 /* Note: we don't need to restore the base context info till the end. */
1350 switch (CxTYPE(cx)) {
1353 continue; /* not break */
1372 PERL_UNUSED_VAR(optype);
1376 Perl_qerror(pTHX_ SV *err)
1379 sv_catsv(ERRSV, err);
1381 sv_catsv(PL_errors, err);
1383 Perl_warn(aTHX_ "%"SVf, err);
1388 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1397 if (PL_in_eval & EVAL_KEEPERR) {
1398 static const char prefix[] = "\t(in cleanup) ";
1399 SV * const err = ERRSV;
1400 const char *e = Nullch;
1402 sv_setpvn(err,"",0);
1403 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1405 e = SvPV_const(err, len);
1407 if (*e != *message || strNE(e,message))
1411 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1412 sv_catpvn(err, prefix, sizeof(prefix)-1);
1413 sv_catpvn(err, message, msglen);
1414 if (ckWARN(WARN_MISC)) {
1415 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1416 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1421 sv_setpvn(ERRSV, message, msglen);
1425 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1426 && PL_curstackinfo->si_prev)
1434 register PERL_CONTEXT *cx;
1437 if (cxix < cxstack_ix)
1440 POPBLOCK(cx,PL_curpm);
1441 if (CxTYPE(cx) != CXt_EVAL) {
1443 message = SvPVx_const(ERRSV, msglen);
1444 PerlIO_write(Perl_error_log, "panic: die ", 11);
1445 PerlIO_write(Perl_error_log, message, msglen);
1450 if (gimme == G_SCALAR)
1451 *++newsp = &PL_sv_undef;
1452 PL_stack_sp = newsp;
1456 /* LEAVE could clobber PL_curcop (see save_re_context())
1457 * XXX it might be better to find a way to avoid messing with
1458 * PL_curcop in save_re_context() instead, but this is a more
1459 * minimal fix --GSAR */
1460 PL_curcop = cx->blk_oldcop;
1462 if (optype == OP_REQUIRE) {
1463 const char* const msg = SvPVx_nolen_const(ERRSV);
1464 SV * const nsv = cx->blk_eval.old_namesv;
1465 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1467 DIE(aTHX_ "%sCompilation failed in require",
1468 *msg ? msg : "Unknown error\n");
1470 assert(CxTYPE(cx) == CXt_EVAL);
1471 return cx->blk_eval.retop;
1475 message = SvPVx_const(ERRSV, msglen);
1477 write_to_stderr(message, msglen);
1486 if (SvTRUE(left) != SvTRUE(right))
1495 register I32 cxix = dopoptosub(cxstack_ix);
1496 register const PERL_CONTEXT *cx;
1497 register const PERL_CONTEXT *ccstack = cxstack;
1498 const PERL_SI *top_si = PL_curstackinfo;
1500 const char *stashname;
1507 /* we may be in a higher stacklevel, so dig down deeper */
1508 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1509 top_si = top_si->si_prev;
1510 ccstack = top_si->si_cxstack;
1511 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1514 if (GIMME != G_ARRAY) {
1520 /* caller() should not report the automatic calls to &DB::sub */
1521 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1522 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1526 cxix = dopoptosub_at(ccstack, cxix - 1);
1529 cx = &ccstack[cxix];
1530 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1531 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1532 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1533 field below is defined for any cx. */
1534 /* caller() should not report the automatic calls to &DB::sub */
1535 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1536 cx = &ccstack[dbcxix];
1539 stashname = CopSTASHPV(cx->blk_oldcop);
1540 if (GIMME != G_ARRAY) {
1543 PUSHs(&PL_sv_undef);
1546 sv_setpv(TARG, stashname);
1555 PUSHs(&PL_sv_undef);
1557 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1558 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1559 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1562 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1563 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1564 /* So is ccstack[dbcxix]. */
1566 SV * const sv = NEWSV(49, 0);
1567 gv_efullname3(sv, cvgv, Nullch);
1568 PUSHs(sv_2mortal(sv));
1569 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1572 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1573 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1577 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1578 PUSHs(sv_2mortal(newSViv(0)));
1580 gimme = (I32)cx->blk_gimme;
1581 if (gimme == G_VOID)
1582 PUSHs(&PL_sv_undef);
1584 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1585 if (CxTYPE(cx) == CXt_EVAL) {
1587 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1588 PUSHs(cx->blk_eval.cur_text);
1592 else if (cx->blk_eval.old_namesv) {
1593 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1596 /* eval BLOCK (try blocks have old_namesv == 0) */
1598 PUSHs(&PL_sv_undef);
1599 PUSHs(&PL_sv_undef);
1603 PUSHs(&PL_sv_undef);
1604 PUSHs(&PL_sv_undef);
1606 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1607 && CopSTASH_eq(PL_curcop, PL_debstash))
1609 AV * const ary = cx->blk_sub.argarray;
1610 const int off = AvARRAY(ary) - AvALLOC(ary);
1613 GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
1614 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1616 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1619 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1620 av_extend(PL_dbargs, AvFILLp(ary) + off);
1621 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1622 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1624 /* XXX only hints propagated via op_private are currently
1625 * visible (others are not easily accessible, since they
1626 * use the global PL_hints) */
1627 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1628 HINT_PRIVATE_MASK)));
1631 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
1633 if (old_warnings == pWARN_NONE ||
1634 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1635 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1636 else if (old_warnings == pWARN_ALL ||
1637 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1638 /* Get the bit mask for $warnings::Bits{all}, because
1639 * it could have been extended by warnings::register */
1641 HV * const bits = get_hv("warnings::Bits", FALSE);
1642 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1643 mask = newSVsv(*bits_all);
1646 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1650 mask = newSVsv(old_warnings);
1651 PUSHs(sv_2mortal(mask));
1659 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1660 sv_reset(tmps, CopSTASH(PL_curcop));
1665 /* like pp_nextstate, but used instead when the debugger is active */
1670 PL_curcop = (COP*)PL_op;
1671 TAINT_NOT; /* Each statement is presumed innocent */
1672 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1675 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1676 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1679 register PERL_CONTEXT *cx;
1680 const I32 gimme = G_ARRAY;
1682 GV * const gv = PL_DBgv;
1683 register CV * const cv = GvCV(gv);
1686 DIE(aTHX_ "No DB::DB routine defined");
1688 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1689 /* don't do recursive DB::DB call */
1704 (void)(*CvXSUB(cv))(aTHX_ cv);
1711 PUSHBLOCK(cx, CXt_SUB, SP);
1713 cx->blk_sub.retop = PL_op->op_next;
1716 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1717 RETURNOP(CvSTART(cv));
1727 register PERL_CONTEXT *cx;
1728 const I32 gimme = GIMME_V;
1730 U32 cxtype = CXt_LOOP;
1738 if (PL_op->op_targ) {
1739 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1740 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1741 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1742 SVs_PADSTALE, SVs_PADSTALE);
1744 #ifndef USE_ITHREADS
1745 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1748 SAVEPADSV(PL_op->op_targ);
1749 iterdata = INT2PTR(void*, PL_op->op_targ);
1750 cxtype |= CXp_PADVAR;
1754 GV * const gv = (GV*)POPs;
1755 svp = &GvSV(gv); /* symbol table variable */
1756 SAVEGENERICSV(*svp);
1759 iterdata = (void*)gv;
1765 PUSHBLOCK(cx, cxtype, SP);
1767 PUSHLOOP(cx, iterdata, MARK);
1769 PUSHLOOP(cx, svp, MARK);
1771 if (PL_op->op_flags & OPf_STACKED) {
1772 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1773 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1775 SV * const right = (SV*)cx->blk_loop.iterary;
1778 if (RANGE_IS_NUMERIC(sv,right)) {
1779 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1780 (SvOK(right) && SvNV(right) >= IV_MAX))
1781 DIE(aTHX_ "Range iterator outside integer range");
1782 cx->blk_loop.iterix = SvIV(sv);
1783 cx->blk_loop.itermax = SvIV(right);
1785 /* for correct -Dstv display */
1786 cx->blk_oldsp = sp - PL_stack_base;
1790 cx->blk_loop.iterlval = newSVsv(sv);
1791 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1792 (void) SvPV_nolen_const(right);
1795 else if (PL_op->op_private & OPpITER_REVERSED) {
1796 cx->blk_loop.itermax = 0;
1797 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1802 cx->blk_loop.iterary = PL_curstack;
1803 AvFILLp(PL_curstack) = SP - PL_stack_base;
1804 if (PL_op->op_private & OPpITER_REVERSED) {
1805 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1806 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1809 cx->blk_loop.iterix = MARK - PL_stack_base;
1819 register PERL_CONTEXT *cx;
1820 const I32 gimme = GIMME_V;
1826 PUSHBLOCK(cx, CXt_LOOP, SP);
1827 PUSHLOOP(cx, 0, SP);
1835 register PERL_CONTEXT *cx;
1842 assert(CxTYPE(cx) == CXt_LOOP);
1844 newsp = PL_stack_base + cx->blk_loop.resetsp;
1847 if (gimme == G_VOID)
1849 else if (gimme == G_SCALAR) {
1851 *++newsp = sv_mortalcopy(*SP);
1853 *++newsp = &PL_sv_undef;
1857 *++newsp = sv_mortalcopy(*++mark);
1858 TAINT_NOT; /* Each item is independent */
1864 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1865 PL_curpm = newpm; /* ... and pop $1 et al */
1876 register PERL_CONTEXT *cx;
1877 bool popsub2 = FALSE;
1878 bool clear_errsv = FALSE;
1886 const I32 cxix = dopoptosub(cxstack_ix);
1889 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1890 * sort block, which is a CXt_NULL
1893 PL_stack_base[1] = *PL_stack_sp;
1894 PL_stack_sp = PL_stack_base + 1;
1898 DIE(aTHX_ "Can't return outside a subroutine");
1900 if (cxix < cxstack_ix)
1903 if (CxMULTICALL(&cxstack[cxix])) {
1904 gimme = cxstack[cxix].blk_gimme;
1905 if (gimme == G_VOID)
1906 PL_stack_sp = PL_stack_base;
1907 else if (gimme == G_SCALAR) {
1908 PL_stack_base[1] = *PL_stack_sp;
1909 PL_stack_sp = PL_stack_base + 1;
1915 switch (CxTYPE(cx)) {
1918 retop = cx->blk_sub.retop;
1919 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1922 if (!(PL_in_eval & EVAL_KEEPERR))
1925 retop = cx->blk_eval.retop;
1929 if (optype == OP_REQUIRE &&
1930 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1932 /* Unassume the success we assumed earlier. */
1933 SV * const nsv = cx->blk_eval.old_namesv;
1934 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1935 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1940 retop = cx->blk_sub.retop;
1943 DIE(aTHX_ "panic: return");
1947 if (gimme == G_SCALAR) {
1950 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1952 *++newsp = SvREFCNT_inc(*SP);
1957 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1959 *++newsp = sv_mortalcopy(sv);
1964 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1967 *++newsp = sv_mortalcopy(*SP);
1970 *++newsp = &PL_sv_undef;
1972 else if (gimme == G_ARRAY) {
1973 while (++MARK <= SP) {
1974 *++newsp = (popsub2 && SvTEMP(*MARK))
1975 ? *MARK : sv_mortalcopy(*MARK);
1976 TAINT_NOT; /* Each item is independent */
1979 PL_stack_sp = newsp;
1982 /* Stack values are safe: */
1985 POPSUB(cx,sv); /* release CV and @_ ... */
1989 PL_curpm = newpm; /* ... and pop $1 et al */
1993 sv_setpvn(ERRSV,"",0);
2001 register PERL_CONTEXT *cx;
2012 if (PL_op->op_flags & OPf_SPECIAL) {
2013 cxix = dopoptoloop(cxstack_ix);
2015 DIE(aTHX_ "Can't \"last\" outside a loop block");
2018 cxix = dopoptolabel(cPVOP->op_pv);
2020 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2022 if (cxix < cxstack_ix)
2026 cxstack_ix++; /* temporarily protect top context */
2028 switch (CxTYPE(cx)) {
2031 newsp = PL_stack_base + cx->blk_loop.resetsp;
2032 nextop = cx->blk_loop.last_op->op_next;
2036 nextop = cx->blk_sub.retop;
2040 nextop = cx->blk_eval.retop;
2044 nextop = cx->blk_sub.retop;
2047 DIE(aTHX_ "panic: last");
2051 if (gimme == G_SCALAR) {
2053 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2054 ? *SP : sv_mortalcopy(*SP);
2056 *++newsp = &PL_sv_undef;
2058 else if (gimme == G_ARRAY) {
2059 while (++MARK <= SP) {
2060 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2061 ? *MARK : sv_mortalcopy(*MARK);
2062 TAINT_NOT; /* Each item is independent */
2070 /* Stack values are safe: */
2073 POPLOOP(cx); /* release loop vars ... */
2077 POPSUB(cx,sv); /* release CV and @_ ... */
2080 PL_curpm = newpm; /* ... and pop $1 et al */
2083 PERL_UNUSED_VAR(optype);
2084 PERL_UNUSED_VAR(gimme);
2092 register PERL_CONTEXT *cx;
2095 if (PL_op->op_flags & OPf_SPECIAL) {
2096 cxix = dopoptoloop(cxstack_ix);
2098 DIE(aTHX_ "Can't \"next\" outside a loop block");
2101 cxix = dopoptolabel(cPVOP->op_pv);
2103 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2105 if (cxix < cxstack_ix)
2108 /* clear off anything above the scope we're re-entering, but
2109 * save the rest until after a possible continue block */
2110 inner = PL_scopestack_ix;
2112 if (PL_scopestack_ix < inner)
2113 leave_scope(PL_scopestack[PL_scopestack_ix]);
2114 PL_curcop = cx->blk_oldcop;
2115 return cx->blk_loop.next_op;
2122 register PERL_CONTEXT *cx;
2126 if (PL_op->op_flags & OPf_SPECIAL) {
2127 cxix = dopoptoloop(cxstack_ix);
2129 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2132 cxix = dopoptolabel(cPVOP->op_pv);
2134 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2136 if (cxix < cxstack_ix)
2139 redo_op = cxstack[cxix].blk_loop.redo_op;
2140 if (redo_op->op_type == OP_ENTER) {
2141 /* pop one less context to avoid $x being freed in while (my $x..) */
2143 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2144 redo_op = redo_op->op_next;
2148 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2149 LEAVE_SCOPE(oldsave);
2151 PL_curcop = cx->blk_oldcop;
2156 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2159 static const char too_deep[] = "Target of goto is too deeply nested";
2162 Perl_croak(aTHX_ too_deep);
2163 if (o->op_type == OP_LEAVE ||
2164 o->op_type == OP_SCOPE ||
2165 o->op_type == OP_LEAVELOOP ||
2166 o->op_type == OP_LEAVESUB ||
2167 o->op_type == OP_LEAVETRY)
2169 *ops++ = cUNOPo->op_first;
2171 Perl_croak(aTHX_ too_deep);
2174 if (o->op_flags & OPf_KIDS) {
2176 /* First try all the kids at this level, since that's likeliest. */
2177 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2178 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2179 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2183 if (kid == PL_lastgotoprobe)
2185 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2188 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2189 ops[-1]->op_type == OP_DBSTATE)
2194 if ((o = dofindlabel(kid, label, ops, oplimit)))
2207 register PERL_CONTEXT *cx;
2208 #define GOTO_DEPTH 64
2209 OP *enterops[GOTO_DEPTH];
2210 const char *label = 0;
2211 const bool do_dump = (PL_op->op_type == OP_DUMP);
2212 static const char must_have_label[] = "goto must have label";
2214 if (PL_op->op_flags & OPf_STACKED) {
2215 SV * const sv = POPs;
2217 /* This egregious kludge implements goto &subroutine */
2218 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2220 register PERL_CONTEXT *cx;
2221 CV* cv = (CV*)SvRV(sv);
2228 if (!CvROOT(cv) && !CvXSUB(cv)) {
2229 const GV * const gv = CvGV(cv);
2233 /* autoloaded stub? */
2234 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2236 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2237 GvNAMELEN(gv), FALSE);
2238 if (autogv && (cv = GvCV(autogv)))
2240 tmpstr = sv_newmortal();
2241 gv_efullname3(tmpstr, gv, Nullch);
2242 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2244 DIE(aTHX_ "Goto undefined subroutine");
2247 /* First do some returnish stuff. */
2248 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2250 cxix = dopoptosub(cxstack_ix);
2252 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2253 if (cxix < cxstack_ix)
2257 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2258 if (CxTYPE(cx) == CXt_EVAL) {
2260 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2262 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2264 else if (CxMULTICALL(cx))
2265 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2266 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2267 /* put @_ back onto stack */
2268 AV* av = cx->blk_sub.argarray;
2270 items = AvFILLp(av) + 1;
2271 EXTEND(SP, items+1); /* @_ could have been extended. */
2272 Copy(AvARRAY(av), SP + 1, items, SV*);
2273 SvREFCNT_dec(GvAV(PL_defgv));
2274 GvAV(PL_defgv) = cx->blk_sub.savearray;
2276 /* abandon @_ if it got reified */
2281 av_extend(av, items-1);
2283 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2286 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2287 AV* const av = GvAV(PL_defgv);
2288 items = AvFILLp(av) + 1;
2289 EXTEND(SP, items+1); /* @_ could have been extended. */
2290 Copy(AvARRAY(av), SP + 1, items, SV*);
2294 if (CxTYPE(cx) == CXt_SUB &&
2295 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2296 SvREFCNT_dec(cx->blk_sub.cv);
2297 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2298 LEAVE_SCOPE(oldsave);
2300 /* Now do some callish stuff. */
2302 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2304 OP* retop = cx->blk_sub.retop;
2307 for (index=0; index<items; index++)
2308 sv_2mortal(SP[-index]);
2310 #ifdef PERL_XSUB_OLDSTYLE
2311 if (CvOLDSTYLE(cv)) {
2312 I32 (*fp3)(int,int,int);
2317 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2318 items = (*fp3)(CvXSUBANY(cv).any_i32,
2319 mark - PL_stack_base + 1,
2321 SP = PL_stack_base + items;
2324 #endif /* PERL_XSUB_OLDSTYLE */
2329 /* XS subs don't have a CxSUB, so pop it */
2330 POPBLOCK(cx, PL_curpm);
2331 /* Push a mark for the start of arglist */
2334 (void)(*CvXSUB(cv))(aTHX_ cv);
2335 /* Put these at the bottom since the vars are set but not used */
2336 PERL_UNUSED_VAR(newsp);
2337 PERL_UNUSED_VAR(gimme);
2343 AV* padlist = CvPADLIST(cv);
2344 if (CxTYPE(cx) == CXt_EVAL) {
2345 PL_in_eval = cx->blk_eval.old_in_eval;
2346 PL_eval_root = cx->blk_eval.old_eval_root;
2347 cx->cx_type = CXt_SUB;
2348 cx->blk_sub.hasargs = 0;
2350 cx->blk_sub.cv = cv;
2351 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2354 if (CvDEPTH(cv) < 2)
2355 (void)SvREFCNT_inc(cv);
2357 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2358 sub_crush_depth(cv);
2359 pad_push(padlist, CvDEPTH(cv));
2362 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2363 if (cx->blk_sub.hasargs)
2365 AV* av = (AV*)PAD_SVl(0);
2368 cx->blk_sub.savearray = GvAV(PL_defgv);
2369 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2370 CX_CURPAD_SAVE(cx->blk_sub);
2371 cx->blk_sub.argarray = av;
2373 if (items >= AvMAX(av) + 1) {
2375 if (AvARRAY(av) != ary) {
2376 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2377 SvPV_set(av, (char*)ary);
2379 if (items >= AvMAX(av) + 1) {
2380 AvMAX(av) = items - 1;
2381 Renew(ary,items+1,SV*);
2383 SvPV_set(av, (char*)ary);
2387 Copy(mark,AvARRAY(av),items,SV*);
2388 AvFILLp(av) = items - 1;
2389 assert(!AvREAL(av));
2391 /* transfer 'ownership' of refcnts to new @_ */
2401 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2403 * We do not care about using sv to call CV;
2404 * it's for informational purposes only.
2406 SV * const sv = GvSV(PL_DBsub);
2410 if (PERLDB_SUB_NN) {
2411 const int type = SvTYPE(sv);
2412 if (type < SVt_PVIV && type != SVt_IV)
2413 sv_upgrade(sv, SVt_PVIV);
2415 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2417 gv_efullname3(sv, CvGV(cv), Nullch);
2420 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2421 PUSHMARK( PL_stack_sp );
2422 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2426 RETURNOP(CvSTART(cv));
2430 label = SvPV_nolen_const(sv);
2431 if (!(do_dump || *label))
2432 DIE(aTHX_ must_have_label);
2435 else if (PL_op->op_flags & OPf_SPECIAL) {
2437 DIE(aTHX_ must_have_label);
2440 label = cPVOP->op_pv;
2442 if (label && *label) {
2444 bool leaving_eval = FALSE;
2445 bool in_block = FALSE;
2446 PERL_CONTEXT *last_eval_cx = 0;
2450 PL_lastgotoprobe = 0;
2452 for (ix = cxstack_ix; ix >= 0; ix--) {
2454 switch (CxTYPE(cx)) {
2456 leaving_eval = TRUE;
2457 if (!CxTRYBLOCK(cx)) {
2458 gotoprobe = (last_eval_cx ?
2459 last_eval_cx->blk_eval.old_eval_root :
2464 /* else fall through */
2466 gotoprobe = cx->blk_oldcop->op_sibling;
2472 gotoprobe = cx->blk_oldcop->op_sibling;
2475 gotoprobe = PL_main_root;
2478 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2479 gotoprobe = CvROOT(cx->blk_sub.cv);
2485 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2488 DIE(aTHX_ "panic: goto");
2489 gotoprobe = PL_main_root;
2493 retop = dofindlabel(gotoprobe, label,
2494 enterops, enterops + GOTO_DEPTH);
2498 PL_lastgotoprobe = gotoprobe;
2501 DIE(aTHX_ "Can't find label %s", label);
2503 /* if we're leaving an eval, check before we pop any frames
2504 that we're not going to punt, otherwise the error
2507 if (leaving_eval && *enterops && enterops[1]) {
2509 for (i = 1; enterops[i]; i++)
2510 if (enterops[i]->op_type == OP_ENTERITER)
2511 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2514 /* pop unwanted frames */
2516 if (ix < cxstack_ix) {
2523 oldsave = PL_scopestack[PL_scopestack_ix];
2524 LEAVE_SCOPE(oldsave);
2527 /* push wanted frames */
2529 if (*enterops && enterops[1]) {
2530 OP * const oldop = PL_op;
2531 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2532 for (; enterops[ix]; ix++) {
2533 PL_op = enterops[ix];
2534 /* Eventually we may want to stack the needed arguments
2535 * for each op. For now, we punt on the hard ones. */
2536 if (PL_op->op_type == OP_ENTERITER)
2537 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2538 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2546 if (!retop) retop = PL_main_start;
2548 PL_restartop = retop;
2549 PL_do_undump = TRUE;
2553 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2554 PL_do_undump = FALSE;
2570 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2572 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2575 PL_exit_flags |= PERL_EXIT_EXPECTED;
2577 PUSHs(&PL_sv_undef);
2585 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2586 register I32 match = I_32(value);
2589 if (((NV)match) > value)
2590 --match; /* was fractional--truncate other way */
2592 match -= cCOP->uop.scop.scop_offset;
2595 else if (match > cCOP->uop.scop.scop_max)
2596 match = cCOP->uop.scop.scop_max;
2597 PL_op = cCOP->uop.scop.scop_next[match];
2607 PL_op = PL_op->op_next; /* can't assume anything */
2609 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2610 match -= cCOP->uop.scop.scop_offset;
2613 else if (match > cCOP->uop.scop.scop_max)
2614 match = cCOP->uop.scop.scop_max;
2615 PL_op = cCOP->uop.scop.scop_next[match];
2624 S_save_lines(pTHX_ AV *array, SV *sv)
2626 const char *s = SvPVX_const(sv);
2627 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2630 while (s && s < send) {
2632 SV * const tmpstr = NEWSV(85,0);
2634 sv_upgrade(tmpstr, SVt_PVMG);
2635 t = strchr(s, '\n');
2641 sv_setpvn(tmpstr, s, t - s);
2642 av_store(array, line++, tmpstr);
2648 S_docatch_body(pTHX)
2655 S_docatch(pTHX_ OP *o)
2658 OP * const oldop = PL_op;
2662 assert(CATCH_GET == TRUE);
2669 assert(cxstack_ix >= 0);
2670 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2671 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2676 /* die caught by an inner eval - continue inner loop */
2678 /* NB XXX we rely on the old popped CxEVAL still being at the top
2679 * of the stack; the way die_where() currently works, this
2680 * assumption is valid. In theory The cur_top_env value should be
2681 * returned in another global, the way retop (aka PL_restartop)
2683 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2686 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2688 PL_op = PL_restartop;
2705 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2706 /* sv Text to convert to OP tree. */
2707 /* startop op_free() this to undo. */
2708 /* code Short string id of the caller. */
2710 /* FIXME - how much of this code is common with pp_entereval? */
2711 dVAR; dSP; /* Make POPBLOCK work. */
2718 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2719 char *tmpbuf = tbuf;
2722 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2728 /* switch to eval mode */
2730 if (IN_PERL_COMPILETIME) {
2731 SAVECOPSTASH_FREE(&PL_compiling);
2732 CopSTASH_set(&PL_compiling, PL_curstash);
2734 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2735 SV * const sv = sv_newmortal();
2736 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2737 code, (unsigned long)++PL_evalseq,
2738 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2743 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2744 (unsigned long)++PL_evalseq);
2745 SAVECOPFILE_FREE(&PL_compiling);
2746 CopFILE_set(&PL_compiling, tmpbuf+2);
2747 SAVECOPLINE(&PL_compiling);
2748 CopLINE_set(&PL_compiling, 1);
2749 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2750 deleting the eval's FILEGV from the stash before gv_check() runs
2751 (i.e. before run-time proper). To work around the coredump that
2752 ensues, we always turn GvMULTI_on for any globals that were
2753 introduced within evals. See force_ident(). GSAR 96-10-12 */
2754 safestr = savepvn(tmpbuf, len);
2755 SAVEDELETE(PL_defstash, safestr, len);
2757 #ifdef OP_IN_REGISTER
2763 /* we get here either during compilation, or via pp_regcomp at runtime */
2764 runtime = IN_PERL_RUNTIME;
2766 runcv = find_runcv(NULL);
2769 PL_op->op_type = OP_ENTEREVAL;
2770 PL_op->op_flags = 0; /* Avoid uninit warning. */
2771 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2772 PUSHEVAL(cx, 0, Nullgv);
2775 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2777 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2778 POPBLOCK(cx,PL_curpm);
2781 (*startop)->op_type = OP_NULL;
2782 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2784 /* XXX DAPM do this properly one year */
2785 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2787 if (IN_PERL_COMPILETIME)
2788 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2789 #ifdef OP_IN_REGISTER
2792 PERL_UNUSED_VAR(newsp);
2793 PERL_UNUSED_VAR(optype);
2800 =for apidoc find_runcv
2802 Locate the CV corresponding to the currently executing sub or eval.
2803 If db_seqp is non_null, skip CVs that are in the DB package and populate
2804 *db_seqp with the cop sequence number at the point that the DB:: code was
2805 entered. (allows debuggers to eval in the scope of the breakpoint rather
2806 than in the scope of the debugger itself).
2812 Perl_find_runcv(pTHX_ U32 *db_seqp)
2817 *db_seqp = PL_curcop->cop_seq;
2818 for (si = PL_curstackinfo; si; si = si->si_prev) {
2820 for (ix = si->si_cxix; ix >= 0; ix--) {
2821 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2822 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2823 CV * const cv = cx->blk_sub.cv;
2824 /* skip DB:: code */
2825 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2826 *db_seqp = cx->blk_oldcop->cop_seq;
2831 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2839 /* Compile a require/do, an eval '', or a /(?{...})/.
2840 * In the last case, startop is non-null, and contains the address of
2841 * a pointer that should be set to the just-compiled code.
2842 * outside is the lexically enclosing CV (if any) that invoked us.
2845 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2847 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2850 OP * const saveop = PL_op;
2852 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2853 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2858 SAVESPTR(PL_compcv);
2859 PL_compcv = (CV*)NEWSV(1104,0);
2860 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2861 CvEVAL_on(PL_compcv);
2862 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2863 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2865 CvOUTSIDE_SEQ(PL_compcv) = seq;
2866 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2868 /* set up a scratch pad */
2870 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2873 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2875 /* make sure we compile in the right package */
2877 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2878 SAVESPTR(PL_curstash);
2879 PL_curstash = CopSTASH(PL_curcop);
2881 SAVESPTR(PL_beginav);
2882 PL_beginav = newAV();
2883 SAVEFREESV(PL_beginav);
2884 SAVEI32(PL_error_count);
2886 /* try to compile it */
2888 PL_eval_root = Nullop;
2890 PL_curcop = &PL_compiling;
2891 PL_curcop->cop_arybase = 0;
2892 if (saveop && saveop->op_flags & OPf_SPECIAL)
2893 PL_in_eval |= EVAL_KEEPERR;
2895 sv_setpvn(ERRSV,"",0);
2896 if (yyparse() || PL_error_count || !PL_eval_root) {
2897 SV **newsp; /* Used by POPBLOCK. */
2898 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2899 I32 optype = 0; /* Might be reset by POPEVAL. */
2904 op_free(PL_eval_root);
2905 PL_eval_root = Nullop;
2907 SP = PL_stack_base + POPMARK; /* pop original mark */
2909 POPBLOCK(cx,PL_curpm);
2915 msg = SvPVx_nolen_const(ERRSV);
2916 if (optype == OP_REQUIRE) {
2917 const SV * const nsv = cx->blk_eval.old_namesv;
2918 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2920 DIE(aTHX_ "%sCompilation failed in require",
2921 *msg ? msg : "Unknown error\n");
2924 POPBLOCK(cx,PL_curpm);
2926 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2927 (*msg ? msg : "Unknown error\n"));
2931 sv_setpv(ERRSV, "Compilation error");
2934 PERL_UNUSED_VAR(newsp);
2937 CopLINE_set(&PL_compiling, 0);
2939 *startop = PL_eval_root;
2941 SAVEFREEOP(PL_eval_root);
2943 /* Set the context for this new optree.
2944 * If the last op is an OP_REQUIRE, force scalar context.
2945 * Otherwise, propagate the context from the eval(). */
2946 if (PL_eval_root->op_type == OP_LEAVEEVAL
2947 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2948 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2950 scalar(PL_eval_root);
2951 else if (gimme & G_VOID)
2952 scalarvoid(PL_eval_root);
2953 else if (gimme & G_ARRAY)
2956 scalar(PL_eval_root);
2958 DEBUG_x(dump_eval());
2960 /* Register with debugger: */
2961 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2962 CV * const cv = get_cv("DB::postponed", FALSE);
2966 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2968 call_sv((SV*)cv, G_DISCARD);
2972 /* compiled okay, so do it */
2974 CvDEPTH(PL_compcv) = 1;
2975 SP = PL_stack_base + POPMARK; /* pop original mark */
2976 PL_op = saveop; /* The caller may need it. */
2977 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2979 RETURNOP(PL_eval_start);
2983 S_check_type_and_open(pTHX_ const char *name, const char *mode)
2987 st_rc = PerlLIO_stat(name, &st);
2992 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
2993 Perl_die(aTHX_ "%s %s not allowed in require",
2994 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
2996 return PerlIO_open(name, mode);
3000 S_doopen_pm(pTHX_ const char *name, const char *mode)
3002 #ifndef PERL_DISABLE_PMC
3003 const STRLEN namelen = strlen(name);
3006 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3007 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3008 const char * const pmc = SvPV_nolen_const(pmcsv);
3010 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3011 fp = check_type_and_open(aTHX_ name, mode);
3015 if (PerlLIO_stat(name, &pmstat) < 0 ||
3016 pmstat.st_mtime < pmcstat.st_mtime)
3018 fp = check_type_and_open(aTHX_ pmc, mode);
3021 fp = check_type_and_open(aTHX_ name, mode);
3024 SvREFCNT_dec(pmcsv);
3027 fp = check_type_and_open(aTHX_ name, mode);
3031 return check_type_and_open(aTHX_ name, mode);
3032 #endif /* !PERL_DISABLE_PMC */
3038 register PERL_CONTEXT *cx;
3042 const char *tryname = Nullch;
3043 SV *namesv = Nullsv;
3044 const I32 gimme = GIMME_V;
3045 PerlIO *tryrsfp = 0;
3046 int filter_has_file = 0;
3047 GV *filter_child_proc = 0;
3048 SV *filter_state = 0;
3055 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3056 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3057 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3058 "v-string in use/require non-portable");
3060 sv = new_version(sv);
3061 if (!sv_derived_from(PL_patchlevel, "version"))
3062 (void *)upg_version(PL_patchlevel);
3063 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3064 if ( vcmp(sv,PL_patchlevel) < 0 )
3065 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3066 vnormal(sv), vnormal(PL_patchlevel));
3069 if ( vcmp(sv,PL_patchlevel) > 0 )
3070 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3071 vnormal(sv), vnormal(PL_patchlevel));
3076 name = SvPV_const(sv, len);
3077 if (!(name && len > 0 && *name))
3078 DIE(aTHX_ "Null filename used");
3079 TAINT_PROPER("require");
3080 if (PL_op->op_type == OP_REQUIRE) {
3081 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3083 if (*svp != &PL_sv_undef)
3086 DIE(aTHX_ "Compilation failed in require");
3090 /* prepare to compile file */
3092 if (path_is_absolute(name)) {
3094 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3096 #ifdef MACOS_TRADITIONAL
3100 MacPerl_CanonDir(name, newname, 1);
3101 if (path_is_absolute(newname)) {
3103 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3108 AV * const ar = GvAVn(PL_incgv);
3112 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3115 namesv = NEWSV(806, 0);
3116 for (i = 0; i <= AvFILL(ar); i++) {
3117 SV *dirsv = *av_fetch(ar, i, TRUE);
3123 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3124 && !sv_isobject(loader))
3126 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3129 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3130 PTR2UV(SvRV(dirsv)), name);
3131 tryname = SvPVX_const(namesv);
3142 if (sv_isobject(loader))
3143 count = call_method("INC", G_ARRAY);
3145 count = call_sv(loader, G_ARRAY);
3155 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3159 if (SvTYPE(arg) == SVt_PVGV) {
3160 IO *io = GvIO((GV *)arg);
3165 tryrsfp = IoIFP(io);
3166 if (IoTYPE(io) == IoTYPE_PIPE) {
3167 /* reading from a child process doesn't
3168 nest -- when returning from reading
3169 the inner module, the outer one is
3170 unreadable (closed?) I've tried to
3171 save the gv to manage the lifespan of
3172 the pipe, but this didn't help. XXX */
3173 filter_child_proc = (GV *)arg;
3174 (void)SvREFCNT_inc(filter_child_proc);
3177 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3178 PerlIO_close(IoOFP(io));
3190 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3192 (void)SvREFCNT_inc(filter_sub);
3195 filter_state = SP[i];
3196 (void)SvREFCNT_inc(filter_state);
3200 tryrsfp = PerlIO_open("/dev/null",
3216 filter_has_file = 0;
3217 if (filter_child_proc) {
3218 SvREFCNT_dec(filter_child_proc);
3219 filter_child_proc = 0;
3222 SvREFCNT_dec(filter_state);
3226 SvREFCNT_dec(filter_sub);
3231 if (!path_is_absolute(name)
3232 #ifdef MACOS_TRADITIONAL
3233 /* We consider paths of the form :a:b ambiguous and interpret them first
3234 as global then as local
3236 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3239 const char *dir = SvPVx_nolen_const(dirsv);
3240 #ifdef MACOS_TRADITIONAL
3244 MacPerl_CanonDir(name, buf2, 1);
3245 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3249 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3251 sv_setpv(namesv, unixdir);
3252 sv_catpv(namesv, unixname);
3254 # ifdef __SYMBIAN32__
3255 if (PL_origfilename[0] &&
3256 PL_origfilename[1] == ':' &&
3257 !(dir[0] && dir[1] == ':'))
3258 Perl_sv_setpvf(aTHX_ namesv,
3263 Perl_sv_setpvf(aTHX_ namesv,
3267 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3271 TAINT_PROPER("require");
3272 tryname = SvPVX_const(namesv);
3273 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3275 if (tryname[0] == '.' && tryname[1] == '/')
3284 SAVECOPFILE_FREE(&PL_compiling);
3285 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3286 SvREFCNT_dec(namesv);
3288 if (PL_op->op_type == OP_REQUIRE) {
3289 const char *msgstr = name;
3290 if(errno == EMFILE) {
3291 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3292 sv_catpv(msg, ": ");
3293 sv_catpv(msg, Strerror(errno));
3294 msgstr = SvPV_nolen_const(msg);
3296 if (namesv) { /* did we lookup @INC? */
3297 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3298 SV * const dirmsgsv = NEWSV(0, 0);
3299 AV * const ar = GvAVn(PL_incgv);
3301 sv_catpvn(msg, " in @INC", 8);
3302 if (instr(SvPVX_const(msg), ".h "))
3303 sv_catpv(msg, " (change .h to .ph maybe?)");
3304 if (instr(SvPVX_const(msg), ".ph "))
3305 sv_catpv(msg, " (did you run h2ph?)");
3306 sv_catpv(msg, " (@INC contains:");
3307 for (i = 0; i <= AvFILL(ar); i++) {
3308 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3309 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3310 sv_catsv(msg, dirmsgsv);
3312 sv_catpvn(msg, ")", 1);
3313 SvREFCNT_dec(dirmsgsv);
3314 msgstr = SvPV_nolen_const(msg);
3317 DIE(aTHX_ "Can't locate %s", msgstr);
3323 SETERRNO(0, SS_NORMAL);
3325 /* Assume success here to prevent recursive requirement. */
3326 /* name is never assigned to again, so len is still strlen(name) */
3327 /* Check whether a hook in @INC has already filled %INC */
3329 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3331 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3333 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3338 lex_start(sv_2mortal(newSVpvn("",0)));
3339 SAVEGENERICSV(PL_rsfp_filters);
3340 PL_rsfp_filters = Nullav;
3345 SAVESPTR(PL_compiling.cop_warnings);
3346 if (PL_dowarn & G_WARN_ALL_ON)
3347 PL_compiling.cop_warnings = pWARN_ALL ;
3348 else if (PL_dowarn & G_WARN_ALL_OFF)
3349 PL_compiling.cop_warnings = pWARN_NONE ;
3350 else if (PL_taint_warn)
3351 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3353 PL_compiling.cop_warnings = pWARN_STD ;
3354 SAVESPTR(PL_compiling.cop_io);
3355 PL_compiling.cop_io = Nullsv;
3357 if (filter_sub || filter_child_proc) {
3358 SV * const datasv = filter_add(S_run_user_filter, Nullsv);
3359 IoLINES(datasv) = filter_has_file;
3360 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3361 IoTOP_GV(datasv) = (GV *)filter_state;
3362 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3365 /* switch to eval mode */
3366 PUSHBLOCK(cx, CXt_EVAL, SP);
3367 PUSHEVAL(cx, name, Nullgv);
3368 cx->blk_eval.retop = PL_op->op_next;
3370 SAVECOPLINE(&PL_compiling);
3371 CopLINE_set(&PL_compiling, 0);
3375 /* Store and reset encoding. */
3376 encoding = PL_encoding;
3377 PL_encoding = Nullsv;
3379 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3381 /* Restore encoding. */
3382 PL_encoding = encoding;
3390 register PERL_CONTEXT *cx;
3392 const I32 gimme = GIMME_V;
3393 const I32 was = PL_sub_generation;
3394 char tbuf[TYPE_DIGITS(long) + 12];
3395 char *tmpbuf = tbuf;
3402 if (!SvPV_nolen_const(sv))
3404 TAINT_PROPER("eval");
3410 /* switch to eval mode */
3412 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3413 SV * const sv = sv_newmortal();
3414 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3415 (unsigned long)++PL_evalseq,
3416 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3421 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3422 SAVECOPFILE_FREE(&PL_compiling);
3423 CopFILE_set(&PL_compiling, tmpbuf+2);
3424 SAVECOPLINE(&PL_compiling);
3425 CopLINE_set(&PL_compiling, 1);
3426 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3427 deleting the eval's FILEGV from the stash before gv_check() runs
3428 (i.e. before run-time proper). To work around the coredump that
3429 ensues, we always turn GvMULTI_on for any globals that were
3430 introduced within evals. See force_ident(). GSAR 96-10-12 */
3431 safestr = savepvn(tmpbuf, len);
3432 SAVEDELETE(PL_defstash, safestr, len);
3434 PL_hints = PL_op->op_targ;
3435 SAVESPTR(PL_compiling.cop_warnings);
3436 if (specialWARN(PL_curcop->cop_warnings))
3437 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3439 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3440 SAVEFREESV(PL_compiling.cop_warnings);
3442 SAVESPTR(PL_compiling.cop_io);
3443 if (specialCopIO(PL_curcop->cop_io))
3444 PL_compiling.cop_io = PL_curcop->cop_io;
3446 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3447 SAVEFREESV(PL_compiling.cop_io);
3449 /* special case: an eval '' executed within the DB package gets lexically
3450 * placed in the first non-DB CV rather than the current CV - this
3451 * allows the debugger to execute code, find lexicals etc, in the
3452 * scope of the code being debugged. Passing &seq gets find_runcv
3453 * to do the dirty work for us */
3454 runcv = find_runcv(&seq);
3456 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3457 PUSHEVAL(cx, 0, Nullgv);
3458 cx->blk_eval.retop = PL_op->op_next;
3460 /* prepare to compile string */
3462 if (PERLDB_LINE && PL_curstash != PL_debstash)
3463 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3465 ret = doeval(gimme, NULL, runcv, seq);
3466 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3467 && ret != PL_op->op_next) { /* Successive compilation. */
3468 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3470 return DOCATCH(ret);
3480 register PERL_CONTEXT *cx;
3482 const U8 save_flags = PL_op -> op_flags;
3487 retop = cx->blk_eval.retop;
3490 if (gimme == G_VOID)
3492 else if (gimme == G_SCALAR) {
3495 if (SvFLAGS(TOPs) & SVs_TEMP)
3498 *MARK = sv_mortalcopy(TOPs);
3502 *MARK = &PL_sv_undef;
3507 /* in case LEAVE wipes old return values */
3508 for (mark = newsp + 1; mark <= SP; mark++) {
3509 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3510 *mark = sv_mortalcopy(*mark);
3511 TAINT_NOT; /* Each item is independent */
3515 PL_curpm = newpm; /* Don't pop $1 et al till now */
3518 assert(CvDEPTH(PL_compcv) == 1);
3520 CvDEPTH(PL_compcv) = 0;
3523 if (optype == OP_REQUIRE &&
3524 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3526 /* Unassume the success we assumed earlier. */
3527 SV * const nsv = cx->blk_eval.old_namesv;
3528 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3529 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3530 /* die_where() did LEAVE, or we won't be here */
3534 if (!(save_flags & OPf_SPECIAL))
3535 sv_setpvn(ERRSV,"",0);
3544 register PERL_CONTEXT *cx;
3545 const I32 gimme = GIMME_V;
3550 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3552 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3554 PL_in_eval = EVAL_INEVAL;
3555 sv_setpvn(ERRSV,"",0);
3557 return DOCATCH(PL_op->op_next);
3567 register PERL_CONTEXT *cx;
3572 PERL_UNUSED_VAR(optype);
3575 if (gimme == G_VOID)
3577 else if (gimme == G_SCALAR) {
3580 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3583 *MARK = sv_mortalcopy(TOPs);
3587 *MARK = &PL_sv_undef;
3592 /* in case LEAVE wipes old return values */
3593 for (mark = newsp + 1; mark <= SP; mark++) {
3594 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3595 *mark = sv_mortalcopy(*mark);
3596 TAINT_NOT; /* Each item is independent */
3600 PL_curpm = newpm; /* Don't pop $1 et al till now */
3603 sv_setpvn(ERRSV,"",0);
3608 S_doparseform(pTHX_ SV *sv)
3611 register char *s = SvPV_force(sv, len);
3612 register char *send = s + len;
3613 register char *base = Nullch;
3614 register I32 skipspaces = 0;
3615 bool noblank = FALSE;
3616 bool repeat = FALSE;
3617 bool postspace = FALSE;
3623 bool unchopnum = FALSE;
3624 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3627 Perl_croak(aTHX_ "Null picture in formline");
3629 /* estimate the buffer size needed */
3630 for (base = s; s <= send; s++) {
3631 if (*s == '\n' || *s == '@' || *s == '^')
3637 Newx(fops, maxops, U32);
3642 *fpc++ = FF_LINEMARK;
3643 noblank = repeat = FALSE;
3661 case ' ': case '\t':
3668 } /* else FALL THROUGH */
3676 *fpc++ = FF_LITERAL;
3684 *fpc++ = (U16)skipspaces;
3688 *fpc++ = FF_NEWLINE;
3692 arg = fpc - linepc + 1;
3699 *fpc++ = FF_LINEMARK;
3700 noblank = repeat = FALSE;
3709 ischop = s[-1] == '^';
3715 arg = (s - base) - 1;
3717 *fpc++ = FF_LITERAL;
3725 *fpc++ = 2; /* skip the @* or ^* */
3727 *fpc++ = FF_LINESNGL;
3730 *fpc++ = FF_LINEGLOB;
3732 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3733 arg = ischop ? 512 : 0;
3738 const char * const f = ++s;
3741 arg |= 256 + (s - f);
3743 *fpc++ = s - base; /* fieldsize for FETCH */
3744 *fpc++ = FF_DECIMAL;
3746 unchopnum |= ! ischop;
3748 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3749 arg = ischop ? 512 : 0;
3751 s++; /* skip the '0' first */
3755 const char * const f = ++s;
3758 arg |= 256 + (s - f);
3760 *fpc++ = s - base; /* fieldsize for FETCH */
3761 *fpc++ = FF_0DECIMAL;
3763 unchopnum |= ! ischop;
3767 bool ismore = FALSE;
3770 while (*++s == '>') ;
3771 prespace = FF_SPACE;
3773 else if (*s == '|') {
3774 while (*++s == '|') ;
3775 prespace = FF_HALFSPACE;
3780 while (*++s == '<') ;
3783 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3787 *fpc++ = s - base; /* fieldsize for FETCH */
3789 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3792 *fpc++ = (U16)prespace;
3806 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3808 { /* need to jump to the next word */
3810 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3811 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3812 s = SvPVX(sv) + SvCUR(sv) + z;
3814 Copy(fops, s, arg, U32);
3816 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3819 if (unchopnum && repeat)
3820 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3826 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3828 /* Can value be printed in fldsize chars, using %*.*f ? */
3832 int intsize = fldsize - (value < 0 ? 1 : 0);
3839 while (intsize--) pwr *= 10.0;
3840 while (frcsize--) eps /= 10.0;
3843 if (value + eps >= pwr)
3846 if (value - eps <= -pwr)
3853 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3856 SV * const datasv = FILTER_DATA(idx);
3857 const int filter_has_file = IoLINES(datasv);
3858 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
3859 SV * const filter_state = (SV *)IoTOP_GV(datasv);
3860 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
3863 /* I was having segfault trouble under Linux 2.2.5 after a
3864 parse error occured. (Had to hack around it with a test
3865 for PL_error_count == 0.) Solaris doesn't segfault --
3866 not sure where the trouble is yet. XXX */
3868 if (filter_has_file) {
3869 len = FILTER_READ(idx+1, buf_sv, maxlen);
3872 if (filter_sub && len >= 0) {
3883 PUSHs(sv_2mortal(newSViv(maxlen)));
3885 PUSHs(filter_state);
3888 count = call_sv(filter_sub, G_SCALAR);
3904 IoLINES(datasv) = 0;
3905 if (filter_child_proc) {
3906 SvREFCNT_dec(filter_child_proc);
3907 IoFMT_GV(datasv) = Nullgv;
3910 SvREFCNT_dec(filter_state);
3911 IoTOP_GV(datasv) = Nullgv;
3914 SvREFCNT_dec(filter_sub);
3915 IoBOTTOM_GV(datasv) = Nullgv;
3917 filter_del(S_run_user_filter);
3923 /* perhaps someone can come up with a better name for
3924 this? it is not really "absolute", per se ... */
3926 S_path_is_absolute(pTHX_ const char *name)
3928 if (PERL_FILE_IS_ABSOLUTE(name)
3929 #ifdef MACOS_TRADITIONAL
3932 || (*name == '.' && (name[1] == '/' ||
3933 (name[1] == '.' && name[2] == '/')))
3945 * c-indentation-style: bsd
3947 * indent-tabs-mode: t
3950 * ex: set ts=8 sts=4 sw=4 noet: