3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
49 cxix = dopoptosub(cxstack_ix);
53 switch (cxstack[cxix].blk_gimme) {
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 MAGIC *mg = Null(MAGIC*);
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
96 if (PL_op->op_flags & OPf_STACKED) {
97 /* multiple args; concatentate them */
99 tmpstr = PAD_SV(ARGTARG);
100 sv_setpvn(tmpstr, "", 0);
101 while (++MARK <= SP) {
102 if (PL_amagic_generation) {
104 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
107 sv_setsv(tmpstr, sv);
111 sv_catsv(tmpstr, *MARK);
120 SV *sv = SvRV(tmpstr);
122 mg = mg_find(sv, PERL_MAGIC_qr);
125 regexp * const re = (regexp *)mg->mg_obj;
126 ReREFCNT_dec(PM_GETRE(pm));
127 PM_SETRE(pm, ReREFCNT_inc(re));
131 const char *t = SvPV_const(tmpstr, len);
133 /* Check against the last compiled regexp. */
134 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
135 PM_GETRE(pm)->prelen != (I32)len ||
136 memNE(PM_GETRE(pm)->precomp, t, len))
139 ReREFCNT_dec(PM_GETRE(pm));
140 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
142 if (PL_op->op_flags & OPf_SPECIAL)
143 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
145 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
147 pm->op_pmdynflags |= PMdf_DYN_UTF8;
149 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
150 if (pm->op_pmdynflags & PMdf_UTF8)
151 t = (char*)bytes_to_utf8((U8*)t, &len);
153 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
154 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
156 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
157 inside tie/overload accessors. */
161 #ifndef INCOMPLETE_TAINTS
164 pm->op_pmdynflags |= PMdf_TAINTED;
166 pm->op_pmdynflags &= ~PMdf_TAINTED;
170 if (!PM_GETRE(pm)->prelen && PL_curpm)
172 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
173 pm->op_pmflags |= PMf_WHITE;
175 pm->op_pmflags &= ~PMf_WHITE;
177 /* XXX runtime compiled output needs to move to the pad */
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 #if !defined(USE_ITHREADS)
181 /* XXX can't change the optree at runtime either */
182 cLOGOP->op_first->op_next = PL_op->op_next;
191 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
192 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
193 register SV * const dstr = cx->sb_dstr;
194 register char *s = cx->sb_s;
195 register char *m = cx->sb_m;
196 char *orig = cx->sb_orig;
197 register REGEXP * const rx = cx->sb_rx;
199 REGEXP *old = PM_GETRE(pm);
206 rxres_restore(&cx->sb_rxres, rx);
207 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
209 if (cx->sb_iters++) {
210 const I32 saviters = cx->sb_iters;
211 if (cx->sb_iters > cx->sb_maxiters)
212 DIE(aTHX_ "Substitution loop");
214 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
215 cx->sb_rxtainted |= 2;
216 sv_catsv(dstr, POPs);
219 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
220 s == m, cx->sb_targ, NULL,
221 ((cx->sb_rflags & REXEC_COPY_STR)
222 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
223 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
225 SV *targ = cx->sb_targ;
227 assert(cx->sb_strend >= s);
228 if(cx->sb_strend > s) {
229 if (DO_UTF8(dstr) && !SvUTF8(targ))
230 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
232 sv_catpvn(dstr, s, cx->sb_strend - s);
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
236 #ifdef PERL_OLD_COPY_ON_WRITE
238 sv_force_normal_flags(targ, SV_COW_DROP_PV);
244 SvPV_set(targ, SvPVX(dstr));
245 SvCUR_set(targ, SvCUR(dstr));
246 SvLEN_set(targ, SvLEN(dstr));
249 SvPV_set(dstr, (char*)0);
252 TAINT_IF(cx->sb_rxtainted & 1);
253 PUSHs(sv_2mortal(newSViv(saviters - 1)));
255 (void)SvPOK_only_UTF8(targ);
256 TAINT_IF(cx->sb_rxtainted);
260 LEAVE_SCOPE(cx->sb_oldsave);
263 RETURNOP(pm->op_next);
265 cx->sb_iters = saviters;
267 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
270 cx->sb_orig = orig = rx->subbeg;
272 cx->sb_strend = s + (cx->sb_strend - m);
274 cx->sb_m = m = rx->startp[0] + orig;
276 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
277 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
279 sv_catpvn(dstr, s, m-s);
281 cx->sb_s = rx->endp[0] + orig;
282 { /* Update the pos() information. */
283 SV * const sv = cx->sb_targ;
286 if (SvTYPE(sv) < SVt_PVMG)
287 SvUPGRADE(sv, SVt_PVMG);
288 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
289 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
290 mg = mg_find(sv, PERL_MAGIC_regex_global);
298 (void)ReREFCNT_inc(rx);
299 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
300 rxres_save(&cx->sb_rxres, rx);
301 RETURNOP(pm->op_pmreplstart);
305 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
310 if (!p || p[1] < rx->nparens) {
311 #ifdef PERL_OLD_COPY_ON_WRITE
312 i = 7 + rx->nparens * 2;
314 i = 6 + rx->nparens * 2;
323 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
324 RX_MATCH_COPIED_off(rx);
326 #ifdef PERL_OLD_COPY_ON_WRITE
327 *p++ = PTR2UV(rx->saved_copy);
328 rx->saved_copy = Nullsv;
333 *p++ = PTR2UV(rx->subbeg);
334 *p++ = (UV)rx->sublen;
335 for (i = 0; i <= rx->nparens; ++i) {
336 *p++ = (UV)rx->startp[i];
337 *p++ = (UV)rx->endp[i];
342 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
347 RX_MATCH_COPY_FREE(rx);
348 RX_MATCH_COPIED_set(rx, *p);
351 #ifdef PERL_OLD_COPY_ON_WRITE
353 SvREFCNT_dec (rx->saved_copy);
354 rx->saved_copy = INT2PTR(SV*,*p);
360 rx->subbeg = INT2PTR(char*,*p++);
361 rx->sublen = (I32)(*p++);
362 for (i = 0; i <= rx->nparens; ++i) {
363 rx->startp[i] = (I32)(*p++);
364 rx->endp[i] = (I32)(*p++);
369 Perl_rxres_free(pTHX_ void **rsp)
371 UV * const p = (UV*)*rsp;
375 void *tmp = INT2PTR(char*,*p);
378 Poison(*p, 1, sizeof(*p));
380 Safefree(INT2PTR(char*,*p));
382 #ifdef PERL_OLD_COPY_ON_WRITE
384 SvREFCNT_dec (INT2PTR(SV*,p[1]));
394 dSP; dMARK; dORIGMARK;
395 register SV *tmpForm = *++MARK;
400 register SV *sv = Nullsv;
401 const char *item = Nullch;
405 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
406 const char *chophere = Nullch;
407 char *linemark = Nullch;
409 bool gotsome = FALSE;
411 STRLEN fudge = SvPOK(tmpForm)
412 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
413 bool item_is_utf8 = FALSE;
414 bool targ_is_utf8 = FALSE;
420 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
421 if (SvREADONLY(tmpForm)) {
422 SvREADONLY_off(tmpForm);
423 parseres = doparseform(tmpForm);
424 SvREADONLY_on(tmpForm);
427 parseres = doparseform(tmpForm);
431 SvPV_force(PL_formtarget, len);
432 if (DO_UTF8(PL_formtarget))
434 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
436 f = SvPV_const(tmpForm, len);
437 /* need to jump to the next word */
438 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
442 const char *name = "???";
445 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
446 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
447 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
448 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
449 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
451 case FF_CHECKNL: name = "CHECKNL"; break;
452 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
453 case FF_SPACE: name = "SPACE"; break;
454 case FF_HALFSPACE: name = "HALFSPACE"; break;
455 case FF_ITEM: name = "ITEM"; break;
456 case FF_CHOP: name = "CHOP"; break;
457 case FF_LINEGLOB: name = "LINEGLOB"; break;
458 case FF_NEWLINE: name = "NEWLINE"; break;
459 case FF_MORE: name = "MORE"; break;
460 case FF_LINEMARK: name = "LINEMARK"; break;
461 case FF_END: name = "END"; break;
462 case FF_0DECIMAL: name = "0DECIMAL"; break;
463 case FF_LINESNGL: name = "LINESNGL"; break;
466 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
468 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
479 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
480 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
482 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
483 t = SvEND(PL_formtarget);
486 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
487 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
489 sv_utf8_upgrade(PL_formtarget);
490 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
491 t = SvEND(PL_formtarget);
511 if (ckWARN(WARN_SYNTAX))
512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
519 const char *s = item = SvPV_const(sv, len);
522 itemsize = sv_len_utf8(sv);
523 if (itemsize != (I32)len) {
525 if (itemsize > fieldsize) {
526 itemsize = fieldsize;
527 itembytes = itemsize;
528 sv_pos_u2b(sv, &itembytes, 0);
532 send = chophere = s + itembytes;
542 sv_pos_b2u(sv, &itemsize);
546 item_is_utf8 = FALSE;
547 if (itemsize > fieldsize)
548 itemsize = fieldsize;
549 send = chophere = s + itemsize;
563 const char *s = item = SvPV_const(sv, len);
566 itemsize = sv_len_utf8(sv);
567 if (itemsize != (I32)len) {
569 if (itemsize <= fieldsize) {
570 const char *send = chophere = s + itemsize;
583 itemsize = fieldsize;
584 itembytes = itemsize;
585 sv_pos_u2b(sv, &itembytes, 0);
586 send = chophere = s + itembytes;
587 while (s < send || (s == send && isSPACE(*s))) {
597 if (strchr(PL_chopset, *s))
602 itemsize = chophere - item;
603 sv_pos_b2u(sv, &itemsize);
609 item_is_utf8 = FALSE;
610 if (itemsize <= fieldsize) {
611 const char *const send = chophere = s + itemsize;
624 itemsize = fieldsize;
625 send = chophere = s + itemsize;
626 while (s < send || (s == send && isSPACE(*s))) {
636 if (strchr(PL_chopset, *s))
641 itemsize = chophere - item;
647 arg = fieldsize - itemsize;
656 arg = fieldsize - itemsize;
667 const char *s = item;
671 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
673 sv_utf8_upgrade(PL_formtarget);
674 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
675 t = SvEND(PL_formtarget);
679 if (UTF8_IS_CONTINUED(*s)) {
680 STRLEN skip = UTF8SKIP(s);
697 if ( !((*t++ = *s++) & ~31) )
703 if (targ_is_utf8 && !item_is_utf8) {
704 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
706 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
707 for (; t < SvEND(PL_formtarget); t++) {
720 const int ch = *t++ = *s++;
723 if ( !((*t++ = *s++) & ~31) )
732 const char *s = chophere;
734 while (*s && isSPACE(*s))
750 const char *s = item = SvPV_const(sv, len);
752 if ((item_is_utf8 = DO_UTF8(sv)))
753 itemsize = sv_len_utf8(sv);
755 bool chopped = FALSE;
756 const char *const send = s + len;
758 chophere = s + itemsize;
774 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
776 SvUTF8_on(PL_formtarget);
778 SvCUR_set(sv, chophere - item);
779 sv_catsv(PL_formtarget, sv);
780 SvCUR_set(sv, itemsize);
782 sv_catsv(PL_formtarget, sv);
784 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
785 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
786 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
795 #if defined(USE_LONG_DOUBLE)
796 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
798 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
803 #if defined(USE_LONG_DOUBLE)
804 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
806 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
809 /* If the field is marked with ^ and the value is undefined,
811 if ((arg & 512) && !SvOK(sv)) {
819 /* overflow evidence */
820 if (num_overflow(value, fieldsize, arg)) {
826 /* Formats aren't yet marked for locales, so assume "yes". */
828 STORE_NUMERIC_STANDARD_SET_LOCAL();
829 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
830 RESTORE_NUMERIC_STANDARD();
837 while (t-- > linemark && *t == ' ') ;
845 if (arg) { /* repeat until fields exhausted? */
847 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
848 lines += FmLINES(PL_formtarget);
851 if (strnEQ(linemark, linemark - arg, arg))
852 DIE(aTHX_ "Runaway format");
855 SvUTF8_on(PL_formtarget);
856 FmLINES(PL_formtarget) = lines;
858 RETURNOP(cLISTOP->op_first);
869 const char *s = chophere;
870 const char *send = item + len;
872 while (*s && isSPACE(*s) && s < send)
877 arg = fieldsize - itemsize;
884 if (strnEQ(s1," ",3)) {
885 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
896 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
898 SvUTF8_on(PL_formtarget);
899 FmLINES(PL_formtarget) += lines;
911 if (PL_stack_base + *PL_markstack_ptr == SP) {
913 if (GIMME_V == G_SCALAR)
914 XPUSHs(sv_2mortal(newSViv(0)));
915 RETURNOP(PL_op->op_next->op_next);
917 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
918 pp_pushmark(); /* push dst */
919 pp_pushmark(); /* push src */
920 ENTER; /* enter outer scope */
923 if (PL_op->op_private & OPpGREP_LEX)
924 SAVESPTR(PAD_SVl(PL_op->op_targ));
927 ENTER; /* enter inner scope */
930 src = PL_stack_base[*PL_markstack_ptr];
932 if (PL_op->op_private & OPpGREP_LEX)
933 PAD_SVl(PL_op->op_targ) = src;
938 if (PL_op->op_type == OP_MAPSTART)
939 pp_pushmark(); /* push top */
940 return ((LOGOP*)PL_op->op_next)->op_other;
945 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
951 const I32 gimme = GIMME_V;
952 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
958 /* first, move source pointer to the next item in the source list */
959 ++PL_markstack_ptr[-1];
961 /* if there are new items, push them into the destination list */
962 if (items && gimme != G_VOID) {
963 /* might need to make room back there first */
964 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
965 /* XXX this implementation is very pessimal because the stack
966 * is repeatedly extended for every set of items. Is possible
967 * to do this without any stack extension or copying at all
968 * by maintaining a separate list over which the map iterates
969 * (like foreach does). --gsar */
971 /* everything in the stack after the destination list moves
972 * towards the end the stack by the amount of room needed */
973 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
975 /* items to shift up (accounting for the moved source pointer) */
976 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
978 /* This optimization is by Ben Tilly and it does
979 * things differently from what Sarathy (gsar)
980 * is describing. The downside of this optimization is
981 * that leaves "holes" (uninitialized and hopefully unused areas)
982 * to the Perl stack, but on the other hand this
983 * shouldn't be a problem. If Sarathy's idea gets
984 * implemented, this optimization should become
985 * irrelevant. --jhi */
987 shift = count; /* Avoid shifting too often --Ben Tilly */
992 PL_markstack_ptr[-1] += shift;
993 *PL_markstack_ptr += shift;
997 /* copy the new items down to the destination list */
998 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
999 if (gimme == G_ARRAY) {
1001 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1004 /* scalar context: we don't care about which values map returns
1005 * (we use undef here). And so we certainly don't want to do mortal
1006 * copies of meaningless values. */
1007 while (items-- > 0) {
1009 *dst-- = &PL_sv_undef;
1013 LEAVE; /* exit inner scope */
1016 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1018 (void)POPMARK; /* pop top */
1019 LEAVE; /* exit outer scope */
1020 (void)POPMARK; /* pop src */
1021 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1022 (void)POPMARK; /* pop dst */
1023 SP = PL_stack_base + POPMARK; /* pop original mark */
1024 if (gimme == G_SCALAR) {
1025 if (PL_op->op_private & OPpGREP_LEX) {
1026 SV* sv = sv_newmortal();
1027 sv_setiv(sv, items);
1035 else if (gimme == G_ARRAY)
1042 ENTER; /* enter inner scope */
1045 /* set $_ to the new source item */
1046 src = PL_stack_base[PL_markstack_ptr[-1]];
1048 if (PL_op->op_private & OPpGREP_LEX)
1049 PAD_SVl(PL_op->op_targ) = src;
1053 RETURNOP(cLOGOP->op_other);
1061 if (GIMME == G_ARRAY)
1063 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1064 return cLOGOP->op_other;
1073 if (GIMME == G_ARRAY) {
1074 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1078 SV * const targ = PAD_SV(PL_op->op_targ);
1081 if (PL_op->op_private & OPpFLIP_LINENUM) {
1082 if (GvIO(PL_last_in_gv)) {
1083 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1086 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1088 flip = SvIV(sv) == SvIV(GvSV(gv));
1094 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1095 if (PL_op->op_flags & OPf_SPECIAL) {
1103 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1106 sv_setpvn(TARG, "", 0);
1112 /* This code tries to decide if "$left .. $right" should use the
1113 magical string increment, or if the range is numeric (we make
1114 an exception for .."0" [#18165]). AMS 20021031. */
1116 #define RANGE_IS_NUMERIC(left,right) ( \
1117 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1118 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1119 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1120 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1121 && (!SvOK(right) || looks_like_number(right))))
1127 if (GIMME == G_ARRAY) {
1133 if (RANGE_IS_NUMERIC(left,right)) {
1136 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1137 (SvOK(right) && SvNV(right) > IV_MAX))
1138 DIE(aTHX_ "Range iterator outside integer range");
1149 SV * const sv = sv_2mortal(newSViv(i++));
1154 SV * const final = sv_mortalcopy(right);
1156 const char *tmps = SvPV_const(final, len);
1158 SV *sv = sv_mortalcopy(left);
1159 SvPV_force_nolen(sv);
1160 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1162 if (strEQ(SvPVX_const(sv),tmps))
1164 sv = sv_2mortal(newSVsv(sv));
1171 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1175 if (PL_op->op_private & OPpFLIP_LINENUM) {
1176 if (GvIO(PL_last_in_gv)) {
1177 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1180 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1181 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1189 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1190 sv_catpvn(targ, "E0", 2);
1200 static const char * const context_name[] = {
1211 S_dopoptolabel(pTHX_ const char *label)
1215 for (i = cxstack_ix; i >= 0; i--) {
1216 register const PERL_CONTEXT * const cx = &cxstack[i];
1217 switch (CxTYPE(cx)) {
1223 if (ckWARN(WARN_EXITING))
1224 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1225 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1226 if (CxTYPE(cx) == CXt_NULL)
1230 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1231 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1232 (long)i, cx->blk_loop.label));
1235 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1243 Perl_dowantarray(pTHX)
1245 const I32 gimme = block_gimme();
1246 return (gimme == G_VOID) ? G_SCALAR : gimme;
1250 Perl_block_gimme(pTHX)
1252 const I32 cxix = dopoptosub(cxstack_ix);
1256 switch (cxstack[cxix].blk_gimme) {
1264 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1271 Perl_is_lvalue_sub(pTHX)
1273 const I32 cxix = dopoptosub(cxstack_ix);
1274 assert(cxix >= 0); /* We should only be called from inside subs */
1276 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1277 return cxstack[cxix].blk_sub.lval;
1283 S_dopoptosub(pTHX_ I32 startingblock)
1285 return dopoptosub_at(cxstack, startingblock);
1289 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1292 for (i = startingblock; i >= 0; i--) {
1293 register const PERL_CONTEXT * const cx = &cxstk[i];
1294 switch (CxTYPE(cx)) {
1300 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1308 S_dopoptoeval(pTHX_ I32 startingblock)
1311 for (i = startingblock; i >= 0; i--) {
1312 register const PERL_CONTEXT *cx = &cxstack[i];
1313 switch (CxTYPE(cx)) {
1317 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1325 S_dopoptoloop(pTHX_ I32 startingblock)
1328 for (i = startingblock; i >= 0; i--) {
1329 register const PERL_CONTEXT * const cx = &cxstack[i];
1330 switch (CxTYPE(cx)) {
1336 if (ckWARN(WARN_EXITING))
1337 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1338 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1339 if ((CxTYPE(cx)) == CXt_NULL)
1343 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1351 Perl_dounwind(pTHX_ I32 cxix)
1355 while (cxstack_ix > cxix) {
1357 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1358 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1359 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1360 /* Note: we don't need to restore the base context info till the end. */
1361 switch (CxTYPE(cx)) {
1364 continue; /* not break */
1383 PERL_UNUSED_VAR(optype);
1387 Perl_qerror(pTHX_ SV *err)
1390 sv_catsv(ERRSV, err);
1392 sv_catsv(PL_errors, err);
1394 Perl_warn(aTHX_ "%"SVf, err);
1399 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1408 if (PL_in_eval & EVAL_KEEPERR) {
1409 static const char prefix[] = "\t(in cleanup) ";
1410 SV * const err = ERRSV;
1411 const char *e = Nullch;
1413 sv_setpvn(err,"",0);
1414 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1416 e = SvPV_const(err, len);
1418 if (*e != *message || strNE(e,message))
1422 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1423 sv_catpvn(err, prefix, sizeof(prefix)-1);
1424 sv_catpvn(err, message, msglen);
1425 if (ckWARN(WARN_MISC)) {
1426 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1427 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1432 sv_setpvn(ERRSV, message, msglen);
1436 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1437 && PL_curstackinfo->si_prev)
1445 register PERL_CONTEXT *cx;
1448 if (cxix < cxstack_ix)
1451 POPBLOCK(cx,PL_curpm);
1452 if (CxTYPE(cx) != CXt_EVAL) {
1454 message = SvPVx_const(ERRSV, msglen);
1455 PerlIO_write(Perl_error_log, "panic: die ", 11);
1456 PerlIO_write(Perl_error_log, message, msglen);
1461 if (gimme == G_SCALAR)
1462 *++newsp = &PL_sv_undef;
1463 PL_stack_sp = newsp;
1467 /* LEAVE could clobber PL_curcop (see save_re_context())
1468 * XXX it might be better to find a way to avoid messing with
1469 * PL_curcop in save_re_context() instead, but this is a more
1470 * minimal fix --GSAR */
1471 PL_curcop = cx->blk_oldcop;
1473 if (optype == OP_REQUIRE) {
1474 const char* const msg = SvPVx_nolen_const(ERRSV);
1475 SV * const nsv = cx->blk_eval.old_namesv;
1476 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1478 DIE(aTHX_ "%sCompilation failed in require",
1479 *msg ? msg : "Unknown error\n");
1481 assert(CxTYPE(cx) == CXt_EVAL);
1482 return cx->blk_eval.retop;
1486 message = SvPVx_const(ERRSV, msglen);
1488 write_to_stderr(message, msglen);
1497 if (SvTRUE(left) != SvTRUE(right))
1509 RETURNOP(cLOGOP->op_other);
1518 RETURNOP(cLOGOP->op_other);
1527 if (!sv || !SvANY(sv)) {
1528 RETURNOP(cLOGOP->op_other);
1531 switch (SvTYPE(sv)) {
1533 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1537 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1541 if (CvROOT(sv) || CvXSUB(sv))
1550 RETURNOP(cLOGOP->op_other);
1556 register I32 cxix = dopoptosub(cxstack_ix);
1557 register const PERL_CONTEXT *cx;
1558 register const PERL_CONTEXT *ccstack = cxstack;
1559 const PERL_SI *top_si = PL_curstackinfo;
1561 const char *stashname;
1568 /* we may be in a higher stacklevel, so dig down deeper */
1569 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1570 top_si = top_si->si_prev;
1571 ccstack = top_si->si_cxstack;
1572 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1575 if (GIMME != G_ARRAY) {
1581 /* caller() should not report the automatic calls to &DB::sub */
1582 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1583 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1587 cxix = dopoptosub_at(ccstack, cxix - 1);
1590 cx = &ccstack[cxix];
1591 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1592 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1593 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1594 field below is defined for any cx. */
1595 /* caller() should not report the automatic calls to &DB::sub */
1596 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1597 cx = &ccstack[dbcxix];
1600 stashname = CopSTASHPV(cx->blk_oldcop);
1601 if (GIMME != G_ARRAY) {
1604 PUSHs(&PL_sv_undef);
1607 sv_setpv(TARG, stashname);
1616 PUSHs(&PL_sv_undef);
1618 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1619 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1620 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1623 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1624 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1625 /* So is ccstack[dbcxix]. */
1627 SV * const sv = NEWSV(49, 0);
1628 gv_efullname3(sv, cvgv, Nullch);
1629 PUSHs(sv_2mortal(sv));
1630 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1633 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1634 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1638 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1639 PUSHs(sv_2mortal(newSViv(0)));
1641 gimme = (I32)cx->blk_gimme;
1642 if (gimme == G_VOID)
1643 PUSHs(&PL_sv_undef);
1645 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1646 if (CxTYPE(cx) == CXt_EVAL) {
1648 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1649 PUSHs(cx->blk_eval.cur_text);
1653 else if (cx->blk_eval.old_namesv) {
1654 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1657 /* eval BLOCK (try blocks have old_namesv == 0) */
1659 PUSHs(&PL_sv_undef);
1660 PUSHs(&PL_sv_undef);
1664 PUSHs(&PL_sv_undef);
1665 PUSHs(&PL_sv_undef);
1667 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1668 && CopSTASH_eq(PL_curcop, PL_debstash))
1670 AV * const ary = cx->blk_sub.argarray;
1671 const int off = AvARRAY(ary) - AvALLOC(ary);
1675 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1678 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1681 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1682 av_extend(PL_dbargs, AvFILLp(ary) + off);
1683 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1684 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1686 /* XXX only hints propagated via op_private are currently
1687 * visible (others are not easily accessible, since they
1688 * use the global PL_hints) */
1689 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1690 HINT_PRIVATE_MASK)));
1693 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1695 if (old_warnings == pWARN_NONE ||
1696 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1697 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1698 else if (old_warnings == pWARN_ALL ||
1699 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1700 /* Get the bit mask for $warnings::Bits{all}, because
1701 * it could have been extended by warnings::register */
1703 HV *bits = get_hv("warnings::Bits", FALSE);
1704 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1705 mask = newSVsv(*bits_all);
1708 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1712 mask = newSVsv(old_warnings);
1713 PUSHs(sv_2mortal(mask));
1727 sv_reset(tmps, CopSTASH(PL_curcop));
1737 /* like pp_nextstate, but used instead when the debugger is active */
1742 PL_curcop = (COP*)PL_op;
1743 TAINT_NOT; /* Each statement is presumed innocent */
1744 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1747 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1748 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1752 register PERL_CONTEXT *cx;
1753 const I32 gimme = G_ARRAY;
1760 DIE(aTHX_ "No DB::DB routine defined");
1762 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1763 /* don't do recursive DB::DB call */
1778 (void)(*CvXSUB(cv))(aTHX_ cv);
1785 PUSHBLOCK(cx, CXt_SUB, SP);
1787 cx->blk_sub.retop = PL_op->op_next;
1790 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1791 RETURNOP(CvSTART(cv));
1806 register PERL_CONTEXT *cx;
1807 const I32 gimme = GIMME_V;
1809 U32 cxtype = CXt_LOOP;
1817 if (PL_op->op_targ) {
1818 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1819 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1820 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1821 SVs_PADSTALE, SVs_PADSTALE);
1823 #ifndef USE_ITHREADS
1824 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1827 SAVEPADSV(PL_op->op_targ);
1828 iterdata = INT2PTR(void*, PL_op->op_targ);
1829 cxtype |= CXp_PADVAR;
1834 svp = &GvSV(gv); /* symbol table variable */
1835 SAVEGENERICSV(*svp);
1838 iterdata = (void*)gv;
1844 PUSHBLOCK(cx, cxtype, SP);
1846 PUSHLOOP(cx, iterdata, MARK);
1848 PUSHLOOP(cx, svp, MARK);
1850 if (PL_op->op_flags & OPf_STACKED) {
1851 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1852 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1854 SV *right = (SV*)cx->blk_loop.iterary;
1857 if (RANGE_IS_NUMERIC(sv,right)) {
1858 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1859 (SvOK(right) && SvNV(right) >= IV_MAX))
1860 DIE(aTHX_ "Range iterator outside integer range");
1861 cx->blk_loop.iterix = SvIV(sv);
1862 cx->blk_loop.itermax = SvIV(right);
1864 /* for correct -Dstv display */
1865 cx->blk_oldsp = sp - PL_stack_base;
1869 cx->blk_loop.iterlval = newSVsv(sv);
1870 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1871 (void) SvPV_nolen_const(right);
1874 else if (PL_op->op_private & OPpITER_REVERSED) {
1875 cx->blk_loop.itermax = -1;
1876 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1881 cx->blk_loop.iterary = PL_curstack;
1882 AvFILLp(PL_curstack) = SP - PL_stack_base;
1883 if (PL_op->op_private & OPpITER_REVERSED) {
1884 cx->blk_loop.itermax = MARK - PL_stack_base;
1885 cx->blk_loop.iterix = cx->blk_oldsp;
1888 cx->blk_loop.iterix = MARK - PL_stack_base;
1898 register PERL_CONTEXT *cx;
1899 const I32 gimme = GIMME_V;
1905 PUSHBLOCK(cx, CXt_LOOP, SP);
1906 PUSHLOOP(cx, 0, SP);
1914 register PERL_CONTEXT *cx;
1921 assert(CxTYPE(cx) == CXt_LOOP);
1923 newsp = PL_stack_base + cx->blk_loop.resetsp;
1926 if (gimme == G_VOID)
1928 else if (gimme == G_SCALAR) {
1930 *++newsp = sv_mortalcopy(*SP);
1932 *++newsp = &PL_sv_undef;
1936 *++newsp = sv_mortalcopy(*++mark);
1937 TAINT_NOT; /* Each item is independent */
1943 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1944 PL_curpm = newpm; /* ... and pop $1 et al */
1956 register PERL_CONTEXT *cx;
1957 bool popsub2 = FALSE;
1958 bool clear_errsv = FALSE;
1966 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1967 if (cxstack_ix == PL_sortcxix
1968 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1970 if (cxstack_ix > PL_sortcxix)
1971 dounwind(PL_sortcxix);
1972 AvARRAY(PL_curstack)[1] = *SP;
1973 PL_stack_sp = PL_stack_base + 1;
1978 cxix = dopoptosub(cxstack_ix);
1980 DIE(aTHX_ "Can't return outside a subroutine");
1981 if (cxix < cxstack_ix)
1985 switch (CxTYPE(cx)) {
1988 retop = cx->blk_sub.retop;
1989 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1992 if (!(PL_in_eval & EVAL_KEEPERR))
1995 retop = cx->blk_eval.retop;
1999 if (optype == OP_REQUIRE &&
2000 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2002 /* Unassume the success we assumed earlier. */
2003 SV * const nsv = cx->blk_eval.old_namesv;
2004 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2005 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2010 retop = cx->blk_sub.retop;
2013 DIE(aTHX_ "panic: return");
2017 if (gimme == G_SCALAR) {
2020 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2022 *++newsp = SvREFCNT_inc(*SP);
2027 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2029 *++newsp = sv_mortalcopy(sv);
2034 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2037 *++newsp = sv_mortalcopy(*SP);
2040 *++newsp = &PL_sv_undef;
2042 else if (gimme == G_ARRAY) {
2043 while (++MARK <= SP) {
2044 *++newsp = (popsub2 && SvTEMP(*MARK))
2045 ? *MARK : sv_mortalcopy(*MARK);
2046 TAINT_NOT; /* Each item is independent */
2049 PL_stack_sp = newsp;
2052 /* Stack values are safe: */
2055 POPSUB(cx,sv); /* release CV and @_ ... */
2059 PL_curpm = newpm; /* ... and pop $1 et al */
2063 sv_setpvn(ERRSV,"",0);
2071 register PERL_CONTEXT *cx;
2082 if (PL_op->op_flags & OPf_SPECIAL) {
2083 cxix = dopoptoloop(cxstack_ix);
2085 DIE(aTHX_ "Can't \"last\" outside a loop block");
2088 cxix = dopoptolabel(cPVOP->op_pv);
2090 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2092 if (cxix < cxstack_ix)
2096 cxstack_ix++; /* temporarily protect top context */
2098 switch (CxTYPE(cx)) {
2101 newsp = PL_stack_base + cx->blk_loop.resetsp;
2102 nextop = cx->blk_loop.last_op->op_next;
2106 nextop = cx->blk_sub.retop;
2110 nextop = cx->blk_eval.retop;
2114 nextop = cx->blk_sub.retop;
2117 DIE(aTHX_ "panic: last");
2121 if (gimme == G_SCALAR) {
2123 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2124 ? *SP : sv_mortalcopy(*SP);
2126 *++newsp = &PL_sv_undef;
2128 else if (gimme == G_ARRAY) {
2129 while (++MARK <= SP) {
2130 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2131 ? *MARK : sv_mortalcopy(*MARK);
2132 TAINT_NOT; /* Each item is independent */
2140 /* Stack values are safe: */
2143 POPLOOP(cx); /* release loop vars ... */
2147 POPSUB(cx,sv); /* release CV and @_ ... */
2150 PL_curpm = newpm; /* ... and pop $1 et al */
2153 PERL_UNUSED_VAR(optype);
2154 PERL_UNUSED_VAR(gimme);
2162 register PERL_CONTEXT *cx;
2165 if (PL_op->op_flags & OPf_SPECIAL) {
2166 cxix = dopoptoloop(cxstack_ix);
2168 DIE(aTHX_ "Can't \"next\" outside a loop block");
2171 cxix = dopoptolabel(cPVOP->op_pv);
2173 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2175 if (cxix < cxstack_ix)
2178 /* clear off anything above the scope we're re-entering, but
2179 * save the rest until after a possible continue block */
2180 inner = PL_scopestack_ix;
2182 if (PL_scopestack_ix < inner)
2183 leave_scope(PL_scopestack[PL_scopestack_ix]);
2184 PL_curcop = cx->blk_oldcop;
2185 return cx->blk_loop.next_op;
2192 register PERL_CONTEXT *cx;
2196 if (PL_op->op_flags & OPf_SPECIAL) {
2197 cxix = dopoptoloop(cxstack_ix);
2199 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2202 cxix = dopoptolabel(cPVOP->op_pv);
2204 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2206 if (cxix < cxstack_ix)
2209 redo_op = cxstack[cxix].blk_loop.redo_op;
2210 if (redo_op->op_type == OP_ENTER) {
2211 /* pop one less context to avoid $x being freed in while (my $x..) */
2213 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2214 redo_op = redo_op->op_next;
2218 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2219 LEAVE_SCOPE(oldsave);
2221 PL_curcop = cx->blk_oldcop;
2226 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2229 static const char too_deep[] = "Target of goto is too deeply nested";
2232 Perl_croak(aTHX_ too_deep);
2233 if (o->op_type == OP_LEAVE ||
2234 o->op_type == OP_SCOPE ||
2235 o->op_type == OP_LEAVELOOP ||
2236 o->op_type == OP_LEAVESUB ||
2237 o->op_type == OP_LEAVETRY)
2239 *ops++ = cUNOPo->op_first;
2241 Perl_croak(aTHX_ too_deep);
2244 if (o->op_flags & OPf_KIDS) {
2246 /* First try all the kids at this level, since that's likeliest. */
2247 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2248 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2249 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2252 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2253 if (kid == PL_lastgotoprobe)
2255 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2258 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2259 ops[-1]->op_type == OP_DBSTATE)
2264 if ((o = dofindlabel(kid, label, ops, oplimit)))
2283 register PERL_CONTEXT *cx;
2284 #define GOTO_DEPTH 64
2285 OP *enterops[GOTO_DEPTH];
2286 const char *label = 0;
2287 const bool do_dump = (PL_op->op_type == OP_DUMP);
2288 static const char must_have_label[] = "goto must have label";
2290 if (PL_op->op_flags & OPf_STACKED) {
2291 SV * const sv = POPs;
2293 /* This egregious kludge implements goto &subroutine */
2294 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2296 register PERL_CONTEXT *cx;
2297 CV* cv = (CV*)SvRV(sv);
2304 if (!CvROOT(cv) && !CvXSUB(cv)) {
2305 const GV * const gv = CvGV(cv);
2309 /* autoloaded stub? */
2310 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2312 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2313 GvNAMELEN(gv), FALSE);
2314 if (autogv && (cv = GvCV(autogv)))
2316 tmpstr = sv_newmortal();
2317 gv_efullname3(tmpstr, gv, Nullch);
2318 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2320 DIE(aTHX_ "Goto undefined subroutine");
2323 /* First do some returnish stuff. */
2324 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2326 cxix = dopoptosub(cxstack_ix);
2328 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2329 if (cxix < cxstack_ix)
2333 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2334 if (CxTYPE(cx) == CXt_EVAL) {
2336 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2338 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2340 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2341 /* put @_ back onto stack */
2342 AV* av = cx->blk_sub.argarray;
2344 items = AvFILLp(av) + 1;
2345 EXTEND(SP, items+1); /* @_ could have been extended. */
2346 Copy(AvARRAY(av), SP + 1, items, SV*);
2347 SvREFCNT_dec(GvAV(PL_defgv));
2348 GvAV(PL_defgv) = cx->blk_sub.savearray;
2350 /* abandon @_ if it got reified */
2355 av_extend(av, items-1);
2357 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2360 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2361 AV* const av = GvAV(PL_defgv);
2362 items = AvFILLp(av) + 1;
2363 EXTEND(SP, items+1); /* @_ could have been extended. */
2364 Copy(AvARRAY(av), SP + 1, items, SV*);
2368 if (CxTYPE(cx) == CXt_SUB &&
2369 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2370 SvREFCNT_dec(cx->blk_sub.cv);
2371 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2372 LEAVE_SCOPE(oldsave);
2374 /* Now do some callish stuff. */
2376 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2378 OP* retop = cx->blk_sub.retop;
2381 for (index=0; index<items; index++)
2382 sv_2mortal(SP[-index]);
2384 #ifdef PERL_XSUB_OLDSTYLE
2385 if (CvOLDSTYLE(cv)) {
2386 I32 (*fp3)(int,int,int);
2391 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2392 items = (*fp3)(CvXSUBANY(cv).any_i32,
2393 mark - PL_stack_base + 1,
2395 SP = PL_stack_base + items;
2398 #endif /* PERL_XSUB_OLDSTYLE */
2403 /* XS subs don't have a CxSUB, so pop it */
2404 POPBLOCK(cx, PL_curpm);
2405 /* Push a mark for the start of arglist */
2408 (void)(*CvXSUB(cv))(aTHX_ cv);
2409 /* Put these at the bottom since the vars are set but not used */
2410 PERL_UNUSED_VAR(newsp);
2411 PERL_UNUSED_VAR(gimme);
2417 AV* padlist = CvPADLIST(cv);
2418 if (CxTYPE(cx) == CXt_EVAL) {
2419 PL_in_eval = cx->blk_eval.old_in_eval;
2420 PL_eval_root = cx->blk_eval.old_eval_root;
2421 cx->cx_type = CXt_SUB;
2422 cx->blk_sub.hasargs = 0;
2424 cx->blk_sub.cv = cv;
2425 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2428 if (CvDEPTH(cv) < 2)
2429 (void)SvREFCNT_inc(cv);
2431 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2432 sub_crush_depth(cv);
2433 pad_push(padlist, CvDEPTH(cv));
2436 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2437 if (cx->blk_sub.hasargs)
2439 AV* av = (AV*)PAD_SVl(0);
2442 cx->blk_sub.savearray = GvAV(PL_defgv);
2443 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2444 CX_CURPAD_SAVE(cx->blk_sub);
2445 cx->blk_sub.argarray = av;
2447 if (items >= AvMAX(av) + 1) {
2449 if (AvARRAY(av) != ary) {
2450 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2451 SvPV_set(av, (char*)ary);
2453 if (items >= AvMAX(av) + 1) {
2454 AvMAX(av) = items - 1;
2455 Renew(ary,items+1,SV*);
2457 SvPV_set(av, (char*)ary);
2461 Copy(mark,AvARRAY(av),items,SV*);
2462 AvFILLp(av) = items - 1;
2463 assert(!AvREAL(av));
2465 /* transfer 'ownership' of refcnts to new @_ */
2475 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2477 * We do not care about using sv to call CV;
2478 * it's for informational purposes only.
2480 SV * const sv = GvSV(PL_DBsub);
2484 if (PERLDB_SUB_NN) {
2485 const int type = SvTYPE(sv);
2486 if (type < SVt_PVIV && type != SVt_IV)
2487 sv_upgrade(sv, SVt_PVIV);
2489 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2491 gv_efullname3(sv, CvGV(cv), Nullch);
2494 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2495 PUSHMARK( PL_stack_sp );
2496 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2500 RETURNOP(CvSTART(cv));
2504 label = SvPV_nolen_const(sv);
2505 if (!(do_dump || *label))
2506 DIE(aTHX_ must_have_label);
2509 else if (PL_op->op_flags & OPf_SPECIAL) {
2511 DIE(aTHX_ must_have_label);
2514 label = cPVOP->op_pv;
2516 if (label && *label) {
2518 bool leaving_eval = FALSE;
2519 bool in_block = FALSE;
2520 PERL_CONTEXT *last_eval_cx = 0;
2524 PL_lastgotoprobe = 0;
2526 for (ix = cxstack_ix; ix >= 0; ix--) {
2528 switch (CxTYPE(cx)) {
2530 leaving_eval = TRUE;
2531 if (!CxTRYBLOCK(cx)) {
2532 gotoprobe = (last_eval_cx ?
2533 last_eval_cx->blk_eval.old_eval_root :
2538 /* else fall through */
2540 gotoprobe = cx->blk_oldcop->op_sibling;
2546 gotoprobe = cx->blk_oldcop->op_sibling;
2549 gotoprobe = PL_main_root;
2552 if (CvDEPTH(cx->blk_sub.cv)) {
2553 gotoprobe = CvROOT(cx->blk_sub.cv);
2559 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2562 DIE(aTHX_ "panic: goto");
2563 gotoprobe = PL_main_root;
2567 retop = dofindlabel(gotoprobe, label,
2568 enterops, enterops + GOTO_DEPTH);
2572 PL_lastgotoprobe = gotoprobe;
2575 DIE(aTHX_ "Can't find label %s", label);
2577 /* if we're leaving an eval, check before we pop any frames
2578 that we're not going to punt, otherwise the error
2581 if (leaving_eval && *enterops && enterops[1]) {
2583 for (i = 1; enterops[i]; i++)
2584 if (enterops[i]->op_type == OP_ENTERITER)
2585 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2588 /* pop unwanted frames */
2590 if (ix < cxstack_ix) {
2597 oldsave = PL_scopestack[PL_scopestack_ix];
2598 LEAVE_SCOPE(oldsave);
2601 /* push wanted frames */
2603 if (*enterops && enterops[1]) {
2605 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2606 for (; enterops[ix]; ix++) {
2607 PL_op = enterops[ix];
2608 /* Eventually we may want to stack the needed arguments
2609 * for each op. For now, we punt on the hard ones. */
2610 if (PL_op->op_type == OP_ENTERITER)
2611 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2612 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2620 if (!retop) retop = PL_main_start;
2622 PL_restartop = retop;
2623 PL_do_undump = TRUE;
2627 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2628 PL_do_undump = FALSE;
2644 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2646 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2649 PL_exit_flags |= PERL_EXIT_EXPECTED;
2651 PUSHs(&PL_sv_undef);
2659 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2660 register I32 match = I_32(value);
2663 if (((NV)match) > value)
2664 --match; /* was fractional--truncate other way */
2666 match -= cCOP->uop.scop.scop_offset;
2669 else if (match > cCOP->uop.scop.scop_max)
2670 match = cCOP->uop.scop.scop_max;
2671 PL_op = cCOP->uop.scop.scop_next[match];
2681 PL_op = PL_op->op_next; /* can't assume anything */
2683 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2684 match -= cCOP->uop.scop.scop_offset;
2687 else if (match > cCOP->uop.scop.scop_max)
2688 match = cCOP->uop.scop.scop_max;
2689 PL_op = cCOP->uop.scop.scop_next[match];
2698 S_save_lines(pTHX_ AV *array, SV *sv)
2700 const char *s = SvPVX_const(sv);
2701 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2704 while (s && s < send) {
2706 SV * const tmpstr = NEWSV(85,0);
2708 sv_upgrade(tmpstr, SVt_PVMG);
2709 t = strchr(s, '\n');
2715 sv_setpvn(tmpstr, s, t - s);
2716 av_store(array, line++, tmpstr);
2722 S_docatch_body(pTHX)
2729 S_docatch(pTHX_ OP *o)
2732 OP * const oldop = PL_op;
2736 assert(CATCH_GET == TRUE);
2743 assert(cxstack_ix >= 0);
2744 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2745 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2750 /* die caught by an inner eval - continue inner loop */
2752 /* NB XXX we rely on the old popped CxEVAL still being at the top
2753 * of the stack; the way die_where() currently works, this
2754 * assumption is valid. In theory The cur_top_env value should be
2755 * returned in another global, the way retop (aka PL_restartop)
2757 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2760 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2762 PL_op = PL_restartop;
2779 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2780 /* sv Text to convert to OP tree. */
2781 /* startop op_free() this to undo. */
2782 /* code Short string id of the caller. */
2784 dVAR; dSP; /* Make POPBLOCK work. */
2791 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2792 char *tmpbuf = tbuf;
2795 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2800 /* switch to eval mode */
2802 if (IN_PERL_COMPILETIME) {
2803 SAVECOPSTASH_FREE(&PL_compiling);
2804 CopSTASH_set(&PL_compiling, PL_curstash);
2806 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2807 SV * const sv = sv_newmortal();
2808 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2809 code, (unsigned long)++PL_evalseq,
2810 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2814 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2815 SAVECOPFILE_FREE(&PL_compiling);
2816 CopFILE_set(&PL_compiling, tmpbuf+2);
2817 SAVECOPLINE(&PL_compiling);
2818 CopLINE_set(&PL_compiling, 1);
2819 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2820 deleting the eval's FILEGV from the stash before gv_check() runs
2821 (i.e. before run-time proper). To work around the coredump that
2822 ensues, we always turn GvMULTI_on for any globals that were
2823 introduced within evals. See force_ident(). GSAR 96-10-12 */
2824 safestr = savepv(tmpbuf);
2825 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2827 #ifdef OP_IN_REGISTER
2833 /* we get here either during compilation, or via pp_regcomp at runtime */
2834 runtime = IN_PERL_RUNTIME;
2836 runcv = find_runcv(NULL);
2839 PL_op->op_type = OP_ENTEREVAL;
2840 PL_op->op_flags = 0; /* Avoid uninit warning. */
2841 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2842 PUSHEVAL(cx, 0, Nullgv);
2845 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2847 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2848 POPBLOCK(cx,PL_curpm);
2851 (*startop)->op_type = OP_NULL;
2852 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2854 /* XXX DAPM do this properly one year */
2855 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2857 if (IN_PERL_COMPILETIME)
2858 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2859 #ifdef OP_IN_REGISTER
2862 PERL_UNUSED_VAR(newsp);
2863 PERL_UNUSED_VAR(optype);
2870 =for apidoc find_runcv
2872 Locate the CV corresponding to the currently executing sub or eval.
2873 If db_seqp is non_null, skip CVs that are in the DB package and populate
2874 *db_seqp with the cop sequence number at the point that the DB:: code was
2875 entered. (allows debuggers to eval in the scope of the breakpoint rather
2876 than in the scope of the debugger itself).
2882 Perl_find_runcv(pTHX_ U32 *db_seqp)
2887 *db_seqp = PL_curcop->cop_seq;
2888 for (si = PL_curstackinfo; si; si = si->si_prev) {
2890 for (ix = si->si_cxix; ix >= 0; ix--) {
2891 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2892 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2893 CV * const cv = cx->blk_sub.cv;
2894 /* skip DB:: code */
2895 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2896 *db_seqp = cx->blk_oldcop->cop_seq;
2901 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2909 /* Compile a require/do, an eval '', or a /(?{...})/.
2910 * In the last case, startop is non-null, and contains the address of
2911 * a pointer that should be set to the just-compiled code.
2912 * outside is the lexically enclosing CV (if any) that invoked us.
2915 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2917 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2920 OP * const saveop = PL_op;
2922 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2923 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2928 SAVESPTR(PL_compcv);
2929 PL_compcv = (CV*)NEWSV(1104,0);
2930 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2931 CvEVAL_on(PL_compcv);
2932 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2933 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2935 CvOUTSIDE_SEQ(PL_compcv) = seq;
2936 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2938 /* set up a scratch pad */
2940 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2943 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2945 /* make sure we compile in the right package */
2947 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2948 SAVESPTR(PL_curstash);
2949 PL_curstash = CopSTASH(PL_curcop);
2951 SAVESPTR(PL_beginav);
2952 PL_beginav = newAV();
2953 SAVEFREESV(PL_beginav);
2954 SAVEI32(PL_error_count);
2956 /* try to compile it */
2958 PL_eval_root = Nullop;
2960 PL_curcop = &PL_compiling;
2961 PL_curcop->cop_arybase = 0;
2962 if (saveop && saveop->op_flags & OPf_SPECIAL)
2963 PL_in_eval |= EVAL_KEEPERR;
2965 sv_setpvn(ERRSV,"",0);
2966 if (yyparse() || PL_error_count || !PL_eval_root) {
2967 SV **newsp; /* Used by POPBLOCK. */
2968 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2969 I32 optype = 0; /* Might be reset by POPEVAL. */
2974 op_free(PL_eval_root);
2975 PL_eval_root = Nullop;
2977 SP = PL_stack_base + POPMARK; /* pop original mark */
2979 POPBLOCK(cx,PL_curpm);
2985 msg = SvPVx_nolen_const(ERRSV);
2986 if (optype == OP_REQUIRE) {
2987 const SV * const nsv = cx->blk_eval.old_namesv;
2988 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2990 DIE(aTHX_ "%sCompilation failed in require",
2991 *msg ? msg : "Unknown error\n");
2994 POPBLOCK(cx,PL_curpm);
2996 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2997 (*msg ? msg : "Unknown error\n"));
3001 sv_setpv(ERRSV, "Compilation error");
3004 PERL_UNUSED_VAR(newsp);
3007 CopLINE_set(&PL_compiling, 0);
3009 *startop = PL_eval_root;
3011 SAVEFREEOP(PL_eval_root);
3013 /* Set the context for this new optree.
3014 * If the last op is an OP_REQUIRE, force scalar context.
3015 * Otherwise, propagate the context from the eval(). */
3016 if (PL_eval_root->op_type == OP_LEAVEEVAL
3017 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3018 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3020 scalar(PL_eval_root);
3021 else if (gimme & G_VOID)
3022 scalarvoid(PL_eval_root);
3023 else if (gimme & G_ARRAY)
3026 scalar(PL_eval_root);
3028 DEBUG_x(dump_eval());
3030 /* Register with debugger: */
3031 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3032 CV * const cv = get_cv("DB::postponed", FALSE);
3036 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3038 call_sv((SV*)cv, G_DISCARD);
3042 /* compiled okay, so do it */
3044 CvDEPTH(PL_compcv) = 1;
3045 SP = PL_stack_base + POPMARK; /* pop original mark */
3046 PL_op = saveop; /* The caller may need it. */
3047 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3049 RETURNOP(PL_eval_start);
3053 S_doopen_pm(pTHX_ const char *name, const char *mode)
3055 #ifndef PERL_DISABLE_PMC
3056 const STRLEN namelen = strlen(name);
3059 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3060 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3061 const char * const pmc = SvPV_nolen_const(pmcsv);
3063 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3064 fp = PerlIO_open(name, mode);
3068 if (PerlLIO_stat(name, &pmstat) < 0 ||
3069 pmstat.st_mtime < pmcstat.st_mtime)
3071 fp = PerlIO_open(pmc, mode);
3074 fp = PerlIO_open(name, mode);
3077 SvREFCNT_dec(pmcsv);
3080 fp = PerlIO_open(name, mode);
3084 return PerlIO_open(name, mode);
3085 #endif /* !PERL_DISABLE_PMC */
3091 register PERL_CONTEXT *cx;
3095 const char *tryname = Nullch;
3096 SV *namesv = Nullsv;
3097 const I32 gimme = GIMME_V;
3098 PerlIO *tryrsfp = 0;
3099 int filter_has_file = 0;
3100 GV *filter_child_proc = 0;
3101 SV *filter_state = 0;
3108 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3109 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3110 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3111 "v-string in use/require non-portable");
3113 sv = new_version(sv);
3114 if (!sv_derived_from(PL_patchlevel, "version"))
3115 (void *)upg_version(PL_patchlevel);
3116 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3117 if ( vcmp(sv,PL_patchlevel) < 0 )
3118 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3119 vnormal(sv), vnormal(PL_patchlevel));
3122 if ( vcmp(sv,PL_patchlevel) > 0 )
3123 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3124 vnormal(sv), vnormal(PL_patchlevel));
3129 name = SvPV_const(sv, len);
3130 if (!(name && len > 0 && *name))
3131 DIE(aTHX_ "Null filename used");
3132 TAINT_PROPER("require");
3133 if (PL_op->op_type == OP_REQUIRE) {
3134 SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3136 if (*svp != &PL_sv_undef)
3139 DIE(aTHX_ "Compilation failed in require");
3143 /* prepare to compile file */
3145 if (path_is_absolute(name)) {
3147 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3149 #ifdef MACOS_TRADITIONAL
3153 MacPerl_CanonDir(name, newname, 1);
3154 if (path_is_absolute(newname)) {
3156 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3161 AV * const ar = GvAVn(PL_incgv);
3165 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3168 namesv = NEWSV(806, 0);
3169 for (i = 0; i <= AvFILL(ar); i++) {
3170 SV *dirsv = *av_fetch(ar, i, TRUE);
3176 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3177 && !sv_isobject(loader))
3179 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3182 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3183 PTR2UV(SvRV(dirsv)), name);
3184 tryname = SvPVX_const(namesv);
3195 if (sv_isobject(loader))
3196 count = call_method("INC", G_ARRAY);
3198 count = call_sv(loader, G_ARRAY);
3208 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3212 if (SvTYPE(arg) == SVt_PVGV) {
3213 IO *io = GvIO((GV *)arg);
3218 tryrsfp = IoIFP(io);
3219 if (IoTYPE(io) == IoTYPE_PIPE) {
3220 /* reading from a child process doesn't
3221 nest -- when returning from reading
3222 the inner module, the outer one is
3223 unreadable (closed?) I've tried to
3224 save the gv to manage the lifespan of
3225 the pipe, but this didn't help. XXX */
3226 filter_child_proc = (GV *)arg;
3227 (void)SvREFCNT_inc(filter_child_proc);
3230 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3231 PerlIO_close(IoOFP(io));
3243 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3245 (void)SvREFCNT_inc(filter_sub);
3248 filter_state = SP[i];
3249 (void)SvREFCNT_inc(filter_state);
3253 tryrsfp = PerlIO_open("/dev/null",
3269 filter_has_file = 0;
3270 if (filter_child_proc) {
3271 SvREFCNT_dec(filter_child_proc);
3272 filter_child_proc = 0;
3275 SvREFCNT_dec(filter_state);
3279 SvREFCNT_dec(filter_sub);
3284 if (!path_is_absolute(name)
3285 #ifdef MACOS_TRADITIONAL
3286 /* We consider paths of the form :a:b ambiguous and interpret them first
3287 as global then as local
3289 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3292 const char *dir = SvPVx_nolen_const(dirsv);
3293 #ifdef MACOS_TRADITIONAL
3297 MacPerl_CanonDir(name, buf2, 1);
3298 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3302 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3304 sv_setpv(namesv, unixdir);
3305 sv_catpv(namesv, unixname);
3308 if (PL_origfilename[0] &&
3309 PL_origfilename[1] == ':' &&
3310 !(dir[0] && dir[1] == ':'))
3311 Perl_sv_setpvf(aTHX_ namesv,
3316 Perl_sv_setpvf(aTHX_ namesv,
3320 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3324 TAINT_PROPER("require");
3325 tryname = SvPVX_const(namesv);
3326 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3328 if (tryname[0] == '.' && tryname[1] == '/')
3337 SAVECOPFILE_FREE(&PL_compiling);
3338 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3339 SvREFCNT_dec(namesv);
3341 if (PL_op->op_type == OP_REQUIRE) {
3342 const char *msgstr = name;
3343 if(errno == EMFILE) {
3344 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3345 sv_catpv(msg, ": ");
3346 sv_catpv(msg, Strerror(errno));
3347 msgstr = SvPV_nolen_const(msg);
3349 if (namesv) { /* did we lookup @INC? */
3350 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3351 SV * const dirmsgsv = NEWSV(0, 0);
3352 AV * const ar = GvAVn(PL_incgv);
3354 sv_catpvn(msg, " in @INC", 8);
3355 if (instr(SvPVX_const(msg), ".h "))
3356 sv_catpv(msg, " (change .h to .ph maybe?)");
3357 if (instr(SvPVX_const(msg), ".ph "))
3358 sv_catpv(msg, " (did you run h2ph?)");
3359 sv_catpv(msg, " (@INC contains:");
3360 for (i = 0; i <= AvFILL(ar); i++) {
3361 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3362 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3363 sv_catsv(msg, dirmsgsv);
3365 sv_catpvn(msg, ")", 1);
3366 SvREFCNT_dec(dirmsgsv);
3367 msgstr = SvPV_nolen_const(msg);
3370 DIE(aTHX_ "Can't locate %s", msgstr);
3376 SETERRNO(0, SS_NORMAL);
3378 /* Assume success here to prevent recursive requirement. */
3380 /* Check whether a hook in @INC has already filled %INC */
3382 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3384 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3386 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3391 lex_start(sv_2mortal(newSVpvn("",0)));
3392 SAVEGENERICSV(PL_rsfp_filters);
3393 PL_rsfp_filters = Nullav;
3398 SAVESPTR(PL_compiling.cop_warnings);
3399 if (PL_dowarn & G_WARN_ALL_ON)
3400 PL_compiling.cop_warnings = pWARN_ALL ;
3401 else if (PL_dowarn & G_WARN_ALL_OFF)
3402 PL_compiling.cop_warnings = pWARN_NONE ;
3403 else if (PL_taint_warn)
3404 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3406 PL_compiling.cop_warnings = pWARN_STD ;
3407 SAVESPTR(PL_compiling.cop_io);
3408 PL_compiling.cop_io = Nullsv;
3410 if (filter_sub || filter_child_proc) {
3411 SV * const datasv = filter_add(run_user_filter, Nullsv);
3412 IoLINES(datasv) = filter_has_file;
3413 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3414 IoTOP_GV(datasv) = (GV *)filter_state;
3415 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3418 /* switch to eval mode */
3419 PUSHBLOCK(cx, CXt_EVAL, SP);
3420 PUSHEVAL(cx, name, Nullgv);
3421 cx->blk_eval.retop = PL_op->op_next;
3423 SAVECOPLINE(&PL_compiling);
3424 CopLINE_set(&PL_compiling, 0);
3428 /* Store and reset encoding. */
3429 encoding = PL_encoding;
3430 PL_encoding = Nullsv;
3432 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3434 /* Restore encoding. */
3435 PL_encoding = encoding;
3442 return pp_require();
3448 register PERL_CONTEXT *cx;
3450 const I32 gimme = GIMME_V;
3451 const I32 was = PL_sub_generation;
3452 char tbuf[TYPE_DIGITS(long) + 12];
3453 char *tmpbuf = tbuf;
3460 if (!SvPV_const(sv,len))
3462 TAINT_PROPER("eval");
3468 /* switch to eval mode */
3470 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3471 SV * const sv = sv_newmortal();
3472 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3473 (unsigned long)++PL_evalseq,
3474 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3478 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3479 SAVECOPFILE_FREE(&PL_compiling);
3480 CopFILE_set(&PL_compiling, tmpbuf+2);
3481 SAVECOPLINE(&PL_compiling);
3482 CopLINE_set(&PL_compiling, 1);
3483 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3484 deleting the eval's FILEGV from the stash before gv_check() runs
3485 (i.e. before run-time proper). To work around the coredump that
3486 ensues, we always turn GvMULTI_on for any globals that were
3487 introduced within evals. See force_ident(). GSAR 96-10-12 */
3488 safestr = savepv(tmpbuf);
3489 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3491 PL_hints = PL_op->op_targ;
3492 SAVESPTR(PL_compiling.cop_warnings);
3493 if (specialWARN(PL_curcop->cop_warnings))
3494 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3496 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3497 SAVEFREESV(PL_compiling.cop_warnings);
3499 SAVESPTR(PL_compiling.cop_io);
3500 if (specialCopIO(PL_curcop->cop_io))
3501 PL_compiling.cop_io = PL_curcop->cop_io;
3503 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3504 SAVEFREESV(PL_compiling.cop_io);
3506 /* special case: an eval '' executed within the DB package gets lexically
3507 * placed in the first non-DB CV rather than the current CV - this
3508 * allows the debugger to execute code, find lexicals etc, in the
3509 * scope of the code being debugged. Passing &seq gets find_runcv
3510 * to do the dirty work for us */
3511 runcv = find_runcv(&seq);
3513 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3514 PUSHEVAL(cx, 0, Nullgv);
3515 cx->blk_eval.retop = PL_op->op_next;
3517 /* prepare to compile string */
3519 if (PERLDB_LINE && PL_curstash != PL_debstash)
3520 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3522 ret = doeval(gimme, NULL, runcv, seq);
3523 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3524 && ret != PL_op->op_next) { /* Successive compilation. */
3525 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3527 return DOCATCH(ret);
3537 register PERL_CONTEXT *cx;
3539 const U8 save_flags = PL_op -> op_flags;
3544 retop = cx->blk_eval.retop;
3547 if (gimme == G_VOID)
3549 else if (gimme == G_SCALAR) {
3552 if (SvFLAGS(TOPs) & SVs_TEMP)
3555 *MARK = sv_mortalcopy(TOPs);
3559 *MARK = &PL_sv_undef;
3564 /* in case LEAVE wipes old return values */
3565 for (mark = newsp + 1; mark <= SP; mark++) {
3566 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3567 *mark = sv_mortalcopy(*mark);
3568 TAINT_NOT; /* Each item is independent */
3572 PL_curpm = newpm; /* Don't pop $1 et al till now */
3575 assert(CvDEPTH(PL_compcv) == 1);
3577 CvDEPTH(PL_compcv) = 0;
3580 if (optype == OP_REQUIRE &&
3581 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3583 /* Unassume the success we assumed earlier. */
3584 SV * const nsv = cx->blk_eval.old_namesv;
3585 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3586 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3587 /* die_where() did LEAVE, or we won't be here */
3591 if (!(save_flags & OPf_SPECIAL))
3592 sv_setpvn(ERRSV,"",0);
3601 register PERL_CONTEXT *cx;
3602 const I32 gimme = GIMME_V;
3607 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3609 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3611 PL_in_eval = EVAL_INEVAL;
3612 sv_setpvn(ERRSV,"",0);
3614 return DOCATCH(PL_op->op_next);
3624 register PERL_CONTEXT *cx;
3629 PERL_UNUSED_VAR(optype);
3632 if (gimme == G_VOID)
3634 else if (gimme == G_SCALAR) {
3637 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3640 *MARK = sv_mortalcopy(TOPs);
3644 *MARK = &PL_sv_undef;
3649 /* in case LEAVE wipes old return values */
3650 for (mark = newsp + 1; mark <= SP; mark++) {
3651 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3652 *mark = sv_mortalcopy(*mark);
3653 TAINT_NOT; /* Each item is independent */
3657 PL_curpm = newpm; /* Don't pop $1 et al till now */
3660 sv_setpvn(ERRSV,"",0);
3665 S_doparseform(pTHX_ SV *sv)
3668 register char *s = SvPV_force(sv, len);
3669 register char *send = s + len;
3670 register char *base = Nullch;
3671 register I32 skipspaces = 0;
3672 bool noblank = FALSE;
3673 bool repeat = FALSE;
3674 bool postspace = FALSE;
3680 bool unchopnum = FALSE;
3681 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3684 Perl_croak(aTHX_ "Null picture in formline");
3686 /* estimate the buffer size needed */
3687 for (base = s; s <= send; s++) {
3688 if (*s == '\n' || *s == '@' || *s == '^')
3694 Newx(fops, maxops, U32);
3699 *fpc++ = FF_LINEMARK;
3700 noblank = repeat = FALSE;
3718 case ' ': case '\t':
3725 } /* else FALL THROUGH */
3733 *fpc++ = FF_LITERAL;
3741 *fpc++ = (U16)skipspaces;
3745 *fpc++ = FF_NEWLINE;
3749 arg = fpc - linepc + 1;
3756 *fpc++ = FF_LINEMARK;
3757 noblank = repeat = FALSE;
3766 ischop = s[-1] == '^';
3772 arg = (s - base) - 1;
3774 *fpc++ = FF_LITERAL;
3782 *fpc++ = 2; /* skip the @* or ^* */
3784 *fpc++ = FF_LINESNGL;
3787 *fpc++ = FF_LINEGLOB;
3789 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3790 arg = ischop ? 512 : 0;
3795 const char * const f = ++s;
3798 arg |= 256 + (s - f);
3800 *fpc++ = s - base; /* fieldsize for FETCH */
3801 *fpc++ = FF_DECIMAL;
3803 unchopnum |= ! ischop;
3805 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3806 arg = ischop ? 512 : 0;
3808 s++; /* skip the '0' first */
3812 const char * const f = ++s;
3815 arg |= 256 + (s - f);
3817 *fpc++ = s - base; /* fieldsize for FETCH */
3818 *fpc++ = FF_0DECIMAL;
3820 unchopnum |= ! ischop;
3824 bool ismore = FALSE;
3827 while (*++s == '>') ;
3828 prespace = FF_SPACE;
3830 else if (*s == '|') {
3831 while (*++s == '|') ;
3832 prespace = FF_HALFSPACE;
3837 while (*++s == '<') ;
3840 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3844 *fpc++ = s - base; /* fieldsize for FETCH */
3846 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3849 *fpc++ = (U16)prespace;
3863 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3865 { /* need to jump to the next word */
3867 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3868 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3869 s = SvPVX(sv) + SvCUR(sv) + z;
3871 Copy(fops, s, arg, U32);
3873 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3876 if (unchopnum && repeat)
3877 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3883 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3885 /* Can value be printed in fldsize chars, using %*.*f ? */
3889 int intsize = fldsize - (value < 0 ? 1 : 0);
3896 while (intsize--) pwr *= 10.0;
3897 while (frcsize--) eps /= 10.0;
3900 if (value + eps >= pwr)
3903 if (value - eps <= -pwr)
3910 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3913 SV *datasv = FILTER_DATA(idx);
3914 const int filter_has_file = IoLINES(datasv);
3915 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3916 SV *filter_state = (SV *)IoTOP_GV(datasv);
3917 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3920 /* I was having segfault trouble under Linux 2.2.5 after a
3921 parse error occured. (Had to hack around it with a test
3922 for PL_error_count == 0.) Solaris doesn't segfault --
3923 not sure where the trouble is yet. XXX */
3925 if (filter_has_file) {
3926 len = FILTER_READ(idx+1, buf_sv, maxlen);
3929 if (filter_sub && len >= 0) {
3940 PUSHs(sv_2mortal(newSViv(maxlen)));
3942 PUSHs(filter_state);
3945 count = call_sv(filter_sub, G_SCALAR);
3961 IoLINES(datasv) = 0;
3962 if (filter_child_proc) {
3963 SvREFCNT_dec(filter_child_proc);
3964 IoFMT_GV(datasv) = Nullgv;
3967 SvREFCNT_dec(filter_state);
3968 IoTOP_GV(datasv) = Nullgv;
3971 SvREFCNT_dec(filter_sub);
3972 IoBOTTOM_GV(datasv) = Nullgv;
3974 filter_del(run_user_filter);
3980 /* perhaps someone can come up with a better name for
3981 this? it is not really "absolute", per se ... */
3983 S_path_is_absolute(pTHX_ const char *name)
3985 if (PERL_FILE_IS_ABSOLUTE(name)
3986 #ifdef MACOS_TRADITIONAL
3989 || (*name == '.' && (name[1] == '/' ||
3990 (name[1] == '.' && name[2] == '/'))))
4001 * c-indentation-style: bsd
4003 * indent-tabs-mode: t
4006 * ex: set ts=8 sts=4 sw=4 noet: