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);
212 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
213 s == m, cx->sb_targ, NULL,
214 ((cx->sb_rflags & REXEC_COPY_STR)
215 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
216 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
218 SV * const targ = cx->sb_targ;
220 assert(cx->sb_strend >= s);
221 if(cx->sb_strend > s) {
222 if (DO_UTF8(dstr) && !SvUTF8(targ))
223 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
225 sv_catpvn(dstr, s, cx->sb_strend - s);
227 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
229 #ifdef PERL_OLD_COPY_ON_WRITE
231 sv_force_normal_flags(targ, SV_COW_DROP_PV);
237 SvPV_set(targ, SvPVX(dstr));
238 SvCUR_set(targ, SvCUR(dstr));
239 SvLEN_set(targ, SvLEN(dstr));
242 SvPV_set(dstr, (char*)0);
245 TAINT_IF(cx->sb_rxtainted & 1);
246 PUSHs(sv_2mortal(newSViv(saviters - 1)));
248 (void)SvPOK_only_UTF8(targ);
249 TAINT_IF(cx->sb_rxtainted);
253 LEAVE_SCOPE(cx->sb_oldsave);
256 RETURNOP(pm->op_next);
258 cx->sb_iters = saviters;
260 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
263 cx->sb_orig = orig = rx->subbeg;
265 cx->sb_strend = s + (cx->sb_strend - m);
267 cx->sb_m = m = rx->startp[0] + orig;
269 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
270 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
272 sv_catpvn(dstr, s, m-s);
274 cx->sb_s = rx->endp[0] + orig;
275 { /* Update the pos() information. */
276 SV * const sv = cx->sb_targ;
279 if (SvTYPE(sv) < SVt_PVMG)
280 SvUPGRADE(sv, SVt_PVMG);
281 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
282 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
283 mg = mg_find(sv, PERL_MAGIC_regex_global);
291 (void)ReREFCNT_inc(rx);
292 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
293 rxres_save(&cx->sb_rxres, rx);
294 RETURNOP(pm->op_pmreplstart);
298 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
303 if (!p || p[1] < rx->nparens) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
305 i = 7 + rx->nparens * 2;
307 i = 6 + rx->nparens * 2;
316 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
317 RX_MATCH_COPIED_off(rx);
319 #ifdef PERL_OLD_COPY_ON_WRITE
320 *p++ = PTR2UV(rx->saved_copy);
321 rx->saved_copy = Nullsv;
326 *p++ = PTR2UV(rx->subbeg);
327 *p++ = (UV)rx->sublen;
328 for (i = 0; i <= rx->nparens; ++i) {
329 *p++ = (UV)rx->startp[i];
330 *p++ = (UV)rx->endp[i];
335 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
340 RX_MATCH_COPY_FREE(rx);
341 RX_MATCH_COPIED_set(rx, *p);
344 #ifdef PERL_OLD_COPY_ON_WRITE
346 SvREFCNT_dec (rx->saved_copy);
347 rx->saved_copy = INT2PTR(SV*,*p);
353 rx->subbeg = INT2PTR(char*,*p++);
354 rx->sublen = (I32)(*p++);
355 for (i = 0; i <= rx->nparens; ++i) {
356 rx->startp[i] = (I32)(*p++);
357 rx->endp[i] = (I32)(*p++);
362 Perl_rxres_free(pTHX_ void **rsp)
364 UV * const p = (UV*)*rsp;
368 void *tmp = INT2PTR(char*,*p);
371 Poison(*p, 1, sizeof(*p));
373 Safefree(INT2PTR(char*,*p));
375 #ifdef PERL_OLD_COPY_ON_WRITE
377 SvREFCNT_dec (INT2PTR(SV*,p[1]));
387 dSP; dMARK; dORIGMARK;
388 register SV * const tmpForm = *++MARK;
393 register SV *sv = Nullsv;
394 const char *item = Nullch;
398 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
399 const char *chophere = Nullch;
400 char *linemark = Nullch;
402 bool gotsome = FALSE;
404 const STRLEN fudge = SvPOK(tmpForm)
405 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
406 bool item_is_utf8 = FALSE;
407 bool targ_is_utf8 = FALSE;
413 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
414 if (SvREADONLY(tmpForm)) {
415 SvREADONLY_off(tmpForm);
416 parseres = doparseform(tmpForm);
417 SvREADONLY_on(tmpForm);
420 parseres = doparseform(tmpForm);
424 SvPV_force(PL_formtarget, len);
425 if (DO_UTF8(PL_formtarget))
427 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
429 f = SvPV_const(tmpForm, len);
430 /* need to jump to the next word */
431 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
435 const char *name = "???";
438 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
439 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
440 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
441 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
442 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
444 case FF_CHECKNL: name = "CHECKNL"; break;
445 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
446 case FF_SPACE: name = "SPACE"; break;
447 case FF_HALFSPACE: name = "HALFSPACE"; break;
448 case FF_ITEM: name = "ITEM"; break;
449 case FF_CHOP: name = "CHOP"; break;
450 case FF_LINEGLOB: name = "LINEGLOB"; break;
451 case FF_NEWLINE: name = "NEWLINE"; break;
452 case FF_MORE: name = "MORE"; break;
453 case FF_LINEMARK: name = "LINEMARK"; break;
454 case FF_END: name = "END"; break;
455 case FF_0DECIMAL: name = "0DECIMAL"; break;
456 case FF_LINESNGL: name = "LINESNGL"; break;
459 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
461 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
472 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
473 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
475 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
476 t = SvEND(PL_formtarget);
479 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
480 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
482 sv_utf8_upgrade(PL_formtarget);
483 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
484 t = SvEND(PL_formtarget);
504 if (ckWARN(WARN_SYNTAX))
505 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
512 const char *s = item = SvPV_const(sv, len);
515 itemsize = sv_len_utf8(sv);
516 if (itemsize != (I32)len) {
518 if (itemsize > fieldsize) {
519 itemsize = fieldsize;
520 itembytes = itemsize;
521 sv_pos_u2b(sv, &itembytes, 0);
525 send = chophere = s + itembytes;
535 sv_pos_b2u(sv, &itemsize);
539 item_is_utf8 = FALSE;
540 if (itemsize > fieldsize)
541 itemsize = fieldsize;
542 send = chophere = s + itemsize;
556 const char *s = item = SvPV_const(sv, len);
559 itemsize = sv_len_utf8(sv);
560 if (itemsize != (I32)len) {
562 if (itemsize <= fieldsize) {
563 const char *send = chophere = s + itemsize;
576 itemsize = fieldsize;
577 itembytes = itemsize;
578 sv_pos_u2b(sv, &itembytes, 0);
579 send = chophere = s + itembytes;
580 while (s < send || (s == send && isSPACE(*s))) {
590 if (strchr(PL_chopset, *s))
595 itemsize = chophere - item;
596 sv_pos_b2u(sv, &itemsize);
602 item_is_utf8 = FALSE;
603 if (itemsize <= fieldsize) {
604 const char *const send = chophere = s + itemsize;
617 itemsize = fieldsize;
618 send = chophere = s + itemsize;
619 while (s < send || (s == send && isSPACE(*s))) {
629 if (strchr(PL_chopset, *s))
634 itemsize = chophere - item;
640 arg = fieldsize - itemsize;
649 arg = fieldsize - itemsize;
660 const char *s = item;
664 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
666 sv_utf8_upgrade(PL_formtarget);
667 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
668 t = SvEND(PL_formtarget);
672 if (UTF8_IS_CONTINUED(*s)) {
673 STRLEN skip = UTF8SKIP(s);
690 if ( !((*t++ = *s++) & ~31) )
696 if (targ_is_utf8 && !item_is_utf8) {
697 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
699 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
700 for (; t < SvEND(PL_formtarget); t++) {
713 const int ch = *t++ = *s++;
716 if ( !((*t++ = *s++) & ~31) )
725 const char *s = chophere;
743 const char *s = item = SvPV_const(sv, len);
745 if ((item_is_utf8 = DO_UTF8(sv)))
746 itemsize = sv_len_utf8(sv);
748 bool chopped = FALSE;
749 const char *const send = s + len;
751 chophere = s + itemsize;
767 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
769 SvUTF8_on(PL_formtarget);
771 SvCUR_set(sv, chophere - item);
772 sv_catsv(PL_formtarget, sv);
773 SvCUR_set(sv, itemsize);
775 sv_catsv(PL_formtarget, sv);
777 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
778 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
779 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
788 #if defined(USE_LONG_DOUBLE)
789 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
791 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
796 #if defined(USE_LONG_DOUBLE)
797 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
799 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
802 /* If the field is marked with ^ and the value is undefined,
804 if ((arg & 512) && !SvOK(sv)) {
812 /* overflow evidence */
813 if (num_overflow(value, fieldsize, arg)) {
819 /* Formats aren't yet marked for locales, so assume "yes". */
821 STORE_NUMERIC_STANDARD_SET_LOCAL();
822 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
823 RESTORE_NUMERIC_STANDARD();
830 while (t-- > linemark && *t == ' ') ;
838 if (arg) { /* repeat until fields exhausted? */
840 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
841 lines += FmLINES(PL_formtarget);
844 if (strnEQ(linemark, linemark - arg, arg))
845 DIE(aTHX_ "Runaway format");
848 SvUTF8_on(PL_formtarget);
849 FmLINES(PL_formtarget) = lines;
851 RETURNOP(cLISTOP->op_first);
862 const char *s = chophere;
863 const char *send = item + len;
865 while (isSPACE(*s) && (s < send))
870 arg = fieldsize - itemsize;
877 if (strnEQ(s1," ",3)) {
878 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
889 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
891 SvUTF8_on(PL_formtarget);
892 FmLINES(PL_formtarget) += lines;
904 if (PL_stack_base + *PL_markstack_ptr == SP) {
906 if (GIMME_V == G_SCALAR)
907 XPUSHs(sv_2mortal(newSViv(0)));
908 RETURNOP(PL_op->op_next->op_next);
910 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
911 pp_pushmark(); /* push dst */
912 pp_pushmark(); /* push src */
913 ENTER; /* enter outer scope */
916 if (PL_op->op_private & OPpGREP_LEX)
917 SAVESPTR(PAD_SVl(PL_op->op_targ));
920 ENTER; /* enter inner scope */
923 src = PL_stack_base[*PL_markstack_ptr];
925 if (PL_op->op_private & OPpGREP_LEX)
926 PAD_SVl(PL_op->op_targ) = src;
931 if (PL_op->op_type == OP_MAPSTART)
932 pp_pushmark(); /* push top */
933 return ((LOGOP*)PL_op->op_next)->op_other;
939 const I32 gimme = GIMME_V;
940 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
946 /* first, move source pointer to the next item in the source list */
947 ++PL_markstack_ptr[-1];
949 /* if there are new items, push them into the destination list */
950 if (items && gimme != G_VOID) {
951 /* might need to make room back there first */
952 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
953 /* XXX this implementation is very pessimal because the stack
954 * is repeatedly extended for every set of items. Is possible
955 * to do this without any stack extension or copying at all
956 * by maintaining a separate list over which the map iterates
957 * (like foreach does). --gsar */
959 /* everything in the stack after the destination list moves
960 * towards the end the stack by the amount of room needed */
961 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
963 /* items to shift up (accounting for the moved source pointer) */
964 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
966 /* This optimization is by Ben Tilly and it does
967 * things differently from what Sarathy (gsar)
968 * is describing. The downside of this optimization is
969 * that leaves "holes" (uninitialized and hopefully unused areas)
970 * to the Perl stack, but on the other hand this
971 * shouldn't be a problem. If Sarathy's idea gets
972 * implemented, this optimization should become
973 * irrelevant. --jhi */
975 shift = count; /* Avoid shifting too often --Ben Tilly */
980 PL_markstack_ptr[-1] += shift;
981 *PL_markstack_ptr += shift;
985 /* copy the new items down to the destination list */
986 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
987 if (gimme == G_ARRAY) {
989 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
992 /* scalar context: we don't care about which values map returns
993 * (we use undef here). And so we certainly don't want to do mortal
994 * copies of meaningless values. */
995 while (items-- > 0) {
997 *dst-- = &PL_sv_undef;
1001 LEAVE; /* exit inner scope */
1004 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1006 (void)POPMARK; /* pop top */
1007 LEAVE; /* exit outer scope */
1008 (void)POPMARK; /* pop src */
1009 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1010 (void)POPMARK; /* pop dst */
1011 SP = PL_stack_base + POPMARK; /* pop original mark */
1012 if (gimme == G_SCALAR) {
1013 if (PL_op->op_private & OPpGREP_LEX) {
1014 SV* sv = sv_newmortal();
1015 sv_setiv(sv, items);
1023 else if (gimme == G_ARRAY)
1030 ENTER; /* enter inner scope */
1033 /* set $_ to the new source item */
1034 src = PL_stack_base[PL_markstack_ptr[-1]];
1036 if (PL_op->op_private & OPpGREP_LEX)
1037 PAD_SVl(PL_op->op_targ) = src;
1041 RETURNOP(cLOGOP->op_other);
1049 if (GIMME == G_ARRAY)
1051 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1052 return cLOGOP->op_other;
1061 if (GIMME == G_ARRAY) {
1062 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1066 SV * const targ = PAD_SV(PL_op->op_targ);
1069 if (PL_op->op_private & OPpFLIP_LINENUM) {
1070 if (GvIO(PL_last_in_gv)) {
1071 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1074 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1076 flip = SvIV(sv) == SvIV(GvSV(gv));
1082 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1083 if (PL_op->op_flags & OPf_SPECIAL) {
1091 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1094 sv_setpvn(TARG, "", 0);
1100 /* This code tries to decide if "$left .. $right" should use the
1101 magical string increment, or if the range is numeric (we make
1102 an exception for .."0" [#18165]). AMS 20021031. */
1104 #define RANGE_IS_NUMERIC(left,right) ( \
1105 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1106 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1107 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1108 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1109 && (!SvOK(right) || looks_like_number(right))))
1115 if (GIMME == G_ARRAY) {
1121 if (RANGE_IS_NUMERIC(left,right)) {
1124 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1125 (SvOK(right) && SvNV(right) > IV_MAX))
1126 DIE(aTHX_ "Range iterator outside integer range");
1137 SV * const sv = sv_2mortal(newSViv(i++));
1142 SV * const final = sv_mortalcopy(right);
1144 const char * const tmps = SvPV_const(final, len);
1146 SV *sv = sv_mortalcopy(left);
1147 SvPV_force_nolen(sv);
1148 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1150 if (strEQ(SvPVX_const(sv),tmps))
1152 sv = sv_2mortal(newSVsv(sv));
1159 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1163 if (PL_op->op_private & OPpFLIP_LINENUM) {
1164 if (GvIO(PL_last_in_gv)) {
1165 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1168 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1169 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1177 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1178 sv_catpvn(targ, "E0", 2);
1188 static const char * const context_name[] = {
1199 S_dopoptolabel(pTHX_ const char *label)
1203 for (i = cxstack_ix; i >= 0; i--) {
1204 register const PERL_CONTEXT * const cx = &cxstack[i];
1205 switch (CxTYPE(cx)) {
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1213 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1214 if (CxTYPE(cx) == CXt_NULL)
1218 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1219 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1220 (long)i, cx->blk_loop.label));
1223 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1231 Perl_dowantarray(pTHX)
1233 const I32 gimme = block_gimme();
1234 return (gimme == G_VOID) ? G_SCALAR : gimme;
1238 Perl_block_gimme(pTHX)
1240 const I32 cxix = dopoptosub(cxstack_ix);
1244 switch (cxstack[cxix].blk_gimme) {
1252 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1259 Perl_is_lvalue_sub(pTHX)
1261 const I32 cxix = dopoptosub(cxstack_ix);
1262 assert(cxix >= 0); /* We should only be called from inside subs */
1264 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1265 return cxstack[cxix].blk_sub.lval;
1271 S_dopoptosub(pTHX_ I32 startingblock)
1273 return dopoptosub_at(cxstack, startingblock);
1277 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1280 for (i = startingblock; i >= 0; i--) {
1281 register const PERL_CONTEXT * const cx = &cxstk[i];
1282 switch (CxTYPE(cx)) {
1288 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1296 S_dopoptoeval(pTHX_ I32 startingblock)
1299 for (i = startingblock; i >= 0; i--) {
1300 register const PERL_CONTEXT *cx = &cxstack[i];
1301 switch (CxTYPE(cx)) {
1305 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1313 S_dopoptoloop(pTHX_ I32 startingblock)
1316 for (i = startingblock; i >= 0; i--) {
1317 register const PERL_CONTEXT * const cx = &cxstack[i];
1318 switch (CxTYPE(cx)) {
1324 if (ckWARN(WARN_EXITING))
1325 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1326 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1327 if ((CxTYPE(cx)) == CXt_NULL)
1331 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1339 Perl_dounwind(pTHX_ I32 cxix)
1343 while (cxstack_ix > cxix) {
1345 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1346 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1347 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1348 /* Note: we don't need to restore the base context info till the end. */
1349 switch (CxTYPE(cx)) {
1352 continue; /* not break */
1371 PERL_UNUSED_VAR(optype);
1375 Perl_qerror(pTHX_ SV *err)
1378 sv_catsv(ERRSV, err);
1380 sv_catsv(PL_errors, err);
1382 Perl_warn(aTHX_ "%"SVf, err);
1387 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1396 if (PL_in_eval & EVAL_KEEPERR) {
1397 static const char prefix[] = "\t(in cleanup) ";
1398 SV * const err = ERRSV;
1399 const char *e = Nullch;
1401 sv_setpvn(err,"",0);
1402 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1404 e = SvPV_const(err, len);
1406 if (*e != *message || strNE(e,message))
1410 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1411 sv_catpvn(err, prefix, sizeof(prefix)-1);
1412 sv_catpvn(err, message, msglen);
1413 if (ckWARN(WARN_MISC)) {
1414 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1415 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1420 sv_setpvn(ERRSV, message, msglen);
1424 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1425 && PL_curstackinfo->si_prev)
1433 register PERL_CONTEXT *cx;
1436 if (cxix < cxstack_ix)
1439 POPBLOCK(cx,PL_curpm);
1440 if (CxTYPE(cx) != CXt_EVAL) {
1442 message = SvPVx_const(ERRSV, msglen);
1443 PerlIO_write(Perl_error_log, "panic: die ", 11);
1444 PerlIO_write(Perl_error_log, message, msglen);
1449 if (gimme == G_SCALAR)
1450 *++newsp = &PL_sv_undef;
1451 PL_stack_sp = newsp;
1455 /* LEAVE could clobber PL_curcop (see save_re_context())
1456 * XXX it might be better to find a way to avoid messing with
1457 * PL_curcop in save_re_context() instead, but this is a more
1458 * minimal fix --GSAR */
1459 PL_curcop = cx->blk_oldcop;
1461 if (optype == OP_REQUIRE) {
1462 const char* const msg = SvPVx_nolen_const(ERRSV);
1463 SV * const nsv = cx->blk_eval.old_namesv;
1464 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1466 DIE(aTHX_ "%sCompilation failed in require",
1467 *msg ? msg : "Unknown error\n");
1469 assert(CxTYPE(cx) == CXt_EVAL);
1470 return cx->blk_eval.retop;
1474 message = SvPVx_const(ERRSV, msglen);
1476 write_to_stderr(message, msglen);
1485 if (SvTRUE(left) != SvTRUE(right))
1494 register I32 cxix = dopoptosub(cxstack_ix);
1495 register const PERL_CONTEXT *cx;
1496 register const PERL_CONTEXT *ccstack = cxstack;
1497 const PERL_SI *top_si = PL_curstackinfo;
1499 const char *stashname;
1506 /* we may be in a higher stacklevel, so dig down deeper */
1507 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1508 top_si = top_si->si_prev;
1509 ccstack = top_si->si_cxstack;
1510 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1513 if (GIMME != G_ARRAY) {
1519 /* caller() should not report the automatic calls to &DB::sub */
1520 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1521 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1525 cxix = dopoptosub_at(ccstack, cxix - 1);
1528 cx = &ccstack[cxix];
1529 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1530 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1531 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1532 field below is defined for any cx. */
1533 /* caller() should not report the automatic calls to &DB::sub */
1534 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1535 cx = &ccstack[dbcxix];
1538 stashname = CopSTASHPV(cx->blk_oldcop);
1539 if (GIMME != G_ARRAY) {
1542 PUSHs(&PL_sv_undef);
1545 sv_setpv(TARG, stashname);
1554 PUSHs(&PL_sv_undef);
1556 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1557 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1558 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1561 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1562 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1563 /* So is ccstack[dbcxix]. */
1565 SV * const sv = NEWSV(49, 0);
1566 gv_efullname3(sv, cvgv, Nullch);
1567 PUSHs(sv_2mortal(sv));
1568 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1571 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1572 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1576 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1577 PUSHs(sv_2mortal(newSViv(0)));
1579 gimme = (I32)cx->blk_gimme;
1580 if (gimme == G_VOID)
1581 PUSHs(&PL_sv_undef);
1583 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1584 if (CxTYPE(cx) == CXt_EVAL) {
1586 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1587 PUSHs(cx->blk_eval.cur_text);
1591 else if (cx->blk_eval.old_namesv) {
1592 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1595 /* eval BLOCK (try blocks have old_namesv == 0) */
1597 PUSHs(&PL_sv_undef);
1598 PUSHs(&PL_sv_undef);
1602 PUSHs(&PL_sv_undef);
1603 PUSHs(&PL_sv_undef);
1605 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1606 && CopSTASH_eq(PL_curcop, PL_debstash))
1608 AV * const ary = cx->blk_sub.argarray;
1609 const int off = AvARRAY(ary) - AvALLOC(ary);
1612 GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
1613 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1615 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1618 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1619 av_extend(PL_dbargs, AvFILLp(ary) + off);
1620 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1621 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1623 /* XXX only hints propagated via op_private are currently
1624 * visible (others are not easily accessible, since they
1625 * use the global PL_hints) */
1626 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1627 HINT_PRIVATE_MASK)));
1630 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
1632 if (old_warnings == pWARN_NONE ||
1633 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1634 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1635 else if (old_warnings == pWARN_ALL ||
1636 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1637 /* Get the bit mask for $warnings::Bits{all}, because
1638 * it could have been extended by warnings::register */
1640 HV * const bits = get_hv("warnings::Bits", FALSE);
1641 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1642 mask = newSVsv(*bits_all);
1645 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1649 mask = newSVsv(old_warnings);
1650 PUSHs(sv_2mortal(mask));
1658 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1659 sv_reset(tmps, CopSTASH(PL_curcop));
1664 /* like pp_nextstate, but used instead when the debugger is active */
1669 PL_curcop = (COP*)PL_op;
1670 TAINT_NOT; /* Each statement is presumed innocent */
1671 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1674 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1675 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1678 register PERL_CONTEXT *cx;
1679 const I32 gimme = G_ARRAY;
1681 GV * const gv = PL_DBgv;
1682 register CV * const cv = GvCV(gv);
1685 DIE(aTHX_ "No DB::DB routine defined");
1687 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1688 /* don't do recursive DB::DB call */
1703 (void)(*CvXSUB(cv))(aTHX_ cv);
1710 PUSHBLOCK(cx, CXt_SUB, SP);
1712 cx->blk_sub.retop = PL_op->op_next;
1715 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1716 RETURNOP(CvSTART(cv));
1726 register PERL_CONTEXT *cx;
1727 const I32 gimme = GIMME_V;
1729 U32 cxtype = CXt_LOOP;
1737 if (PL_op->op_targ) {
1738 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1739 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1740 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1741 SVs_PADSTALE, SVs_PADSTALE);
1743 #ifndef USE_ITHREADS
1744 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1747 SAVEPADSV(PL_op->op_targ);
1748 iterdata = INT2PTR(void*, PL_op->op_targ);
1749 cxtype |= CXp_PADVAR;
1753 GV * const gv = (GV*)POPs;
1754 svp = &GvSV(gv); /* symbol table variable */
1755 SAVEGENERICSV(*svp);
1758 iterdata = (void*)gv;
1764 PUSHBLOCK(cx, cxtype, SP);
1766 PUSHLOOP(cx, iterdata, MARK);
1768 PUSHLOOP(cx, svp, MARK);
1770 if (PL_op->op_flags & OPf_STACKED) {
1771 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1772 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1774 SV * const right = (SV*)cx->blk_loop.iterary;
1777 if (RANGE_IS_NUMERIC(sv,right)) {
1778 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1779 (SvOK(right) && SvNV(right) >= IV_MAX))
1780 DIE(aTHX_ "Range iterator outside integer range");
1781 cx->blk_loop.iterix = SvIV(sv);
1782 cx->blk_loop.itermax = SvIV(right);
1784 /* for correct -Dstv display */
1785 cx->blk_oldsp = sp - PL_stack_base;
1789 cx->blk_loop.iterlval = newSVsv(sv);
1790 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1791 (void) SvPV_nolen_const(right);
1794 else if (PL_op->op_private & OPpITER_REVERSED) {
1795 cx->blk_loop.itermax = 0;
1796 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1801 cx->blk_loop.iterary = PL_curstack;
1802 AvFILLp(PL_curstack) = SP - PL_stack_base;
1803 if (PL_op->op_private & OPpITER_REVERSED) {
1804 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1805 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1808 cx->blk_loop.iterix = MARK - PL_stack_base;
1818 register PERL_CONTEXT *cx;
1819 const I32 gimme = GIMME_V;
1825 PUSHBLOCK(cx, CXt_LOOP, SP);
1826 PUSHLOOP(cx, 0, SP);
1834 register PERL_CONTEXT *cx;
1841 assert(CxTYPE(cx) == CXt_LOOP);
1843 newsp = PL_stack_base + cx->blk_loop.resetsp;
1846 if (gimme == G_VOID)
1848 else if (gimme == G_SCALAR) {
1850 *++newsp = sv_mortalcopy(*SP);
1852 *++newsp = &PL_sv_undef;
1856 *++newsp = sv_mortalcopy(*++mark);
1857 TAINT_NOT; /* Each item is independent */
1863 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1864 PL_curpm = newpm; /* ... and pop $1 et al */
1875 register PERL_CONTEXT *cx;
1876 bool popsub2 = FALSE;
1877 bool clear_errsv = FALSE;
1885 const I32 cxix = dopoptosub(cxstack_ix);
1888 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1889 * sort block, which is a CXt_NULL
1892 PL_stack_base[1] = *PL_stack_sp;
1893 PL_stack_sp = PL_stack_base + 1;
1897 DIE(aTHX_ "Can't return outside a subroutine");
1899 if (cxix < cxstack_ix)
1902 if (CxMULTICALL(&cxstack[cxix])) {
1903 gimme = cxstack[cxix].blk_gimme;
1904 if (gimme == G_VOID)
1905 PL_stack_sp = PL_stack_base;
1906 else if (gimme == G_SCALAR) {
1907 PL_stack_base[1] = *PL_stack_sp;
1908 PL_stack_sp = PL_stack_base + 1;
1914 switch (CxTYPE(cx)) {
1917 retop = cx->blk_sub.retop;
1918 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1921 if (!(PL_in_eval & EVAL_KEEPERR))
1924 retop = cx->blk_eval.retop;
1928 if (optype == OP_REQUIRE &&
1929 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1931 /* Unassume the success we assumed earlier. */
1932 SV * const nsv = cx->blk_eval.old_namesv;
1933 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1934 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1939 retop = cx->blk_sub.retop;
1942 DIE(aTHX_ "panic: return");
1946 if (gimme == G_SCALAR) {
1949 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1951 *++newsp = SvREFCNT_inc(*SP);
1956 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1958 *++newsp = sv_mortalcopy(sv);
1963 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1966 *++newsp = sv_mortalcopy(*SP);
1969 *++newsp = &PL_sv_undef;
1971 else if (gimme == G_ARRAY) {
1972 while (++MARK <= SP) {
1973 *++newsp = (popsub2 && SvTEMP(*MARK))
1974 ? *MARK : sv_mortalcopy(*MARK);
1975 TAINT_NOT; /* Each item is independent */
1978 PL_stack_sp = newsp;
1981 /* Stack values are safe: */
1984 POPSUB(cx,sv); /* release CV and @_ ... */
1988 PL_curpm = newpm; /* ... and pop $1 et al */
1992 sv_setpvn(ERRSV,"",0);
2000 register PERL_CONTEXT *cx;
2011 if (PL_op->op_flags & OPf_SPECIAL) {
2012 cxix = dopoptoloop(cxstack_ix);
2014 DIE(aTHX_ "Can't \"last\" outside a loop block");
2017 cxix = dopoptolabel(cPVOP->op_pv);
2019 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2021 if (cxix < cxstack_ix)
2025 cxstack_ix++; /* temporarily protect top context */
2027 switch (CxTYPE(cx)) {
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2031 nextop = cx->blk_loop.last_op->op_next;
2035 nextop = cx->blk_sub.retop;
2039 nextop = cx->blk_eval.retop;
2043 nextop = cx->blk_sub.retop;
2046 DIE(aTHX_ "panic: last");
2050 if (gimme == G_SCALAR) {
2052 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2053 ? *SP : sv_mortalcopy(*SP);
2055 *++newsp = &PL_sv_undef;
2057 else if (gimme == G_ARRAY) {
2058 while (++MARK <= SP) {
2059 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2060 ? *MARK : sv_mortalcopy(*MARK);
2061 TAINT_NOT; /* Each item is independent */
2069 /* Stack values are safe: */
2072 POPLOOP(cx); /* release loop vars ... */
2076 POPSUB(cx,sv); /* release CV and @_ ... */
2079 PL_curpm = newpm; /* ... and pop $1 et al */
2082 PERL_UNUSED_VAR(optype);
2083 PERL_UNUSED_VAR(gimme);
2091 register PERL_CONTEXT *cx;
2094 if (PL_op->op_flags & OPf_SPECIAL) {
2095 cxix = dopoptoloop(cxstack_ix);
2097 DIE(aTHX_ "Can't \"next\" outside a loop block");
2100 cxix = dopoptolabel(cPVOP->op_pv);
2102 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2104 if (cxix < cxstack_ix)
2107 /* clear off anything above the scope we're re-entering, but
2108 * save the rest until after a possible continue block */
2109 inner = PL_scopestack_ix;
2111 if (PL_scopestack_ix < inner)
2112 leave_scope(PL_scopestack[PL_scopestack_ix]);
2113 PL_curcop = cx->blk_oldcop;
2114 return cx->blk_loop.next_op;
2121 register PERL_CONTEXT *cx;
2125 if (PL_op->op_flags & OPf_SPECIAL) {
2126 cxix = dopoptoloop(cxstack_ix);
2128 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2131 cxix = dopoptolabel(cPVOP->op_pv);
2133 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2135 if (cxix < cxstack_ix)
2138 redo_op = cxstack[cxix].blk_loop.redo_op;
2139 if (redo_op->op_type == OP_ENTER) {
2140 /* pop one less context to avoid $x being freed in while (my $x..) */
2142 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2143 redo_op = redo_op->op_next;
2147 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2148 LEAVE_SCOPE(oldsave);
2150 PL_curcop = cx->blk_oldcop;
2155 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2158 static const char too_deep[] = "Target of goto is too deeply nested";
2161 Perl_croak(aTHX_ too_deep);
2162 if (o->op_type == OP_LEAVE ||
2163 o->op_type == OP_SCOPE ||
2164 o->op_type == OP_LEAVELOOP ||
2165 o->op_type == OP_LEAVESUB ||
2166 o->op_type == OP_LEAVETRY)
2168 *ops++ = cUNOPo->op_first;
2170 Perl_croak(aTHX_ too_deep);
2173 if (o->op_flags & OPf_KIDS) {
2175 /* First try all the kids at this level, since that's likeliest. */
2176 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2177 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2178 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2181 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2182 if (kid == PL_lastgotoprobe)
2184 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2187 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2188 ops[-1]->op_type == OP_DBSTATE)
2193 if ((o = dofindlabel(kid, label, ops, oplimit)))
2206 register PERL_CONTEXT *cx;
2207 #define GOTO_DEPTH 64
2208 OP *enterops[GOTO_DEPTH];
2209 const char *label = 0;
2210 const bool do_dump = (PL_op->op_type == OP_DUMP);
2211 static const char must_have_label[] = "goto must have label";
2213 if (PL_op->op_flags & OPf_STACKED) {
2214 SV * const sv = POPs;
2216 /* This egregious kludge implements goto &subroutine */
2217 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2219 register PERL_CONTEXT *cx;
2220 CV* cv = (CV*)SvRV(sv);
2227 if (!CvROOT(cv) && !CvXSUB(cv)) {
2228 const GV * const gv = CvGV(cv);
2232 /* autoloaded stub? */
2233 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2235 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2236 GvNAMELEN(gv), FALSE);
2237 if (autogv && (cv = GvCV(autogv)))
2239 tmpstr = sv_newmortal();
2240 gv_efullname3(tmpstr, gv, Nullch);
2241 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2243 DIE(aTHX_ "Goto undefined subroutine");
2246 /* First do some returnish stuff. */
2247 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2249 cxix = dopoptosub(cxstack_ix);
2251 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2252 if (cxix < cxstack_ix)
2256 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2257 if (CxTYPE(cx) == CXt_EVAL) {
2259 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2261 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2263 else if (CxMULTICALL(cx))
2264 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2265 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2266 /* put @_ back onto stack */
2267 AV* av = cx->blk_sub.argarray;
2269 items = AvFILLp(av) + 1;
2270 EXTEND(SP, items+1); /* @_ could have been extended. */
2271 Copy(AvARRAY(av), SP + 1, items, SV*);
2272 SvREFCNT_dec(GvAV(PL_defgv));
2273 GvAV(PL_defgv) = cx->blk_sub.savearray;
2275 /* abandon @_ if it got reified */
2280 av_extend(av, items-1);
2282 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2285 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2286 AV* const av = GvAV(PL_defgv);
2287 items = AvFILLp(av) + 1;
2288 EXTEND(SP, items+1); /* @_ could have been extended. */
2289 Copy(AvARRAY(av), SP + 1, items, SV*);
2293 if (CxTYPE(cx) == CXt_SUB &&
2294 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2295 SvREFCNT_dec(cx->blk_sub.cv);
2296 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2297 LEAVE_SCOPE(oldsave);
2299 /* Now do some callish stuff. */
2301 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2303 OP* retop = cx->blk_sub.retop;
2306 for (index=0; index<items; index++)
2307 sv_2mortal(SP[-index]);
2309 #ifdef PERL_XSUB_OLDSTYLE
2310 if (CvOLDSTYLE(cv)) {
2311 I32 (*fp3)(int,int,int);
2316 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2317 items = (*fp3)(CvXSUBANY(cv).any_i32,
2318 mark - PL_stack_base + 1,
2320 SP = PL_stack_base + items;
2323 #endif /* PERL_XSUB_OLDSTYLE */
2328 /* XS subs don't have a CxSUB, so pop it */
2329 POPBLOCK(cx, PL_curpm);
2330 /* Push a mark for the start of arglist */
2333 (void)(*CvXSUB(cv))(aTHX_ cv);
2334 /* Put these at the bottom since the vars are set but not used */
2335 PERL_UNUSED_VAR(newsp);
2336 PERL_UNUSED_VAR(gimme);
2342 AV* padlist = CvPADLIST(cv);
2343 if (CxTYPE(cx) == CXt_EVAL) {
2344 PL_in_eval = cx->blk_eval.old_in_eval;
2345 PL_eval_root = cx->blk_eval.old_eval_root;
2346 cx->cx_type = CXt_SUB;
2347 cx->blk_sub.hasargs = 0;
2349 cx->blk_sub.cv = cv;
2350 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2353 if (CvDEPTH(cv) < 2)
2354 (void)SvREFCNT_inc(cv);
2356 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2357 sub_crush_depth(cv);
2358 pad_push(padlist, CvDEPTH(cv));
2361 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2362 if (cx->blk_sub.hasargs)
2364 AV* av = (AV*)PAD_SVl(0);
2367 cx->blk_sub.savearray = GvAV(PL_defgv);
2368 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2369 CX_CURPAD_SAVE(cx->blk_sub);
2370 cx->blk_sub.argarray = av;
2372 if (items >= AvMAX(av) + 1) {
2374 if (AvARRAY(av) != ary) {
2375 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2376 SvPV_set(av, (char*)ary);
2378 if (items >= AvMAX(av) + 1) {
2379 AvMAX(av) = items - 1;
2380 Renew(ary,items+1,SV*);
2382 SvPV_set(av, (char*)ary);
2386 Copy(mark,AvARRAY(av),items,SV*);
2387 AvFILLp(av) = items - 1;
2388 assert(!AvREAL(av));
2390 /* transfer 'ownership' of refcnts to new @_ */
2400 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2402 * We do not care about using sv to call CV;
2403 * it's for informational purposes only.
2405 SV * const sv = GvSV(PL_DBsub);
2409 if (PERLDB_SUB_NN) {
2410 const int type = SvTYPE(sv);
2411 if (type < SVt_PVIV && type != SVt_IV)
2412 sv_upgrade(sv, SVt_PVIV);
2414 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2416 gv_efullname3(sv, CvGV(cv), Nullch);
2419 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2420 PUSHMARK( PL_stack_sp );
2421 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2425 RETURNOP(CvSTART(cv));
2429 label = SvPV_nolen_const(sv);
2430 if (!(do_dump || *label))
2431 DIE(aTHX_ must_have_label);
2434 else if (PL_op->op_flags & OPf_SPECIAL) {
2436 DIE(aTHX_ must_have_label);
2439 label = cPVOP->op_pv;
2441 if (label && *label) {
2443 bool leaving_eval = FALSE;
2444 bool in_block = FALSE;
2445 PERL_CONTEXT *last_eval_cx = 0;
2449 PL_lastgotoprobe = 0;
2451 for (ix = cxstack_ix; ix >= 0; ix--) {
2453 switch (CxTYPE(cx)) {
2455 leaving_eval = TRUE;
2456 if (!CxTRYBLOCK(cx)) {
2457 gotoprobe = (last_eval_cx ?
2458 last_eval_cx->blk_eval.old_eval_root :
2463 /* else fall through */
2465 gotoprobe = cx->blk_oldcop->op_sibling;
2471 gotoprobe = cx->blk_oldcop->op_sibling;
2474 gotoprobe = PL_main_root;
2477 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2478 gotoprobe = CvROOT(cx->blk_sub.cv);
2484 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2487 DIE(aTHX_ "panic: goto");
2488 gotoprobe = PL_main_root;
2492 retop = dofindlabel(gotoprobe, label,
2493 enterops, enterops + GOTO_DEPTH);
2497 PL_lastgotoprobe = gotoprobe;
2500 DIE(aTHX_ "Can't find label %s", label);
2502 /* if we're leaving an eval, check before we pop any frames
2503 that we're not going to punt, otherwise the error
2506 if (leaving_eval && *enterops && enterops[1]) {
2508 for (i = 1; enterops[i]; i++)
2509 if (enterops[i]->op_type == OP_ENTERITER)
2510 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2513 /* pop unwanted frames */
2515 if (ix < cxstack_ix) {
2522 oldsave = PL_scopestack[PL_scopestack_ix];
2523 LEAVE_SCOPE(oldsave);
2526 /* push wanted frames */
2528 if (*enterops && enterops[1]) {
2529 OP * const oldop = PL_op;
2530 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2531 for (; enterops[ix]; ix++) {
2532 PL_op = enterops[ix];
2533 /* Eventually we may want to stack the needed arguments
2534 * for each op. For now, we punt on the hard ones. */
2535 if (PL_op->op_type == OP_ENTERITER)
2536 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2537 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2545 if (!retop) retop = PL_main_start;
2547 PL_restartop = retop;
2548 PL_do_undump = TRUE;
2552 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2553 PL_do_undump = FALSE;
2569 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2571 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2574 PL_exit_flags |= PERL_EXIT_EXPECTED;
2576 PUSHs(&PL_sv_undef);
2584 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2585 register I32 match = I_32(value);
2588 if (((NV)match) > value)
2589 --match; /* was fractional--truncate other way */
2591 match -= cCOP->uop.scop.scop_offset;
2594 else if (match > cCOP->uop.scop.scop_max)
2595 match = cCOP->uop.scop.scop_max;
2596 PL_op = cCOP->uop.scop.scop_next[match];
2606 PL_op = PL_op->op_next; /* can't assume anything */
2608 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2609 match -= cCOP->uop.scop.scop_offset;
2612 else if (match > cCOP->uop.scop.scop_max)
2613 match = cCOP->uop.scop.scop_max;
2614 PL_op = cCOP->uop.scop.scop_next[match];
2623 S_save_lines(pTHX_ AV *array, SV *sv)
2625 const char *s = SvPVX_const(sv);
2626 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2629 while (s && s < send) {
2631 SV * const tmpstr = NEWSV(85,0);
2633 sv_upgrade(tmpstr, SVt_PVMG);
2634 t = strchr(s, '\n');
2640 sv_setpvn(tmpstr, s, t - s);
2641 av_store(array, line++, tmpstr);
2647 S_docatch_body(pTHX)
2654 S_docatch(pTHX_ OP *o)
2657 OP * const oldop = PL_op;
2661 assert(CATCH_GET == TRUE);
2668 assert(cxstack_ix >= 0);
2669 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2670 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2675 /* die caught by an inner eval - continue inner loop */
2677 /* NB XXX we rely on the old popped CxEVAL still being at the top
2678 * of the stack; the way die_where() currently works, this
2679 * assumption is valid. In theory The cur_top_env value should be
2680 * returned in another global, the way retop (aka PL_restartop)
2682 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2685 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2687 PL_op = PL_restartop;
2704 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2705 /* sv Text to convert to OP tree. */
2706 /* startop op_free() this to undo. */
2707 /* code Short string id of the caller. */
2709 /* FIXME - how much of this code is common with pp_entereval? */
2710 dVAR; dSP; /* Make POPBLOCK work. */
2717 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2718 char *tmpbuf = tbuf;
2721 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2727 /* switch to eval mode */
2729 if (IN_PERL_COMPILETIME) {
2730 SAVECOPSTASH_FREE(&PL_compiling);
2731 CopSTASH_set(&PL_compiling, PL_curstash);
2733 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2734 SV * const sv = sv_newmortal();
2735 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2736 code, (unsigned long)++PL_evalseq,
2737 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2742 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2743 (unsigned long)++PL_evalseq);
2744 SAVECOPFILE_FREE(&PL_compiling);
2745 CopFILE_set(&PL_compiling, tmpbuf+2);
2746 SAVECOPLINE(&PL_compiling);
2747 CopLINE_set(&PL_compiling, 1);
2748 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2749 deleting the eval's FILEGV from the stash before gv_check() runs
2750 (i.e. before run-time proper). To work around the coredump that
2751 ensues, we always turn GvMULTI_on for any globals that were
2752 introduced within evals. See force_ident(). GSAR 96-10-12 */
2753 safestr = savepvn(tmpbuf, len);
2754 SAVEDELETE(PL_defstash, safestr, len);
2756 #ifdef OP_IN_REGISTER
2762 /* we get here either during compilation, or via pp_regcomp at runtime */
2763 runtime = IN_PERL_RUNTIME;
2765 runcv = find_runcv(NULL);
2768 PL_op->op_type = OP_ENTEREVAL;
2769 PL_op->op_flags = 0; /* Avoid uninit warning. */
2770 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2771 PUSHEVAL(cx, 0, Nullgv);
2774 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2776 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2777 POPBLOCK(cx,PL_curpm);
2780 (*startop)->op_type = OP_NULL;
2781 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2783 /* XXX DAPM do this properly one year */
2784 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2786 if (IN_PERL_COMPILETIME)
2787 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2788 #ifdef OP_IN_REGISTER
2791 PERL_UNUSED_VAR(newsp);
2792 PERL_UNUSED_VAR(optype);
2799 =for apidoc find_runcv
2801 Locate the CV corresponding to the currently executing sub or eval.
2802 If db_seqp is non_null, skip CVs that are in the DB package and populate
2803 *db_seqp with the cop sequence number at the point that the DB:: code was
2804 entered. (allows debuggers to eval in the scope of the breakpoint rather
2805 than in the scope of the debugger itself).
2811 Perl_find_runcv(pTHX_ U32 *db_seqp)
2816 *db_seqp = PL_curcop->cop_seq;
2817 for (si = PL_curstackinfo; si; si = si->si_prev) {
2819 for (ix = si->si_cxix; ix >= 0; ix--) {
2820 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2821 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2822 CV * const cv = cx->blk_sub.cv;
2823 /* skip DB:: code */
2824 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2825 *db_seqp = cx->blk_oldcop->cop_seq;
2830 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2838 /* Compile a require/do, an eval '', or a /(?{...})/.
2839 * In the last case, startop is non-null, and contains the address of
2840 * a pointer that should be set to the just-compiled code.
2841 * outside is the lexically enclosing CV (if any) that invoked us.
2844 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2846 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2849 OP * const saveop = PL_op;
2851 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2852 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2857 SAVESPTR(PL_compcv);
2858 PL_compcv = (CV*)NEWSV(1104,0);
2859 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2860 CvEVAL_on(PL_compcv);
2861 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2862 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2864 CvOUTSIDE_SEQ(PL_compcv) = seq;
2865 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2867 /* set up a scratch pad */
2869 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2872 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2874 /* make sure we compile in the right package */
2876 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2877 SAVESPTR(PL_curstash);
2878 PL_curstash = CopSTASH(PL_curcop);
2880 SAVESPTR(PL_beginav);
2881 PL_beginav = newAV();
2882 SAVEFREESV(PL_beginav);
2883 SAVEI32(PL_error_count);
2885 /* try to compile it */
2887 PL_eval_root = Nullop;
2889 PL_curcop = &PL_compiling;
2890 PL_curcop->cop_arybase = 0;
2891 if (saveop && saveop->op_flags & OPf_SPECIAL)
2892 PL_in_eval |= EVAL_KEEPERR;
2894 sv_setpvn(ERRSV,"",0);
2895 if (yyparse() || PL_error_count || !PL_eval_root) {
2896 SV **newsp; /* Used by POPBLOCK. */
2897 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2898 I32 optype = 0; /* Might be reset by POPEVAL. */
2903 op_free(PL_eval_root);
2904 PL_eval_root = Nullop;
2906 SP = PL_stack_base + POPMARK; /* pop original mark */
2908 POPBLOCK(cx,PL_curpm);
2914 msg = SvPVx_nolen_const(ERRSV);
2915 if (optype == OP_REQUIRE) {
2916 const SV * const nsv = cx->blk_eval.old_namesv;
2917 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2919 DIE(aTHX_ "%sCompilation failed in require",
2920 *msg ? msg : "Unknown error\n");
2923 POPBLOCK(cx,PL_curpm);
2925 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2926 (*msg ? msg : "Unknown error\n"));
2930 sv_setpv(ERRSV, "Compilation error");
2933 PERL_UNUSED_VAR(newsp);
2936 CopLINE_set(&PL_compiling, 0);
2938 *startop = PL_eval_root;
2940 SAVEFREEOP(PL_eval_root);
2942 /* Set the context for this new optree.
2943 * If the last op is an OP_REQUIRE, force scalar context.
2944 * Otherwise, propagate the context from the eval(). */
2945 if (PL_eval_root->op_type == OP_LEAVEEVAL
2946 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2947 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2949 scalar(PL_eval_root);
2950 else if (gimme & G_VOID)
2951 scalarvoid(PL_eval_root);
2952 else if (gimme & G_ARRAY)
2955 scalar(PL_eval_root);
2957 DEBUG_x(dump_eval());
2959 /* Register with debugger: */
2960 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2961 CV * const cv = get_cv("DB::postponed", FALSE);
2965 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2967 call_sv((SV*)cv, G_DISCARD);
2971 /* compiled okay, so do it */
2973 CvDEPTH(PL_compcv) = 1;
2974 SP = PL_stack_base + POPMARK; /* pop original mark */
2975 PL_op = saveop; /* The caller may need it. */
2976 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2978 RETURNOP(PL_eval_start);
2982 S_doopen_pm(pTHX_ const char *name, const char *mode)
2984 #ifndef PERL_DISABLE_PMC
2985 const STRLEN namelen = strlen(name);
2988 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2989 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2990 const char * const pmc = SvPV_nolen_const(pmcsv);
2992 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2993 fp = PerlIO_open(name, mode);
2997 if (PerlLIO_stat(name, &pmstat) < 0 ||
2998 pmstat.st_mtime < pmcstat.st_mtime)
3000 fp = PerlIO_open(pmc, mode);
3003 fp = PerlIO_open(name, mode);
3006 SvREFCNT_dec(pmcsv);
3009 fp = PerlIO_open(name, mode);
3013 return PerlIO_open(name, mode);
3014 #endif /* !PERL_DISABLE_PMC */
3020 register PERL_CONTEXT *cx;
3024 const char *tryname = Nullch;
3025 SV *namesv = Nullsv;
3026 const I32 gimme = GIMME_V;
3027 PerlIO *tryrsfp = 0;
3028 int filter_has_file = 0;
3029 GV *filter_child_proc = 0;
3030 SV *filter_state = 0;
3037 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3038 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3039 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3040 "v-string in use/require non-portable");
3042 sv = new_version(sv);
3043 if (!sv_derived_from(PL_patchlevel, "version"))
3044 (void *)upg_version(PL_patchlevel);
3045 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3046 if ( vcmp(sv,PL_patchlevel) < 0 )
3047 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3048 vnormal(sv), vnormal(PL_patchlevel));
3051 if ( vcmp(sv,PL_patchlevel) > 0 )
3052 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3053 vnormal(sv), vnormal(PL_patchlevel));
3058 name = SvPV_const(sv, len);
3059 if (!(name && len > 0 && *name))
3060 DIE(aTHX_ "Null filename used");
3061 TAINT_PROPER("require");
3062 if (PL_op->op_type == OP_REQUIRE) {
3063 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3065 if (*svp != &PL_sv_undef)
3068 DIE(aTHX_ "Compilation failed in require");
3072 /* prepare to compile file */
3074 if (path_is_absolute(name)) {
3076 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3078 #ifdef MACOS_TRADITIONAL
3082 MacPerl_CanonDir(name, newname, 1);
3083 if (path_is_absolute(newname)) {
3085 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3090 AV * const ar = GvAVn(PL_incgv);
3094 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3097 namesv = NEWSV(806, 0);
3098 for (i = 0; i <= AvFILL(ar); i++) {
3099 SV *dirsv = *av_fetch(ar, i, TRUE);
3105 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3106 && !sv_isobject(loader))
3108 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3111 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3112 PTR2UV(SvRV(dirsv)), name);
3113 tryname = SvPVX_const(namesv);
3124 if (sv_isobject(loader))
3125 count = call_method("INC", G_ARRAY);
3127 count = call_sv(loader, G_ARRAY);
3137 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3141 if (SvTYPE(arg) == SVt_PVGV) {
3142 IO *io = GvIO((GV *)arg);
3147 tryrsfp = IoIFP(io);
3148 if (IoTYPE(io) == IoTYPE_PIPE) {
3149 /* reading from a child process doesn't
3150 nest -- when returning from reading
3151 the inner module, the outer one is
3152 unreadable (closed?) I've tried to
3153 save the gv to manage the lifespan of
3154 the pipe, but this didn't help. XXX */
3155 filter_child_proc = (GV *)arg;
3156 (void)SvREFCNT_inc(filter_child_proc);
3159 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3160 PerlIO_close(IoOFP(io));
3172 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3174 (void)SvREFCNT_inc(filter_sub);
3177 filter_state = SP[i];
3178 (void)SvREFCNT_inc(filter_state);
3182 tryrsfp = PerlIO_open("/dev/null",
3198 filter_has_file = 0;
3199 if (filter_child_proc) {
3200 SvREFCNT_dec(filter_child_proc);
3201 filter_child_proc = 0;
3204 SvREFCNT_dec(filter_state);
3208 SvREFCNT_dec(filter_sub);
3213 if (!path_is_absolute(name)
3214 #ifdef MACOS_TRADITIONAL
3215 /* We consider paths of the form :a:b ambiguous and interpret them first
3216 as global then as local
3218 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3221 const char *dir = SvPVx_nolen_const(dirsv);
3222 #ifdef MACOS_TRADITIONAL
3226 MacPerl_CanonDir(name, buf2, 1);
3227 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3231 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3233 sv_setpv(namesv, unixdir);
3234 sv_catpv(namesv, unixname);
3236 # ifdef __SYMBIAN32__
3237 if (PL_origfilename[0] &&
3238 PL_origfilename[1] == ':' &&
3239 !(dir[0] && dir[1] == ':'))
3240 Perl_sv_setpvf(aTHX_ namesv,
3245 Perl_sv_setpvf(aTHX_ namesv,
3249 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3253 TAINT_PROPER("require");
3254 tryname = SvPVX_const(namesv);
3255 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3257 if (tryname[0] == '.' && tryname[1] == '/')
3266 SAVECOPFILE_FREE(&PL_compiling);
3267 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3268 SvREFCNT_dec(namesv);
3270 if (PL_op->op_type == OP_REQUIRE) {
3271 const char *msgstr = name;
3272 if(errno == EMFILE) {
3273 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3274 sv_catpv(msg, ": ");
3275 sv_catpv(msg, Strerror(errno));
3276 msgstr = SvPV_nolen_const(msg);
3278 if (namesv) { /* did we lookup @INC? */
3279 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3280 SV * const dirmsgsv = NEWSV(0, 0);
3281 AV * const ar = GvAVn(PL_incgv);
3283 sv_catpvn(msg, " in @INC", 8);
3284 if (instr(SvPVX_const(msg), ".h "))
3285 sv_catpv(msg, " (change .h to .ph maybe?)");
3286 if (instr(SvPVX_const(msg), ".ph "))
3287 sv_catpv(msg, " (did you run h2ph?)");
3288 sv_catpv(msg, " (@INC contains:");
3289 for (i = 0; i <= AvFILL(ar); i++) {
3290 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3291 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3292 sv_catsv(msg, dirmsgsv);
3294 sv_catpvn(msg, ")", 1);
3295 SvREFCNT_dec(dirmsgsv);
3296 msgstr = SvPV_nolen_const(msg);
3299 DIE(aTHX_ "Can't locate %s", msgstr);
3305 SETERRNO(0, SS_NORMAL);
3307 /* Assume success here to prevent recursive requirement. */
3308 /* name is never assigned to again, so len is still strlen(name) */
3309 /* Check whether a hook in @INC has already filled %INC */
3311 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3313 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3315 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3320 lex_start(sv_2mortal(newSVpvn("",0)));
3321 SAVEGENERICSV(PL_rsfp_filters);
3322 PL_rsfp_filters = Nullav;
3327 SAVESPTR(PL_compiling.cop_warnings);
3328 if (PL_dowarn & G_WARN_ALL_ON)
3329 PL_compiling.cop_warnings = pWARN_ALL ;
3330 else if (PL_dowarn & G_WARN_ALL_OFF)
3331 PL_compiling.cop_warnings = pWARN_NONE ;
3332 else if (PL_taint_warn)
3333 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3335 PL_compiling.cop_warnings = pWARN_STD ;
3336 SAVESPTR(PL_compiling.cop_io);
3337 PL_compiling.cop_io = Nullsv;
3339 if (filter_sub || filter_child_proc) {
3340 SV * const datasv = filter_add(S_run_user_filter, Nullsv);
3341 IoLINES(datasv) = filter_has_file;
3342 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3343 IoTOP_GV(datasv) = (GV *)filter_state;
3344 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3347 /* switch to eval mode */
3348 PUSHBLOCK(cx, CXt_EVAL, SP);
3349 PUSHEVAL(cx, name, Nullgv);
3350 cx->blk_eval.retop = PL_op->op_next;
3352 SAVECOPLINE(&PL_compiling);
3353 CopLINE_set(&PL_compiling, 0);
3357 /* Store and reset encoding. */
3358 encoding = PL_encoding;
3359 PL_encoding = Nullsv;
3361 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3363 /* Restore encoding. */
3364 PL_encoding = encoding;
3372 register PERL_CONTEXT *cx;
3374 const I32 gimme = GIMME_V;
3375 const I32 was = PL_sub_generation;
3376 char tbuf[TYPE_DIGITS(long) + 12];
3377 char *tmpbuf = tbuf;
3384 if (!SvPV_nolen_const(sv))
3386 TAINT_PROPER("eval");
3392 /* switch to eval mode */
3394 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3395 SV * const sv = sv_newmortal();
3396 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3397 (unsigned long)++PL_evalseq,
3398 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3403 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3404 SAVECOPFILE_FREE(&PL_compiling);
3405 CopFILE_set(&PL_compiling, tmpbuf+2);
3406 SAVECOPLINE(&PL_compiling);
3407 CopLINE_set(&PL_compiling, 1);
3408 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3409 deleting the eval's FILEGV from the stash before gv_check() runs
3410 (i.e. before run-time proper). To work around the coredump that
3411 ensues, we always turn GvMULTI_on for any globals that were
3412 introduced within evals. See force_ident(). GSAR 96-10-12 */
3413 safestr = savepvn(tmpbuf, len);
3414 SAVEDELETE(PL_defstash, safestr, len);
3416 PL_hints = PL_op->op_targ;
3417 SAVESPTR(PL_compiling.cop_warnings);
3418 if (specialWARN(PL_curcop->cop_warnings))
3419 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3421 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3422 SAVEFREESV(PL_compiling.cop_warnings);
3424 SAVESPTR(PL_compiling.cop_io);
3425 if (specialCopIO(PL_curcop->cop_io))
3426 PL_compiling.cop_io = PL_curcop->cop_io;
3428 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3429 SAVEFREESV(PL_compiling.cop_io);
3431 /* special case: an eval '' executed within the DB package gets lexically
3432 * placed in the first non-DB CV rather than the current CV - this
3433 * allows the debugger to execute code, find lexicals etc, in the
3434 * scope of the code being debugged. Passing &seq gets find_runcv
3435 * to do the dirty work for us */
3436 runcv = find_runcv(&seq);
3438 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3439 PUSHEVAL(cx, 0, Nullgv);
3440 cx->blk_eval.retop = PL_op->op_next;
3442 /* prepare to compile string */
3444 if (PERLDB_LINE && PL_curstash != PL_debstash)
3445 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3447 ret = doeval(gimme, NULL, runcv, seq);
3448 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3449 && ret != PL_op->op_next) { /* Successive compilation. */
3450 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3452 return DOCATCH(ret);
3462 register PERL_CONTEXT *cx;
3464 const U8 save_flags = PL_op -> op_flags;
3469 retop = cx->blk_eval.retop;
3472 if (gimme == G_VOID)
3474 else if (gimme == G_SCALAR) {
3477 if (SvFLAGS(TOPs) & SVs_TEMP)
3480 *MARK = sv_mortalcopy(TOPs);
3484 *MARK = &PL_sv_undef;
3489 /* in case LEAVE wipes old return values */
3490 for (mark = newsp + 1; mark <= SP; mark++) {
3491 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3492 *mark = sv_mortalcopy(*mark);
3493 TAINT_NOT; /* Each item is independent */
3497 PL_curpm = newpm; /* Don't pop $1 et al till now */
3500 assert(CvDEPTH(PL_compcv) == 1);
3502 CvDEPTH(PL_compcv) = 0;
3505 if (optype == OP_REQUIRE &&
3506 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3508 /* Unassume the success we assumed earlier. */
3509 SV * const nsv = cx->blk_eval.old_namesv;
3510 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3511 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3512 /* die_where() did LEAVE, or we won't be here */
3516 if (!(save_flags & OPf_SPECIAL))
3517 sv_setpvn(ERRSV,"",0);
3526 register PERL_CONTEXT *cx;
3527 const I32 gimme = GIMME_V;
3532 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3534 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3536 PL_in_eval = EVAL_INEVAL;
3537 sv_setpvn(ERRSV,"",0);
3539 return DOCATCH(PL_op->op_next);
3549 register PERL_CONTEXT *cx;
3554 PERL_UNUSED_VAR(optype);
3557 if (gimme == G_VOID)
3559 else if (gimme == G_SCALAR) {
3562 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3565 *MARK = sv_mortalcopy(TOPs);
3569 *MARK = &PL_sv_undef;
3574 /* in case LEAVE wipes old return values */
3575 for (mark = newsp + 1; mark <= SP; mark++) {
3576 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3577 *mark = sv_mortalcopy(*mark);
3578 TAINT_NOT; /* Each item is independent */
3582 PL_curpm = newpm; /* Don't pop $1 et al till now */
3585 sv_setpvn(ERRSV,"",0);
3590 S_doparseform(pTHX_ SV *sv)
3593 register char *s = SvPV_force(sv, len);
3594 register char *send = s + len;
3595 register char *base = Nullch;
3596 register I32 skipspaces = 0;
3597 bool noblank = FALSE;
3598 bool repeat = FALSE;
3599 bool postspace = FALSE;
3605 bool unchopnum = FALSE;
3606 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3609 Perl_croak(aTHX_ "Null picture in formline");
3611 /* estimate the buffer size needed */
3612 for (base = s; s <= send; s++) {
3613 if (*s == '\n' || *s == '@' || *s == '^')
3619 Newx(fops, maxops, U32);
3624 *fpc++ = FF_LINEMARK;
3625 noblank = repeat = FALSE;
3643 case ' ': case '\t':
3650 } /* else FALL THROUGH */
3658 *fpc++ = FF_LITERAL;
3666 *fpc++ = (U16)skipspaces;
3670 *fpc++ = FF_NEWLINE;
3674 arg = fpc - linepc + 1;
3681 *fpc++ = FF_LINEMARK;
3682 noblank = repeat = FALSE;
3691 ischop = s[-1] == '^';
3697 arg = (s - base) - 1;
3699 *fpc++ = FF_LITERAL;
3707 *fpc++ = 2; /* skip the @* or ^* */
3709 *fpc++ = FF_LINESNGL;
3712 *fpc++ = FF_LINEGLOB;
3714 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3715 arg = ischop ? 512 : 0;
3720 const char * const f = ++s;
3723 arg |= 256 + (s - f);
3725 *fpc++ = s - base; /* fieldsize for FETCH */
3726 *fpc++ = FF_DECIMAL;
3728 unchopnum |= ! ischop;
3730 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3731 arg = ischop ? 512 : 0;
3733 s++; /* skip the '0' first */
3737 const char * const f = ++s;
3740 arg |= 256 + (s - f);
3742 *fpc++ = s - base; /* fieldsize for FETCH */
3743 *fpc++ = FF_0DECIMAL;
3745 unchopnum |= ! ischop;
3749 bool ismore = FALSE;
3752 while (*++s == '>') ;
3753 prespace = FF_SPACE;
3755 else if (*s == '|') {
3756 while (*++s == '|') ;
3757 prespace = FF_HALFSPACE;
3762 while (*++s == '<') ;
3765 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3769 *fpc++ = s - base; /* fieldsize for FETCH */
3771 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3774 *fpc++ = (U16)prespace;
3788 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3790 { /* need to jump to the next word */
3792 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3793 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3794 s = SvPVX(sv) + SvCUR(sv) + z;
3796 Copy(fops, s, arg, U32);
3798 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3801 if (unchopnum && repeat)
3802 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3808 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3810 /* Can value be printed in fldsize chars, using %*.*f ? */
3814 int intsize = fldsize - (value < 0 ? 1 : 0);
3821 while (intsize--) pwr *= 10.0;
3822 while (frcsize--) eps /= 10.0;
3825 if (value + eps >= pwr)
3828 if (value - eps <= -pwr)
3835 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3838 SV * const datasv = FILTER_DATA(idx);
3839 const int filter_has_file = IoLINES(datasv);
3840 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
3841 SV * const filter_state = (SV *)IoTOP_GV(datasv);
3842 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
3845 /* I was having segfault trouble under Linux 2.2.5 after a
3846 parse error occured. (Had to hack around it with a test
3847 for PL_error_count == 0.) Solaris doesn't segfault --
3848 not sure where the trouble is yet. XXX */
3850 if (filter_has_file) {
3851 len = FILTER_READ(idx+1, buf_sv, maxlen);
3854 if (filter_sub && len >= 0) {
3865 PUSHs(sv_2mortal(newSViv(maxlen)));
3867 PUSHs(filter_state);
3870 count = call_sv(filter_sub, G_SCALAR);
3886 IoLINES(datasv) = 0;
3887 if (filter_child_proc) {
3888 SvREFCNT_dec(filter_child_proc);
3889 IoFMT_GV(datasv) = Nullgv;
3892 SvREFCNT_dec(filter_state);
3893 IoTOP_GV(datasv) = Nullgv;
3896 SvREFCNT_dec(filter_sub);
3897 IoBOTTOM_GV(datasv) = Nullgv;
3899 filter_del(S_run_user_filter);
3905 /* perhaps someone can come up with a better name for
3906 this? it is not really "absolute", per se ... */
3908 S_path_is_absolute(pTHX_ const char *name)
3910 if (PERL_FILE_IS_ABSOLUTE(name)
3911 #ifdef MACOS_TRADITIONAL
3914 || (*name == '.' && (name[1] == '/' ||
3915 (name[1] == '.' && name[2] == '/')))
3927 * c-indentation-style: bsd
3929 * indent-tabs-mode: t
3932 * ex: set ts=8 sts=4 sw=4 noet: