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 *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 *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)
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 *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 *gv = gv_fetchpv(".", TRUE, SVt_PV);
1087 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1093 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1094 if (PL_op->op_flags & OPf_SPECIAL) {
1102 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1105 sv_setpvn(TARG, "", 0);
1111 /* This code tries to decide if "$left .. $right" should use the
1112 magical string increment, or if the range is numeric (we make
1113 an exception for .."0" [#18165]). AMS 20021031. */
1115 #define RANGE_IS_NUMERIC(left,right) ( \
1116 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1117 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1118 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1119 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1120 && (!SvOK(right) || looks_like_number(right))))
1126 if (GIMME == G_ARRAY) {
1129 if (SvGMAGICAL(left))
1131 if (SvGMAGICAL(right))
1134 if (RANGE_IS_NUMERIC(left,right)) {
1137 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1138 (SvOK(right) && SvNV(right) > IV_MAX))
1139 DIE(aTHX_ "Range iterator outside integer range");
1150 SV * const sv = sv_2mortal(newSViv(i++));
1155 SV *final = sv_mortalcopy(right);
1157 const char *tmps = SvPV_const(final, len);
1159 SV *sv = sv_mortalcopy(left);
1160 SvPV_force_nolen(sv);
1161 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1163 if (strEQ(SvPVX_const(sv),tmps))
1165 sv = sv_2mortal(newSVsv(sv));
1172 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1176 if (PL_op->op_private & OPpFLIP_LINENUM) {
1177 if (GvIO(PL_last_in_gv)) {
1178 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1181 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1182 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1190 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1191 sv_catpvn(targ, "E0", 2);
1201 static const char * const context_name[] = {
1212 S_dopoptolabel(pTHX_ const char *label)
1216 for (i = cxstack_ix; i >= 0; i--) {
1217 register const PERL_CONTEXT * const cx = &cxstack[i];
1218 switch (CxTYPE(cx)) {
1224 if (ckWARN(WARN_EXITING))
1225 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1226 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1227 if (CxTYPE(cx) == CXt_NULL)
1231 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1232 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1233 (long)i, cx->blk_loop.label));
1236 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1244 Perl_dowantarray(pTHX)
1246 const I32 gimme = block_gimme();
1247 return (gimme == G_VOID) ? G_SCALAR : gimme;
1251 Perl_block_gimme(pTHX)
1253 const I32 cxix = dopoptosub(cxstack_ix);
1257 switch (cxstack[cxix].blk_gimme) {
1265 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1272 Perl_is_lvalue_sub(pTHX)
1274 const I32 cxix = dopoptosub(cxstack_ix);
1275 assert(cxix >= 0); /* We should only be called from inside subs */
1277 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1278 return cxstack[cxix].blk_sub.lval;
1284 S_dopoptosub(pTHX_ I32 startingblock)
1286 return dopoptosub_at(cxstack, startingblock);
1290 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1293 for (i = startingblock; i >= 0; i--) {
1294 register const PERL_CONTEXT * const cx = &cxstk[i];
1295 switch (CxTYPE(cx)) {
1301 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1309 S_dopoptoeval(pTHX_ I32 startingblock)
1312 for (i = startingblock; i >= 0; i--) {
1313 register const PERL_CONTEXT *cx = &cxstack[i];
1314 switch (CxTYPE(cx)) {
1318 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1326 S_dopoptoloop(pTHX_ I32 startingblock)
1329 for (i = startingblock; i >= 0; i--) {
1330 register const PERL_CONTEXT * const cx = &cxstack[i];
1331 switch (CxTYPE(cx)) {
1337 if (ckWARN(WARN_EXITING))
1338 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1339 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1340 if ((CxTYPE(cx)) == CXt_NULL)
1344 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1352 Perl_dounwind(pTHX_ I32 cxix)
1356 while (cxstack_ix > cxix) {
1358 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1359 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1360 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1361 /* Note: we don't need to restore the base context info till the end. */
1362 switch (CxTYPE(cx)) {
1365 continue; /* not break */
1384 PERL_UNUSED_VAR(optype);
1388 Perl_qerror(pTHX_ SV *err)
1391 sv_catsv(ERRSV, err);
1393 sv_catsv(PL_errors, err);
1395 Perl_warn(aTHX_ "%"SVf, err);
1400 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1409 if (PL_in_eval & EVAL_KEEPERR) {
1410 static const char prefix[] = "\t(in cleanup) ";
1411 SV * const err = ERRSV;
1412 const char *e = Nullch;
1414 sv_setpvn(err,"",0);
1415 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1417 e = SvPV_const(err, len);
1419 if (*e != *message || strNE(e,message))
1423 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1424 sv_catpvn(err, prefix, sizeof(prefix)-1);
1425 sv_catpvn(err, message, msglen);
1426 if (ckWARN(WARN_MISC)) {
1427 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1428 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1433 sv_setpvn(ERRSV, message, msglen);
1437 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1438 && PL_curstackinfo->si_prev)
1446 register PERL_CONTEXT *cx;
1449 if (cxix < cxstack_ix)
1452 POPBLOCK(cx,PL_curpm);
1453 if (CxTYPE(cx) != CXt_EVAL) {
1455 message = SvPVx_const(ERRSV, msglen);
1456 PerlIO_write(Perl_error_log, "panic: die ", 11);
1457 PerlIO_write(Perl_error_log, message, msglen);
1462 if (gimme == G_SCALAR)
1463 *++newsp = &PL_sv_undef;
1464 PL_stack_sp = newsp;
1468 /* LEAVE could clobber PL_curcop (see save_re_context())
1469 * XXX it might be better to find a way to avoid messing with
1470 * PL_curcop in save_re_context() instead, but this is a more
1471 * minimal fix --GSAR */
1472 PL_curcop = cx->blk_oldcop;
1474 if (optype == OP_REQUIRE) {
1475 const char* msg = SvPVx_nolen_const(ERRSV);
1476 SV * const nsv = cx->blk_eval.old_namesv;
1477 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1479 DIE(aTHX_ "%sCompilation failed in require",
1480 *msg ? msg : "Unknown error\n");
1482 assert(CxTYPE(cx) == CXt_EVAL);
1483 return cx->blk_eval.retop;
1487 message = SvPVx_const(ERRSV, msglen);
1489 write_to_stderr(message, msglen);
1498 if (SvTRUE(left) != SvTRUE(right))
1510 RETURNOP(cLOGOP->op_other);
1519 RETURNOP(cLOGOP->op_other);
1528 if (!sv || !SvANY(sv)) {
1529 RETURNOP(cLOGOP->op_other);
1532 switch (SvTYPE(sv)) {
1534 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1538 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1542 if (CvROOT(sv) || CvXSUB(sv))
1552 RETURNOP(cLOGOP->op_other);
1558 register I32 cxix = dopoptosub(cxstack_ix);
1559 register const PERL_CONTEXT *cx;
1560 register const PERL_CONTEXT *ccstack = cxstack;
1561 const PERL_SI *top_si = PL_curstackinfo;
1563 const char *stashname;
1570 /* we may be in a higher stacklevel, so dig down deeper */
1571 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1572 top_si = top_si->si_prev;
1573 ccstack = top_si->si_cxstack;
1574 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1577 if (GIMME != G_ARRAY) {
1583 /* caller() should not report the automatic calls to &DB::sub */
1584 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1585 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1589 cxix = dopoptosub_at(ccstack, cxix - 1);
1592 cx = &ccstack[cxix];
1593 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1594 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1595 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1596 field below is defined for any cx. */
1597 /* caller() should not report the automatic calls to &DB::sub */
1598 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1599 cx = &ccstack[dbcxix];
1602 stashname = CopSTASHPV(cx->blk_oldcop);
1603 if (GIMME != G_ARRAY) {
1606 PUSHs(&PL_sv_undef);
1609 sv_setpv(TARG, stashname);
1618 PUSHs(&PL_sv_undef);
1620 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1621 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1622 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1625 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1626 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1627 /* So is ccstack[dbcxix]. */
1629 SV * const sv = NEWSV(49, 0);
1630 gv_efullname3(sv, cvgv, Nullch);
1631 PUSHs(sv_2mortal(sv));
1632 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1635 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1636 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1640 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1641 PUSHs(sv_2mortal(newSViv(0)));
1643 gimme = (I32)cx->blk_gimme;
1644 if (gimme == G_VOID)
1645 PUSHs(&PL_sv_undef);
1647 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1648 if (CxTYPE(cx) == CXt_EVAL) {
1650 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1651 PUSHs(cx->blk_eval.cur_text);
1655 else if (cx->blk_eval.old_namesv) {
1656 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1659 /* eval BLOCK (try blocks have old_namesv == 0) */
1661 PUSHs(&PL_sv_undef);
1662 PUSHs(&PL_sv_undef);
1666 PUSHs(&PL_sv_undef);
1667 PUSHs(&PL_sv_undef);
1669 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1670 && CopSTASH_eq(PL_curcop, PL_debstash))
1672 AV * const ary = cx->blk_sub.argarray;
1673 const int off = AvARRAY(ary) - AvALLOC(ary);
1677 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1680 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1683 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1684 av_extend(PL_dbargs, AvFILLp(ary) + off);
1685 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1686 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1688 /* XXX only hints propagated via op_private are currently
1689 * visible (others are not easily accessible, since they
1690 * use the global PL_hints) */
1691 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1692 HINT_PRIVATE_MASK)));
1695 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1697 if (old_warnings == pWARN_NONE ||
1698 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1699 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1700 else if (old_warnings == pWARN_ALL ||
1701 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1702 /* Get the bit mask for $warnings::Bits{all}, because
1703 * it could have been extended by warnings::register */
1705 HV *bits = get_hv("warnings::Bits", FALSE);
1706 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1707 mask = newSVsv(*bits_all);
1710 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1714 mask = newSVsv(old_warnings);
1715 PUSHs(sv_2mortal(mask));
1729 sv_reset(tmps, CopSTASH(PL_curcop));
1739 /* like pp_nextstate, but used instead when the debugger is active */
1744 PL_curcop = (COP*)PL_op;
1745 TAINT_NOT; /* Each statement is presumed innocent */
1746 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1749 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1750 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1754 register PERL_CONTEXT *cx;
1755 const I32 gimme = G_ARRAY;
1762 DIE(aTHX_ "No DB::DB routine defined");
1764 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1765 /* don't do recursive DB::DB call */
1777 PUSHBLOCK(cx, CXt_SUB, SP);
1779 cx->blk_sub.retop = PL_op->op_next;
1782 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1783 RETURNOP(CvSTART(cv));
1797 register PERL_CONTEXT *cx;
1798 const I32 gimme = GIMME_V;
1800 U32 cxtype = CXt_LOOP;
1808 if (PL_op->op_targ) {
1809 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1810 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1811 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1812 SVs_PADSTALE, SVs_PADSTALE);
1814 #ifndef USE_ITHREADS
1815 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1818 SAVEPADSV(PL_op->op_targ);
1819 iterdata = INT2PTR(void*, PL_op->op_targ);
1820 cxtype |= CXp_PADVAR;
1825 svp = &GvSV(gv); /* symbol table variable */
1826 SAVEGENERICSV(*svp);
1829 iterdata = (void*)gv;
1835 PUSHBLOCK(cx, cxtype, SP);
1837 PUSHLOOP(cx, iterdata, MARK);
1839 PUSHLOOP(cx, svp, MARK);
1841 if (PL_op->op_flags & OPf_STACKED) {
1842 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1843 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1845 SV *right = (SV*)cx->blk_loop.iterary;
1846 if (RANGE_IS_NUMERIC(sv,right)) {
1847 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1848 (SvOK(right) && SvNV(right) >= IV_MAX))
1849 DIE(aTHX_ "Range iterator outside integer range");
1850 cx->blk_loop.iterix = SvIV(sv);
1851 cx->blk_loop.itermax = SvIV(right);
1853 /* for correct -Dstv display */
1854 cx->blk_oldsp = sp - PL_stack_base;
1858 cx->blk_loop.iterlval = newSVsv(sv);
1859 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1860 (void) SvPV_nolen_const(right);
1863 else if (PL_op->op_private & OPpITER_REVERSED) {
1864 cx->blk_loop.itermax = -1;
1865 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1870 cx->blk_loop.iterary = PL_curstack;
1871 AvFILLp(PL_curstack) = SP - PL_stack_base;
1872 if (PL_op->op_private & OPpITER_REVERSED) {
1873 cx->blk_loop.itermax = MARK - PL_stack_base;
1874 cx->blk_loop.iterix = cx->blk_oldsp;
1877 cx->blk_loop.iterix = MARK - PL_stack_base;
1887 register PERL_CONTEXT *cx;
1888 const I32 gimme = GIMME_V;
1894 PUSHBLOCK(cx, CXt_LOOP, SP);
1895 PUSHLOOP(cx, 0, SP);
1903 register PERL_CONTEXT *cx;
1910 assert(CxTYPE(cx) == CXt_LOOP);
1912 newsp = PL_stack_base + cx->blk_loop.resetsp;
1915 if (gimme == G_VOID)
1917 else if (gimme == G_SCALAR) {
1919 *++newsp = sv_mortalcopy(*SP);
1921 *++newsp = &PL_sv_undef;
1925 *++newsp = sv_mortalcopy(*++mark);
1926 TAINT_NOT; /* Each item is independent */
1932 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1933 PL_curpm = newpm; /* ... and pop $1 et al */
1945 register PERL_CONTEXT *cx;
1946 bool popsub2 = FALSE;
1947 bool clear_errsv = FALSE;
1955 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1956 if (cxstack_ix == PL_sortcxix
1957 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1959 if (cxstack_ix > PL_sortcxix)
1960 dounwind(PL_sortcxix);
1961 AvARRAY(PL_curstack)[1] = *SP;
1962 PL_stack_sp = PL_stack_base + 1;
1967 cxix = dopoptosub(cxstack_ix);
1969 DIE(aTHX_ "Can't return outside a subroutine");
1970 if (cxix < cxstack_ix)
1974 switch (CxTYPE(cx)) {
1977 retop = cx->blk_sub.retop;
1978 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1981 if (!(PL_in_eval & EVAL_KEEPERR))
1984 retop = cx->blk_eval.retop;
1988 if (optype == OP_REQUIRE &&
1989 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1991 /* Unassume the success we assumed earlier. */
1992 SV * const nsv = cx->blk_eval.old_namesv;
1993 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1994 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1999 retop = cx->blk_sub.retop;
2002 DIE(aTHX_ "panic: return");
2006 if (gimme == G_SCALAR) {
2009 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2011 *++newsp = SvREFCNT_inc(*SP);
2016 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2018 *++newsp = sv_mortalcopy(sv);
2023 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2026 *++newsp = sv_mortalcopy(*SP);
2029 *++newsp = &PL_sv_undef;
2031 else if (gimme == G_ARRAY) {
2032 while (++MARK <= SP) {
2033 *++newsp = (popsub2 && SvTEMP(*MARK))
2034 ? *MARK : sv_mortalcopy(*MARK);
2035 TAINT_NOT; /* Each item is independent */
2038 PL_stack_sp = newsp;
2041 /* Stack values are safe: */
2044 POPSUB(cx,sv); /* release CV and @_ ... */
2048 PL_curpm = newpm; /* ... and pop $1 et al */
2052 sv_setpvn(ERRSV,"",0);
2060 register PERL_CONTEXT *cx;
2071 if (PL_op->op_flags & OPf_SPECIAL) {
2072 cxix = dopoptoloop(cxstack_ix);
2074 DIE(aTHX_ "Can't \"last\" outside a loop block");
2077 cxix = dopoptolabel(cPVOP->op_pv);
2079 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2081 if (cxix < cxstack_ix)
2085 cxstack_ix++; /* temporarily protect top context */
2087 switch (CxTYPE(cx)) {
2090 newsp = PL_stack_base + cx->blk_loop.resetsp;
2091 nextop = cx->blk_loop.last_op->op_next;
2095 nextop = cx->blk_sub.retop;
2099 nextop = cx->blk_eval.retop;
2103 nextop = cx->blk_sub.retop;
2106 DIE(aTHX_ "panic: last");
2110 if (gimme == G_SCALAR) {
2112 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2113 ? *SP : sv_mortalcopy(*SP);
2115 *++newsp = &PL_sv_undef;
2117 else if (gimme == G_ARRAY) {
2118 while (++MARK <= SP) {
2119 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2120 ? *MARK : sv_mortalcopy(*MARK);
2121 TAINT_NOT; /* Each item is independent */
2129 /* Stack values are safe: */
2132 POPLOOP(cx); /* release loop vars ... */
2136 POPSUB(cx,sv); /* release CV and @_ ... */
2139 PL_curpm = newpm; /* ... and pop $1 et al */
2142 PERL_UNUSED_VAR(optype);
2143 PERL_UNUSED_VAR(gimme);
2151 register PERL_CONTEXT *cx;
2154 if (PL_op->op_flags & OPf_SPECIAL) {
2155 cxix = dopoptoloop(cxstack_ix);
2157 DIE(aTHX_ "Can't \"next\" outside a loop block");
2160 cxix = dopoptolabel(cPVOP->op_pv);
2162 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2164 if (cxix < cxstack_ix)
2167 /* clear off anything above the scope we're re-entering, but
2168 * save the rest until after a possible continue block */
2169 inner = PL_scopestack_ix;
2171 if (PL_scopestack_ix < inner)
2172 leave_scope(PL_scopestack[PL_scopestack_ix]);
2173 PL_curcop = cx->blk_oldcop;
2174 return cx->blk_loop.next_op;
2181 register PERL_CONTEXT *cx;
2185 if (PL_op->op_flags & OPf_SPECIAL) {
2186 cxix = dopoptoloop(cxstack_ix);
2188 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2191 cxix = dopoptolabel(cPVOP->op_pv);
2193 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2195 if (cxix < cxstack_ix)
2198 redo_op = cxstack[cxix].blk_loop.redo_op;
2199 if (redo_op->op_type == OP_ENTER) {
2200 /* pop one less context to avoid $x being freed in while (my $x..) */
2202 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2203 redo_op = redo_op->op_next;
2207 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2208 LEAVE_SCOPE(oldsave);
2210 PL_curcop = cx->blk_oldcop;
2215 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2218 static const char too_deep[] = "Target of goto is too deeply nested";
2221 Perl_croak(aTHX_ too_deep);
2222 if (o->op_type == OP_LEAVE ||
2223 o->op_type == OP_SCOPE ||
2224 o->op_type == OP_LEAVELOOP ||
2225 o->op_type == OP_LEAVESUB ||
2226 o->op_type == OP_LEAVETRY)
2228 *ops++ = cUNOPo->op_first;
2230 Perl_croak(aTHX_ too_deep);
2233 if (o->op_flags & OPf_KIDS) {
2235 /* First try all the kids at this level, since that's likeliest. */
2236 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2237 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2238 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2241 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2242 if (kid == PL_lastgotoprobe)
2244 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2247 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2248 ops[-1]->op_type == OP_DBSTATE)
2253 if ((o = dofindlabel(kid, label, ops, oplimit)))
2272 register PERL_CONTEXT *cx;
2273 #define GOTO_DEPTH 64
2274 OP *enterops[GOTO_DEPTH];
2275 const char *label = 0;
2276 const bool do_dump = (PL_op->op_type == OP_DUMP);
2277 static const char must_have_label[] = "goto must have label";
2279 if (PL_op->op_flags & OPf_STACKED) {
2280 SV * const sv = POPs;
2282 /* This egregious kludge implements goto &subroutine */
2283 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2285 register PERL_CONTEXT *cx;
2286 CV* cv = (CV*)SvRV(sv);
2293 if (!CvROOT(cv) && !CvXSUB(cv)) {
2294 const GV * const gv = CvGV(cv);
2298 /* autoloaded stub? */
2299 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2301 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2302 GvNAMELEN(gv), FALSE);
2303 if (autogv && (cv = GvCV(autogv)))
2305 tmpstr = sv_newmortal();
2306 gv_efullname3(tmpstr, gv, Nullch);
2307 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2309 DIE(aTHX_ "Goto undefined subroutine");
2312 /* First do some returnish stuff. */
2313 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2315 cxix = dopoptosub(cxstack_ix);
2317 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2318 if (cxix < cxstack_ix)
2322 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2323 if (CxTYPE(cx) == CXt_EVAL) {
2325 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2327 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2329 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2330 /* put @_ back onto stack */
2331 AV* av = cx->blk_sub.argarray;
2333 items = AvFILLp(av) + 1;
2334 EXTEND(SP, items+1); /* @_ could have been extended. */
2335 Copy(AvARRAY(av), SP + 1, items, SV*);
2336 SvREFCNT_dec(GvAV(PL_defgv));
2337 GvAV(PL_defgv) = cx->blk_sub.savearray;
2339 /* abandon @_ if it got reified */
2344 av_extend(av, items-1);
2346 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2349 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2350 AV* const av = GvAV(PL_defgv);
2351 items = AvFILLp(av) + 1;
2352 EXTEND(SP, items+1); /* @_ could have been extended. */
2353 Copy(AvARRAY(av), SP + 1, items, SV*);
2357 if (CxTYPE(cx) == CXt_SUB &&
2358 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2359 SvREFCNT_dec(cx->blk_sub.cv);
2360 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2361 LEAVE_SCOPE(oldsave);
2363 /* Now do some callish stuff. */
2365 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2367 OP* retop = cx->blk_sub.retop;
2370 for (index=0; index<items; index++)
2371 sv_2mortal(SP[-index]);
2373 #ifdef PERL_XSUB_OLDSTYLE
2374 if (CvOLDSTYLE(cv)) {
2375 I32 (*fp3)(int,int,int);
2380 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2381 items = (*fp3)(CvXSUBANY(cv).any_i32,
2382 mark - PL_stack_base + 1,
2384 SP = PL_stack_base + items;
2387 #endif /* PERL_XSUB_OLDSTYLE */
2392 /* XS subs don't have a CxSUB, so pop it */
2393 POPBLOCK(cx, PL_curpm);
2394 /* Push a mark for the start of arglist */
2397 (void)(*CvXSUB(cv))(aTHX_ cv);
2398 /* Put these at the bottom since the vars are set but not used */
2399 PERL_UNUSED_VAR(newsp);
2400 PERL_UNUSED_VAR(gimme);
2406 AV* padlist = CvPADLIST(cv);
2407 if (CxTYPE(cx) == CXt_EVAL) {
2408 PL_in_eval = cx->blk_eval.old_in_eval;
2409 PL_eval_root = cx->blk_eval.old_eval_root;
2410 cx->cx_type = CXt_SUB;
2411 cx->blk_sub.hasargs = 0;
2413 cx->blk_sub.cv = cv;
2414 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2417 if (CvDEPTH(cv) < 2)
2418 (void)SvREFCNT_inc(cv);
2420 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2421 sub_crush_depth(cv);
2422 pad_push(padlist, CvDEPTH(cv));
2425 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2426 if (cx->blk_sub.hasargs)
2428 AV* av = (AV*)PAD_SVl(0);
2431 cx->blk_sub.savearray = GvAV(PL_defgv);
2432 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2433 CX_CURPAD_SAVE(cx->blk_sub);
2434 cx->blk_sub.argarray = av;
2436 if (items >= AvMAX(av) + 1) {
2438 if (AvARRAY(av) != ary) {
2439 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2440 SvPV_set(av, (char*)ary);
2442 if (items >= AvMAX(av) + 1) {
2443 AvMAX(av) = items - 1;
2444 Renew(ary,items+1,SV*);
2446 SvPV_set(av, (char*)ary);
2450 Copy(mark,AvARRAY(av),items,SV*);
2451 AvFILLp(av) = items - 1;
2452 assert(!AvREAL(av));
2454 /* transfer 'ownership' of refcnts to new @_ */
2464 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2466 * We do not care about using sv to call CV;
2467 * it's for informational purposes only.
2469 SV * const sv = GvSV(PL_DBsub);
2473 if (PERLDB_SUB_NN) {
2474 const int type = SvTYPE(sv);
2475 if (type < SVt_PVIV && type != SVt_IV)
2476 sv_upgrade(sv, SVt_PVIV);
2478 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2480 gv_efullname3(sv, CvGV(cv), Nullch);
2483 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2484 PUSHMARK( PL_stack_sp );
2485 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2489 RETURNOP(CvSTART(cv));
2493 label = SvPV_nolen_const(sv);
2494 if (!(do_dump || *label))
2495 DIE(aTHX_ must_have_label);
2498 else if (PL_op->op_flags & OPf_SPECIAL) {
2500 DIE(aTHX_ must_have_label);
2503 label = cPVOP->op_pv;
2505 if (label && *label) {
2507 bool leaving_eval = FALSE;
2508 bool in_block = FALSE;
2509 PERL_CONTEXT *last_eval_cx = 0;
2513 PL_lastgotoprobe = 0;
2515 for (ix = cxstack_ix; ix >= 0; ix--) {
2517 switch (CxTYPE(cx)) {
2519 leaving_eval = TRUE;
2520 if (!CxTRYBLOCK(cx)) {
2521 gotoprobe = (last_eval_cx ?
2522 last_eval_cx->blk_eval.old_eval_root :
2527 /* else fall through */
2529 gotoprobe = cx->blk_oldcop->op_sibling;
2535 gotoprobe = cx->blk_oldcop->op_sibling;
2538 gotoprobe = PL_main_root;
2541 if (CvDEPTH(cx->blk_sub.cv)) {
2542 gotoprobe = CvROOT(cx->blk_sub.cv);
2548 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2551 DIE(aTHX_ "panic: goto");
2552 gotoprobe = PL_main_root;
2556 retop = dofindlabel(gotoprobe, label,
2557 enterops, enterops + GOTO_DEPTH);
2561 PL_lastgotoprobe = gotoprobe;
2564 DIE(aTHX_ "Can't find label %s", label);
2566 /* if we're leaving an eval, check before we pop any frames
2567 that we're not going to punt, otherwise the error
2570 if (leaving_eval && *enterops && enterops[1]) {
2572 for (i = 1; enterops[i]; i++)
2573 if (enterops[i]->op_type == OP_ENTERITER)
2574 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2577 /* pop unwanted frames */
2579 if (ix < cxstack_ix) {
2586 oldsave = PL_scopestack[PL_scopestack_ix];
2587 LEAVE_SCOPE(oldsave);
2590 /* push wanted frames */
2592 if (*enterops && enterops[1]) {
2594 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2595 for (; enterops[ix]; ix++) {
2596 PL_op = enterops[ix];
2597 /* Eventually we may want to stack the needed arguments
2598 * for each op. For now, we punt on the hard ones. */
2599 if (PL_op->op_type == OP_ENTERITER)
2600 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2601 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2609 if (!retop) retop = PL_main_start;
2611 PL_restartop = retop;
2612 PL_do_undump = TRUE;
2616 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2617 PL_do_undump = FALSE;
2633 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2635 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2638 PL_exit_flags |= PERL_EXIT_EXPECTED;
2640 PUSHs(&PL_sv_undef);
2648 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2649 register I32 match = I_32(value);
2652 if (((NV)match) > value)
2653 --match; /* was fractional--truncate other way */
2655 match -= cCOP->uop.scop.scop_offset;
2658 else if (match > cCOP->uop.scop.scop_max)
2659 match = cCOP->uop.scop.scop_max;
2660 PL_op = cCOP->uop.scop.scop_next[match];
2670 PL_op = PL_op->op_next; /* can't assume anything */
2672 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2673 match -= cCOP->uop.scop.scop_offset;
2676 else if (match > cCOP->uop.scop.scop_max)
2677 match = cCOP->uop.scop.scop_max;
2678 PL_op = cCOP->uop.scop.scop_next[match];
2687 S_save_lines(pTHX_ AV *array, SV *sv)
2689 const char *s = SvPVX_const(sv);
2690 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2693 while (s && s < send) {
2695 SV * const tmpstr = NEWSV(85,0);
2697 sv_upgrade(tmpstr, SVt_PVMG);
2698 t = strchr(s, '\n');
2704 sv_setpvn(tmpstr, s, t - s);
2705 av_store(array, line++, tmpstr);
2711 S_docatch_body(pTHX)
2718 S_docatch(pTHX_ OP *o)
2721 OP * const oldop = PL_op;
2725 assert(CATCH_GET == TRUE);
2732 assert(cxstack_ix >= 0);
2733 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2734 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2739 /* die caught by an inner eval - continue inner loop */
2741 /* NB XXX we rely on the old popped CxEVAL still being at the top
2742 * of the stack; the way die_where() currently works, this
2743 * assumption is valid. In theory The cur_top_env value should be
2744 * returned in another global, the way retop (aka PL_restartop)
2746 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2749 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2751 PL_op = PL_restartop;
2768 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2769 /* sv Text to convert to OP tree. */
2770 /* startop op_free() this to undo. */
2771 /* code Short string id of the caller. */
2773 dVAR; dSP; /* Make POPBLOCK work. */
2780 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2781 char *tmpbuf = tbuf;
2784 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2789 /* switch to eval mode */
2791 if (IN_PERL_COMPILETIME) {
2792 SAVECOPSTASH_FREE(&PL_compiling);
2793 CopSTASH_set(&PL_compiling, PL_curstash);
2795 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2796 SV * const sv = sv_newmortal();
2797 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2798 code, (unsigned long)++PL_evalseq,
2799 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2803 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2804 SAVECOPFILE_FREE(&PL_compiling);
2805 CopFILE_set(&PL_compiling, tmpbuf+2);
2806 SAVECOPLINE(&PL_compiling);
2807 CopLINE_set(&PL_compiling, 1);
2808 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2809 deleting the eval's FILEGV from the stash before gv_check() runs
2810 (i.e. before run-time proper). To work around the coredump that
2811 ensues, we always turn GvMULTI_on for any globals that were
2812 introduced within evals. See force_ident(). GSAR 96-10-12 */
2813 safestr = savepv(tmpbuf);
2814 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2816 #ifdef OP_IN_REGISTER
2822 /* we get here either during compilation, or via pp_regcomp at runtime */
2823 runtime = IN_PERL_RUNTIME;
2825 runcv = find_runcv(NULL);
2828 PL_op->op_type = OP_ENTEREVAL;
2829 PL_op->op_flags = 0; /* Avoid uninit warning. */
2830 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2831 PUSHEVAL(cx, 0, Nullgv);
2834 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2836 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2837 POPBLOCK(cx,PL_curpm);
2840 (*startop)->op_type = OP_NULL;
2841 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2843 /* XXX DAPM do this properly one year */
2844 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2846 if (IN_PERL_COMPILETIME)
2847 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2848 #ifdef OP_IN_REGISTER
2851 PERL_UNUSED_VAR(newsp);
2852 PERL_UNUSED_VAR(optype);
2859 =for apidoc find_runcv
2861 Locate the CV corresponding to the currently executing sub or eval.
2862 If db_seqp is non_null, skip CVs that are in the DB package and populate
2863 *db_seqp with the cop sequence number at the point that the DB:: code was
2864 entered. (allows debuggers to eval in the scope of the breakpoint rather
2865 than in in the scope of the debugger itself).
2871 Perl_find_runcv(pTHX_ U32 *db_seqp)
2876 *db_seqp = PL_curcop->cop_seq;
2877 for (si = PL_curstackinfo; si; si = si->si_prev) {
2879 for (ix = si->si_cxix; ix >= 0; ix--) {
2880 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2881 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2882 CV * const cv = cx->blk_sub.cv;
2883 /* skip DB:: code */
2884 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2885 *db_seqp = cx->blk_oldcop->cop_seq;
2890 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2898 /* Compile a require/do, an eval '', or a /(?{...})/.
2899 * In the last case, startop is non-null, and contains the address of
2900 * a pointer that should be set to the just-compiled code.
2901 * outside is the lexically enclosing CV (if any) that invoked us.
2904 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2906 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2909 OP * const saveop = PL_op;
2911 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2912 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2917 SAVESPTR(PL_compcv);
2918 PL_compcv = (CV*)NEWSV(1104,0);
2919 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2920 CvEVAL_on(PL_compcv);
2921 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2922 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2924 CvOUTSIDE_SEQ(PL_compcv) = seq;
2925 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2927 /* set up a scratch pad */
2929 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2932 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2934 /* make sure we compile in the right package */
2936 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2937 SAVESPTR(PL_curstash);
2938 PL_curstash = CopSTASH(PL_curcop);
2940 SAVESPTR(PL_beginav);
2941 PL_beginav = newAV();
2942 SAVEFREESV(PL_beginav);
2943 SAVEI32(PL_error_count);
2945 /* try to compile it */
2947 PL_eval_root = Nullop;
2949 PL_curcop = &PL_compiling;
2950 PL_curcop->cop_arybase = 0;
2951 if (saveop && saveop->op_flags & OPf_SPECIAL)
2952 PL_in_eval |= EVAL_KEEPERR;
2954 sv_setpvn(ERRSV,"",0);
2955 if (yyparse() || PL_error_count || !PL_eval_root) {
2956 SV **newsp; /* Used by POPBLOCK. */
2957 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2958 I32 optype = 0; /* Might be reset by POPEVAL. */
2963 op_free(PL_eval_root);
2964 PL_eval_root = Nullop;
2966 SP = PL_stack_base + POPMARK; /* pop original mark */
2968 POPBLOCK(cx,PL_curpm);
2974 msg = SvPVx_nolen_const(ERRSV);
2975 if (optype == OP_REQUIRE) {
2976 const SV * const nsv = cx->blk_eval.old_namesv;
2977 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2979 DIE(aTHX_ "%sCompilation failed in require",
2980 *msg ? msg : "Unknown error\n");
2983 POPBLOCK(cx,PL_curpm);
2985 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2986 (*msg ? msg : "Unknown error\n"));
2990 sv_setpv(ERRSV, "Compilation error");
2993 PERL_UNUSED_VAR(newsp);
2996 CopLINE_set(&PL_compiling, 0);
2998 *startop = PL_eval_root;
3000 SAVEFREEOP(PL_eval_root);
3002 /* Set the context for this new optree.
3003 * If the last op is an OP_REQUIRE, force scalar context.
3004 * Otherwise, propagate the context from the eval(). */
3005 if (PL_eval_root->op_type == OP_LEAVEEVAL
3006 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3007 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3009 scalar(PL_eval_root);
3010 else if (gimme & G_VOID)
3011 scalarvoid(PL_eval_root);
3012 else if (gimme & G_ARRAY)
3015 scalar(PL_eval_root);
3017 DEBUG_x(dump_eval());
3019 /* Register with debugger: */
3020 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3021 CV * const cv = get_cv("DB::postponed", FALSE);
3025 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3027 call_sv((SV*)cv, G_DISCARD);
3031 /* compiled okay, so do it */
3033 CvDEPTH(PL_compcv) = 1;
3034 SP = PL_stack_base + POPMARK; /* pop original mark */
3035 PL_op = saveop; /* The caller may need it. */
3036 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3038 RETURNOP(PL_eval_start);
3042 S_doopen_pm(pTHX_ const char *name, const char *mode)
3044 #ifndef PERL_DISABLE_PMC
3045 const STRLEN namelen = strlen(name);
3048 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3049 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3050 const char * const pmc = SvPV_nolen_const(pmcsv);
3052 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3053 fp = PerlIO_open(name, mode);
3057 if (PerlLIO_stat(name, &pmstat) < 0 ||
3058 pmstat.st_mtime < pmcstat.st_mtime)
3060 fp = PerlIO_open(pmc, mode);
3063 fp = PerlIO_open(name, mode);
3066 SvREFCNT_dec(pmcsv);
3069 fp = PerlIO_open(name, mode);
3073 return PerlIO_open(name, mode);
3074 #endif /* !PERL_DISABLE_PMC */
3080 register PERL_CONTEXT *cx;
3084 const char *tryname = Nullch;
3085 SV *namesv = Nullsv;
3087 const I32 gimme = GIMME_V;
3088 PerlIO *tryrsfp = 0;
3089 int filter_has_file = 0;
3090 GV *filter_child_proc = 0;
3091 SV *filter_state = 0;
3098 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3099 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3100 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3101 "v-string in use/require non-portable");
3103 sv = new_version(sv);
3104 if (!sv_derived_from(PL_patchlevel, "version"))
3105 (void *)upg_version(PL_patchlevel);
3106 if ( vcmp(sv,PL_patchlevel) > 0 )
3107 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3108 vnormal(sv), vnormal(PL_patchlevel));
3112 name = SvPV_const(sv, len);
3113 if (!(name && len > 0 && *name))
3114 DIE(aTHX_ "Null filename used");
3115 TAINT_PROPER("require");
3116 if (PL_op->op_type == OP_REQUIRE &&
3117 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3118 if (*svp != &PL_sv_undef)
3121 DIE(aTHX_ "Compilation failed in require");
3124 /* prepare to compile file */
3126 if (path_is_absolute(name)) {
3128 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3130 #ifdef MACOS_TRADITIONAL
3134 MacPerl_CanonDir(name, newname, 1);
3135 if (path_is_absolute(newname)) {
3137 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3142 AV *ar = GvAVn(PL_incgv);
3146 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3149 namesv = NEWSV(806, 0);
3150 for (i = 0; i <= AvFILL(ar); i++) {
3151 SV *dirsv = *av_fetch(ar, i, TRUE);
3157 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3158 && !sv_isobject(loader))
3160 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3163 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3164 PTR2UV(SvRV(dirsv)), name);
3165 tryname = SvPVX_const(namesv);
3176 if (sv_isobject(loader))
3177 count = call_method("INC", G_ARRAY);
3179 count = call_sv(loader, G_ARRAY);
3189 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3193 if (SvTYPE(arg) == SVt_PVGV) {
3194 IO *io = GvIO((GV *)arg);
3199 tryrsfp = IoIFP(io);
3200 if (IoTYPE(io) == IoTYPE_PIPE) {
3201 /* reading from a child process doesn't
3202 nest -- when returning from reading
3203 the inner module, the outer one is
3204 unreadable (closed?) I've tried to
3205 save the gv to manage the lifespan of
3206 the pipe, but this didn't help. XXX */
3207 filter_child_proc = (GV *)arg;
3208 (void)SvREFCNT_inc(filter_child_proc);
3211 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3212 PerlIO_close(IoOFP(io));
3224 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3226 (void)SvREFCNT_inc(filter_sub);
3229 filter_state = SP[i];
3230 (void)SvREFCNT_inc(filter_state);
3234 tryrsfp = PerlIO_open("/dev/null",
3250 filter_has_file = 0;
3251 if (filter_child_proc) {
3252 SvREFCNT_dec(filter_child_proc);
3253 filter_child_proc = 0;
3256 SvREFCNT_dec(filter_state);
3260 SvREFCNT_dec(filter_sub);
3265 if (!path_is_absolute(name)
3266 #ifdef MACOS_TRADITIONAL
3267 /* We consider paths of the form :a:b ambiguous and interpret them first
3268 as global then as local
3270 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3273 const char *dir = SvPVx_nolen_const(dirsv);
3274 #ifdef MACOS_TRADITIONAL
3278 MacPerl_CanonDir(name, buf2, 1);
3279 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3283 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3285 sv_setpv(namesv, unixdir);
3286 sv_catpv(namesv, unixname);
3289 if (PL_origfilename[0] &&
3290 PL_origfilename[1] == ':' &&
3291 !(dir[0] && dir[1] == ':'))
3292 Perl_sv_setpvf(aTHX_ namesv,
3297 Perl_sv_setpvf(aTHX_ namesv,
3301 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3305 TAINT_PROPER("require");
3306 tryname = SvPVX_const(namesv);
3307 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3309 if (tryname[0] == '.' && tryname[1] == '/')
3318 SAVECOPFILE_FREE(&PL_compiling);
3319 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3320 SvREFCNT_dec(namesv);
3322 if (PL_op->op_type == OP_REQUIRE) {
3323 const char *msgstr = name;
3324 if (namesv) { /* did we lookup @INC? */
3325 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3326 SV *dirmsgsv = NEWSV(0, 0);
3327 AV *ar = GvAVn(PL_incgv);
3329 sv_catpvn(msg, " in @INC", 8);
3330 if (instr(SvPVX_const(msg), ".h "))
3331 sv_catpv(msg, " (change .h to .ph maybe?)");
3332 if (instr(SvPVX_const(msg), ".ph "))
3333 sv_catpv(msg, " (did you run h2ph?)");
3334 sv_catpv(msg, " (@INC contains:");
3335 for (i = 0; i <= AvFILL(ar); i++) {
3336 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3337 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3338 sv_catsv(msg, dirmsgsv);
3340 sv_catpvn(msg, ")", 1);
3341 SvREFCNT_dec(dirmsgsv);
3342 msgstr = SvPV_nolen_const(msg);
3344 DIE(aTHX_ "Can't locate %s", msgstr);
3350 SETERRNO(0, SS_NORMAL);
3352 /* Assume success here to prevent recursive requirement. */
3354 /* Check whether a hook in @INC has already filled %INC */
3355 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3356 (void)hv_store(GvHVn(PL_incgv), name, len,
3357 (hook_sv ? SvREFCNT_inc(hook_sv)
3358 : newSVpv(CopFILE(&PL_compiling), 0)),
3364 lex_start(sv_2mortal(newSVpvn("",0)));
3365 SAVEGENERICSV(PL_rsfp_filters);
3366 PL_rsfp_filters = Nullav;
3371 SAVESPTR(PL_compiling.cop_warnings);
3372 if (PL_dowarn & G_WARN_ALL_ON)
3373 PL_compiling.cop_warnings = pWARN_ALL ;
3374 else if (PL_dowarn & G_WARN_ALL_OFF)
3375 PL_compiling.cop_warnings = pWARN_NONE ;
3376 else if (PL_taint_warn)
3377 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3379 PL_compiling.cop_warnings = pWARN_STD ;
3380 SAVESPTR(PL_compiling.cop_io);
3381 PL_compiling.cop_io = Nullsv;
3383 if (filter_sub || filter_child_proc) {
3384 SV * const datasv = filter_add(run_user_filter, Nullsv);
3385 IoLINES(datasv) = filter_has_file;
3386 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3387 IoTOP_GV(datasv) = (GV *)filter_state;
3388 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3391 /* switch to eval mode */
3392 PUSHBLOCK(cx, CXt_EVAL, SP);
3393 PUSHEVAL(cx, name, Nullgv);
3394 cx->blk_eval.retop = PL_op->op_next;
3396 SAVECOPLINE(&PL_compiling);
3397 CopLINE_set(&PL_compiling, 0);
3401 /* Store and reset encoding. */
3402 encoding = PL_encoding;
3403 PL_encoding = Nullsv;
3405 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3407 /* Restore encoding. */
3408 PL_encoding = encoding;
3415 return pp_require();
3421 register PERL_CONTEXT *cx;
3423 const I32 gimme = GIMME_V;
3424 const I32 was = PL_sub_generation;
3425 char tbuf[TYPE_DIGITS(long) + 12];
3426 char *tmpbuf = tbuf;
3433 if (!SvPV_const(sv,len))
3435 TAINT_PROPER("eval");
3441 /* switch to eval mode */
3443 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3444 SV * const sv = sv_newmortal();
3445 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3446 (unsigned long)++PL_evalseq,
3447 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3451 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3452 SAVECOPFILE_FREE(&PL_compiling);
3453 CopFILE_set(&PL_compiling, tmpbuf+2);
3454 SAVECOPLINE(&PL_compiling);
3455 CopLINE_set(&PL_compiling, 1);
3456 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3457 deleting the eval's FILEGV from the stash before gv_check() runs
3458 (i.e. before run-time proper). To work around the coredump that
3459 ensues, we always turn GvMULTI_on for any globals that were
3460 introduced within evals. See force_ident(). GSAR 96-10-12 */
3461 safestr = savepv(tmpbuf);
3462 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3464 PL_hints = PL_op->op_targ;
3465 SAVESPTR(PL_compiling.cop_warnings);
3466 if (specialWARN(PL_curcop->cop_warnings))
3467 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3469 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3470 SAVEFREESV(PL_compiling.cop_warnings);
3472 SAVESPTR(PL_compiling.cop_io);
3473 if (specialCopIO(PL_curcop->cop_io))
3474 PL_compiling.cop_io = PL_curcop->cop_io;
3476 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3477 SAVEFREESV(PL_compiling.cop_io);
3479 /* special case: an eval '' executed within the DB package gets lexically
3480 * placed in the first non-DB CV rather than the current CV - this
3481 * allows the debugger to execute code, find lexicals etc, in the
3482 * scope of the code being debugged. Passing &seq gets find_runcv
3483 * to do the dirty work for us */
3484 runcv = find_runcv(&seq);
3486 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3487 PUSHEVAL(cx, 0, Nullgv);
3488 cx->blk_eval.retop = PL_op->op_next;
3490 /* prepare to compile string */
3492 if (PERLDB_LINE && PL_curstash != PL_debstash)
3493 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3495 ret = doeval(gimme, NULL, runcv, seq);
3496 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3497 && ret != PL_op->op_next) { /* Successive compilation. */
3498 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3500 return DOCATCH(ret);
3510 register PERL_CONTEXT *cx;
3512 const U8 save_flags = PL_op -> op_flags;
3517 retop = cx->blk_eval.retop;
3520 if (gimme == G_VOID)
3522 else if (gimme == G_SCALAR) {
3525 if (SvFLAGS(TOPs) & SVs_TEMP)
3528 *MARK = sv_mortalcopy(TOPs);
3532 *MARK = &PL_sv_undef;
3537 /* in case LEAVE wipes old return values */
3538 for (mark = newsp + 1; mark <= SP; mark++) {
3539 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3540 *mark = sv_mortalcopy(*mark);
3541 TAINT_NOT; /* Each item is independent */
3545 PL_curpm = newpm; /* Don't pop $1 et al till now */
3548 assert(CvDEPTH(PL_compcv) == 1);
3550 CvDEPTH(PL_compcv) = 0;
3553 if (optype == OP_REQUIRE &&
3554 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3556 /* Unassume the success we assumed earlier. */
3557 SV * const nsv = cx->blk_eval.old_namesv;
3558 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3559 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3560 /* die_where() did LEAVE, or we won't be here */
3564 if (!(save_flags & OPf_SPECIAL))
3565 sv_setpvn(ERRSV,"",0);
3574 register PERL_CONTEXT *cx;
3575 const I32 gimme = GIMME_V;
3580 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3582 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3584 PL_in_eval = EVAL_INEVAL;
3585 sv_setpvn(ERRSV,"",0);
3587 return DOCATCH(PL_op->op_next);
3597 register PERL_CONTEXT *cx;
3602 PERL_UNUSED_VAR(optype);
3605 if (gimme == G_VOID)
3607 else if (gimme == G_SCALAR) {
3610 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3613 *MARK = sv_mortalcopy(TOPs);
3617 *MARK = &PL_sv_undef;
3622 /* in case LEAVE wipes old return values */
3623 for (mark = newsp + 1; mark <= SP; mark++) {
3624 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3625 *mark = sv_mortalcopy(*mark);
3626 TAINT_NOT; /* Each item is independent */
3630 PL_curpm = newpm; /* Don't pop $1 et al till now */
3633 sv_setpvn(ERRSV,"",0);
3638 S_doparseform(pTHX_ SV *sv)
3641 register char *s = SvPV_force(sv, len);
3642 register char *send = s + len;
3643 register char *base = Nullch;
3644 register I32 skipspaces = 0;
3645 bool noblank = FALSE;
3646 bool repeat = FALSE;
3647 bool postspace = FALSE;
3653 bool unchopnum = FALSE;
3654 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3657 Perl_croak(aTHX_ "Null picture in formline");
3659 /* estimate the buffer size needed */
3660 for (base = s; s <= send; s++) {
3661 if (*s == '\n' || *s == '@' || *s == '^')
3667 Newx(fops, maxops, U32);
3672 *fpc++ = FF_LINEMARK;
3673 noblank = repeat = FALSE;
3691 case ' ': case '\t':
3698 } /* else FALL THROUGH */
3706 *fpc++ = FF_LITERAL;
3714 *fpc++ = (U16)skipspaces;
3718 *fpc++ = FF_NEWLINE;
3722 arg = fpc - linepc + 1;
3729 *fpc++ = FF_LINEMARK;
3730 noblank = repeat = FALSE;
3739 ischop = s[-1] == '^';
3745 arg = (s - base) - 1;
3747 *fpc++ = FF_LITERAL;
3755 *fpc++ = 2; /* skip the @* or ^* */
3757 *fpc++ = FF_LINESNGL;
3760 *fpc++ = FF_LINEGLOB;
3762 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3763 arg = ischop ? 512 : 0;
3768 const char * const f = ++s;
3771 arg |= 256 + (s - f);
3773 *fpc++ = s - base; /* fieldsize for FETCH */
3774 *fpc++ = FF_DECIMAL;
3776 unchopnum |= ! ischop;
3778 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3779 arg = ischop ? 512 : 0;
3781 s++; /* skip the '0' first */
3785 const char * const f = ++s;
3788 arg |= 256 + (s - f);
3790 *fpc++ = s - base; /* fieldsize for FETCH */
3791 *fpc++ = FF_0DECIMAL;
3793 unchopnum |= ! ischop;
3797 bool ismore = FALSE;
3800 while (*++s == '>') ;
3801 prespace = FF_SPACE;
3803 else if (*s == '|') {
3804 while (*++s == '|') ;
3805 prespace = FF_HALFSPACE;
3810 while (*++s == '<') ;
3813 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3817 *fpc++ = s - base; /* fieldsize for FETCH */
3819 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3822 *fpc++ = (U16)prespace;
3836 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3838 { /* need to jump to the next word */
3840 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3841 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3842 s = SvPVX(sv) + SvCUR(sv) + z;
3844 Copy(fops, s, arg, U32);
3846 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3849 if (unchopnum && repeat)
3850 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3856 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3858 /* Can value be printed in fldsize chars, using %*.*f ? */
3862 int intsize = fldsize - (value < 0 ? 1 : 0);
3869 while (intsize--) pwr *= 10.0;
3870 while (frcsize--) eps /= 10.0;
3873 if (value + eps >= pwr)
3876 if (value - eps <= -pwr)
3883 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3886 SV *datasv = FILTER_DATA(idx);
3887 const int filter_has_file = IoLINES(datasv);
3888 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3889 SV *filter_state = (SV *)IoTOP_GV(datasv);
3890 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3893 /* I was having segfault trouble under Linux 2.2.5 after a
3894 parse error occured. (Had to hack around it with a test
3895 for PL_error_count == 0.) Solaris doesn't segfault --
3896 not sure where the trouble is yet. XXX */
3898 if (filter_has_file) {
3899 len = FILTER_READ(idx+1, buf_sv, maxlen);
3902 if (filter_sub && len >= 0) {
3913 PUSHs(sv_2mortal(newSViv(maxlen)));
3915 PUSHs(filter_state);
3918 count = call_sv(filter_sub, G_SCALAR);
3934 IoLINES(datasv) = 0;
3935 if (filter_child_proc) {
3936 SvREFCNT_dec(filter_child_proc);
3937 IoFMT_GV(datasv) = Nullgv;
3940 SvREFCNT_dec(filter_state);
3941 IoTOP_GV(datasv) = Nullgv;
3944 SvREFCNT_dec(filter_sub);
3945 IoBOTTOM_GV(datasv) = Nullgv;
3947 filter_del(run_user_filter);
3953 /* perhaps someone can come up with a better name for
3954 this? it is not really "absolute", per se ... */
3956 S_path_is_absolute(pTHX_ const char *name)
3958 if (PERL_FILE_IS_ABSOLUTE(name)
3959 #ifdef MACOS_TRADITIONAL
3962 || (*name == '.' && (name[1] == '/' ||
3963 (name[1] == '.' && name[2] == '/'))))
3974 * c-indentation-style: bsd
3976 * indent-tabs-mode: t
3979 * ex: set ts=8 sts=4 sw=4 noet: