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) {
1132 if (RANGE_IS_NUMERIC(left,right)) {
1135 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1136 (SvOK(right) && SvNV(right) > IV_MAX))
1137 DIE(aTHX_ "Range iterator outside integer range");
1148 SV * const sv = sv_2mortal(newSViv(i++));
1153 SV *final = sv_mortalcopy(right);
1155 const char *tmps = SvPV_const(final, len);
1157 SV *sv = sv_mortalcopy(left);
1158 SvPV_force_nolen(sv);
1159 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1161 if (strEQ(SvPVX_const(sv),tmps))
1163 sv = sv_2mortal(newSVsv(sv));
1170 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1174 if (PL_op->op_private & OPpFLIP_LINENUM) {
1175 if (GvIO(PL_last_in_gv)) {
1176 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1179 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1180 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1188 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1189 sv_catpvn(targ, "E0", 2);
1199 static const char * const context_name[] = {
1210 S_dopoptolabel(pTHX_ const char *label)
1214 for (i = cxstack_ix; i >= 0; i--) {
1215 register const PERL_CONTEXT * const cx = &cxstack[i];
1216 switch (CxTYPE(cx)) {
1222 if (ckWARN(WARN_EXITING))
1223 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1224 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1225 if (CxTYPE(cx) == CXt_NULL)
1229 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1230 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1231 (long)i, cx->blk_loop.label));
1234 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1242 Perl_dowantarray(pTHX)
1244 const I32 gimme = block_gimme();
1245 return (gimme == G_VOID) ? G_SCALAR : gimme;
1249 Perl_block_gimme(pTHX)
1251 const I32 cxix = dopoptosub(cxstack_ix);
1255 switch (cxstack[cxix].blk_gimme) {
1263 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1270 Perl_is_lvalue_sub(pTHX)
1272 const I32 cxix = dopoptosub(cxstack_ix);
1273 assert(cxix >= 0); /* We should only be called from inside subs */
1275 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1276 return cxstack[cxix].blk_sub.lval;
1282 S_dopoptosub(pTHX_ I32 startingblock)
1284 return dopoptosub_at(cxstack, startingblock);
1288 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1291 for (i = startingblock; i >= 0; i--) {
1292 register const PERL_CONTEXT * const cx = &cxstk[i];
1293 switch (CxTYPE(cx)) {
1299 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1307 S_dopoptoeval(pTHX_ I32 startingblock)
1310 for (i = startingblock; i >= 0; i--) {
1311 register const PERL_CONTEXT *cx = &cxstack[i];
1312 switch (CxTYPE(cx)) {
1316 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1324 S_dopoptoloop(pTHX_ I32 startingblock)
1327 for (i = startingblock; i >= 0; i--) {
1328 register const PERL_CONTEXT * const cx = &cxstack[i];
1329 switch (CxTYPE(cx)) {
1335 if (ckWARN(WARN_EXITING))
1336 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1337 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1338 if ((CxTYPE(cx)) == CXt_NULL)
1342 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1350 Perl_dounwind(pTHX_ I32 cxix)
1354 while (cxstack_ix > cxix) {
1356 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1357 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1358 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1359 /* Note: we don't need to restore the base context info till the end. */
1360 switch (CxTYPE(cx)) {
1363 continue; /* not break */
1382 PERL_UNUSED_VAR(optype);
1386 Perl_qerror(pTHX_ SV *err)
1389 sv_catsv(ERRSV, err);
1391 sv_catsv(PL_errors, err);
1393 Perl_warn(aTHX_ "%"SVf, err);
1398 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1407 if (PL_in_eval & EVAL_KEEPERR) {
1408 static const char prefix[] = "\t(in cleanup) ";
1409 SV * const err = ERRSV;
1410 const char *e = Nullch;
1412 sv_setpvn(err,"",0);
1413 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1415 e = SvPV_const(err, len);
1417 if (*e != *message || strNE(e,message))
1421 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1422 sv_catpvn(err, prefix, sizeof(prefix)-1);
1423 sv_catpvn(err, message, msglen);
1424 if (ckWARN(WARN_MISC)) {
1425 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1426 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1431 sv_setpvn(ERRSV, message, msglen);
1435 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1436 && PL_curstackinfo->si_prev)
1444 register PERL_CONTEXT *cx;
1447 if (cxix < cxstack_ix)
1450 POPBLOCK(cx,PL_curpm);
1451 if (CxTYPE(cx) != CXt_EVAL) {
1453 message = SvPVx_const(ERRSV, msglen);
1454 PerlIO_write(Perl_error_log, "panic: die ", 11);
1455 PerlIO_write(Perl_error_log, message, msglen);
1460 if (gimme == G_SCALAR)
1461 *++newsp = &PL_sv_undef;
1462 PL_stack_sp = newsp;
1466 /* LEAVE could clobber PL_curcop (see save_re_context())
1467 * XXX it might be better to find a way to avoid messing with
1468 * PL_curcop in save_re_context() instead, but this is a more
1469 * minimal fix --GSAR */
1470 PL_curcop = cx->blk_oldcop;
1472 if (optype == OP_REQUIRE) {
1473 const char* msg = SvPVx_nolen_const(ERRSV);
1474 SV * const nsv = cx->blk_eval.old_namesv;
1475 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1477 DIE(aTHX_ "%sCompilation failed in require",
1478 *msg ? msg : "Unknown error\n");
1480 assert(CxTYPE(cx) == CXt_EVAL);
1481 return cx->blk_eval.retop;
1485 message = SvPVx_const(ERRSV, msglen);
1487 write_to_stderr(message, msglen);
1496 if (SvTRUE(left) != SvTRUE(right))
1508 RETURNOP(cLOGOP->op_other);
1517 RETURNOP(cLOGOP->op_other);
1526 if (!sv || !SvANY(sv)) {
1527 RETURNOP(cLOGOP->op_other);
1530 switch (SvTYPE(sv)) {
1532 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1536 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1540 if (CvROOT(sv) || CvXSUB(sv))
1549 RETURNOP(cLOGOP->op_other);
1555 register I32 cxix = dopoptosub(cxstack_ix);
1556 register const PERL_CONTEXT *cx;
1557 register const PERL_CONTEXT *ccstack = cxstack;
1558 const PERL_SI *top_si = PL_curstackinfo;
1560 const char *stashname;
1567 /* we may be in a higher stacklevel, so dig down deeper */
1568 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1569 top_si = top_si->si_prev;
1570 ccstack = top_si->si_cxstack;
1571 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1574 if (GIMME != G_ARRAY) {
1580 /* caller() should not report the automatic calls to &DB::sub */
1581 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1582 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1586 cxix = dopoptosub_at(ccstack, cxix - 1);
1589 cx = &ccstack[cxix];
1590 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1591 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1592 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1593 field below is defined for any cx. */
1594 /* caller() should not report the automatic calls to &DB::sub */
1595 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1596 cx = &ccstack[dbcxix];
1599 stashname = CopSTASHPV(cx->blk_oldcop);
1600 if (GIMME != G_ARRAY) {
1603 PUSHs(&PL_sv_undef);
1606 sv_setpv(TARG, stashname);
1615 PUSHs(&PL_sv_undef);
1617 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1618 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1619 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1622 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1623 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1624 /* So is ccstack[dbcxix]. */
1626 SV * const sv = NEWSV(49, 0);
1627 gv_efullname3(sv, cvgv, Nullch);
1628 PUSHs(sv_2mortal(sv));
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1632 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1633 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1637 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1638 PUSHs(sv_2mortal(newSViv(0)));
1640 gimme = (I32)cx->blk_gimme;
1641 if (gimme == G_VOID)
1642 PUSHs(&PL_sv_undef);
1644 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1645 if (CxTYPE(cx) == CXt_EVAL) {
1647 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1648 PUSHs(cx->blk_eval.cur_text);
1652 else if (cx->blk_eval.old_namesv) {
1653 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1656 /* eval BLOCK (try blocks have old_namesv == 0) */
1658 PUSHs(&PL_sv_undef);
1659 PUSHs(&PL_sv_undef);
1663 PUSHs(&PL_sv_undef);
1664 PUSHs(&PL_sv_undef);
1666 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1667 && CopSTASH_eq(PL_curcop, PL_debstash))
1669 AV * const ary = cx->blk_sub.argarray;
1670 const int off = AvARRAY(ary) - AvALLOC(ary);
1674 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1677 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1680 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1681 av_extend(PL_dbargs, AvFILLp(ary) + off);
1682 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1683 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1685 /* XXX only hints propagated via op_private are currently
1686 * visible (others are not easily accessible, since they
1687 * use the global PL_hints) */
1688 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1689 HINT_PRIVATE_MASK)));
1692 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1694 if (old_warnings == pWARN_NONE ||
1695 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1696 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1697 else if (old_warnings == pWARN_ALL ||
1698 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1699 /* Get the bit mask for $warnings::Bits{all}, because
1700 * it could have been extended by warnings::register */
1702 HV *bits = get_hv("warnings::Bits", FALSE);
1703 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1704 mask = newSVsv(*bits_all);
1707 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1711 mask = newSVsv(old_warnings);
1712 PUSHs(sv_2mortal(mask));
1726 sv_reset(tmps, CopSTASH(PL_curcop));
1736 /* like pp_nextstate, but used instead when the debugger is active */
1741 PL_curcop = (COP*)PL_op;
1742 TAINT_NOT; /* Each statement is presumed innocent */
1743 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1746 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1747 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1751 register PERL_CONTEXT *cx;
1752 const I32 gimme = G_ARRAY;
1759 DIE(aTHX_ "No DB::DB routine defined");
1761 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1762 /* don't do recursive DB::DB call */
1777 (void)(*CvXSUB(cv))(aTHX_ cv);
1784 PUSHBLOCK(cx, CXt_SUB, SP);
1786 cx->blk_sub.retop = PL_op->op_next;
1789 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1790 RETURNOP(CvSTART(cv));
1805 register PERL_CONTEXT *cx;
1806 const I32 gimme = GIMME_V;
1808 U32 cxtype = CXt_LOOP;
1816 if (PL_op->op_targ) {
1817 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1818 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1819 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1820 SVs_PADSTALE, SVs_PADSTALE);
1822 #ifndef USE_ITHREADS
1823 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1826 SAVEPADSV(PL_op->op_targ);
1827 iterdata = INT2PTR(void*, PL_op->op_targ);
1828 cxtype |= CXp_PADVAR;
1833 svp = &GvSV(gv); /* symbol table variable */
1834 SAVEGENERICSV(*svp);
1837 iterdata = (void*)gv;
1843 PUSHBLOCK(cx, cxtype, SP);
1845 PUSHLOOP(cx, iterdata, MARK);
1847 PUSHLOOP(cx, svp, MARK);
1849 if (PL_op->op_flags & OPf_STACKED) {
1850 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1851 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1853 SV *right = (SV*)cx->blk_loop.iterary;
1856 if (RANGE_IS_NUMERIC(sv,right)) {
1857 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1858 (SvOK(right) && SvNV(right) >= IV_MAX))
1859 DIE(aTHX_ "Range iterator outside integer range");
1860 cx->blk_loop.iterix = SvIV(sv);
1861 cx->blk_loop.itermax = SvIV(right);
1863 /* for correct -Dstv display */
1864 cx->blk_oldsp = sp - PL_stack_base;
1868 cx->blk_loop.iterlval = newSVsv(sv);
1869 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1870 (void) SvPV_nolen_const(right);
1873 else if (PL_op->op_private & OPpITER_REVERSED) {
1874 cx->blk_loop.itermax = -1;
1875 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1880 cx->blk_loop.iterary = PL_curstack;
1881 AvFILLp(PL_curstack) = SP - PL_stack_base;
1882 if (PL_op->op_private & OPpITER_REVERSED) {
1883 cx->blk_loop.itermax = MARK - PL_stack_base;
1884 cx->blk_loop.iterix = cx->blk_oldsp;
1887 cx->blk_loop.iterix = MARK - PL_stack_base;
1897 register PERL_CONTEXT *cx;
1898 const I32 gimme = GIMME_V;
1904 PUSHBLOCK(cx, CXt_LOOP, SP);
1905 PUSHLOOP(cx, 0, SP);
1913 register PERL_CONTEXT *cx;
1920 assert(CxTYPE(cx) == CXt_LOOP);
1922 newsp = PL_stack_base + cx->blk_loop.resetsp;
1925 if (gimme == G_VOID)
1927 else if (gimme == G_SCALAR) {
1929 *++newsp = sv_mortalcopy(*SP);
1931 *++newsp = &PL_sv_undef;
1935 *++newsp = sv_mortalcopy(*++mark);
1936 TAINT_NOT; /* Each item is independent */
1942 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1943 PL_curpm = newpm; /* ... and pop $1 et al */
1955 register PERL_CONTEXT *cx;
1956 bool popsub2 = FALSE;
1957 bool clear_errsv = FALSE;
1965 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1966 if (cxstack_ix == PL_sortcxix
1967 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1969 if (cxstack_ix > PL_sortcxix)
1970 dounwind(PL_sortcxix);
1971 AvARRAY(PL_curstack)[1] = *SP;
1972 PL_stack_sp = PL_stack_base + 1;
1977 cxix = dopoptosub(cxstack_ix);
1979 DIE(aTHX_ "Can't return outside a subroutine");
1980 if (cxix < cxstack_ix)
1984 switch (CxTYPE(cx)) {
1987 retop = cx->blk_sub.retop;
1988 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1991 if (!(PL_in_eval & EVAL_KEEPERR))
1994 retop = cx->blk_eval.retop;
1998 if (optype == OP_REQUIRE &&
1999 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2001 /* Unassume the success we assumed earlier. */
2002 SV * const nsv = cx->blk_eval.old_namesv;
2003 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2004 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2009 retop = cx->blk_sub.retop;
2012 DIE(aTHX_ "panic: return");
2016 if (gimme == G_SCALAR) {
2019 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2021 *++newsp = SvREFCNT_inc(*SP);
2026 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2028 *++newsp = sv_mortalcopy(sv);
2033 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2036 *++newsp = sv_mortalcopy(*SP);
2039 *++newsp = &PL_sv_undef;
2041 else if (gimme == G_ARRAY) {
2042 while (++MARK <= SP) {
2043 *++newsp = (popsub2 && SvTEMP(*MARK))
2044 ? *MARK : sv_mortalcopy(*MARK);
2045 TAINT_NOT; /* Each item is independent */
2048 PL_stack_sp = newsp;
2051 /* Stack values are safe: */
2054 POPSUB(cx,sv); /* release CV and @_ ... */
2058 PL_curpm = newpm; /* ... and pop $1 et al */
2062 sv_setpvn(ERRSV,"",0);
2070 register PERL_CONTEXT *cx;
2081 if (PL_op->op_flags & OPf_SPECIAL) {
2082 cxix = dopoptoloop(cxstack_ix);
2084 DIE(aTHX_ "Can't \"last\" outside a loop block");
2087 cxix = dopoptolabel(cPVOP->op_pv);
2089 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2091 if (cxix < cxstack_ix)
2095 cxstack_ix++; /* temporarily protect top context */
2097 switch (CxTYPE(cx)) {
2100 newsp = PL_stack_base + cx->blk_loop.resetsp;
2101 nextop = cx->blk_loop.last_op->op_next;
2105 nextop = cx->blk_sub.retop;
2109 nextop = cx->blk_eval.retop;
2113 nextop = cx->blk_sub.retop;
2116 DIE(aTHX_ "panic: last");
2120 if (gimme == G_SCALAR) {
2122 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2123 ? *SP : sv_mortalcopy(*SP);
2125 *++newsp = &PL_sv_undef;
2127 else if (gimme == G_ARRAY) {
2128 while (++MARK <= SP) {
2129 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2130 ? *MARK : sv_mortalcopy(*MARK);
2131 TAINT_NOT; /* Each item is independent */
2139 /* Stack values are safe: */
2142 POPLOOP(cx); /* release loop vars ... */
2146 POPSUB(cx,sv); /* release CV and @_ ... */
2149 PL_curpm = newpm; /* ... and pop $1 et al */
2152 PERL_UNUSED_VAR(optype);
2153 PERL_UNUSED_VAR(gimme);
2161 register PERL_CONTEXT *cx;
2164 if (PL_op->op_flags & OPf_SPECIAL) {
2165 cxix = dopoptoloop(cxstack_ix);
2167 DIE(aTHX_ "Can't \"next\" outside a loop block");
2170 cxix = dopoptolabel(cPVOP->op_pv);
2172 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2174 if (cxix < cxstack_ix)
2177 /* clear off anything above the scope we're re-entering, but
2178 * save the rest until after a possible continue block */
2179 inner = PL_scopestack_ix;
2181 if (PL_scopestack_ix < inner)
2182 leave_scope(PL_scopestack[PL_scopestack_ix]);
2183 PL_curcop = cx->blk_oldcop;
2184 return cx->blk_loop.next_op;
2191 register PERL_CONTEXT *cx;
2195 if (PL_op->op_flags & OPf_SPECIAL) {
2196 cxix = dopoptoloop(cxstack_ix);
2198 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2201 cxix = dopoptolabel(cPVOP->op_pv);
2203 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2205 if (cxix < cxstack_ix)
2208 redo_op = cxstack[cxix].blk_loop.redo_op;
2209 if (redo_op->op_type == OP_ENTER) {
2210 /* pop one less context to avoid $x being freed in while (my $x..) */
2212 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2213 redo_op = redo_op->op_next;
2217 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2218 LEAVE_SCOPE(oldsave);
2220 PL_curcop = cx->blk_oldcop;
2225 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2228 static const char too_deep[] = "Target of goto is too deeply nested";
2231 Perl_croak(aTHX_ too_deep);
2232 if (o->op_type == OP_LEAVE ||
2233 o->op_type == OP_SCOPE ||
2234 o->op_type == OP_LEAVELOOP ||
2235 o->op_type == OP_LEAVESUB ||
2236 o->op_type == OP_LEAVETRY)
2238 *ops++ = cUNOPo->op_first;
2240 Perl_croak(aTHX_ too_deep);
2243 if (o->op_flags & OPf_KIDS) {
2245 /* First try all the kids at this level, since that's likeliest. */
2246 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2247 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2248 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2251 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2252 if (kid == PL_lastgotoprobe)
2254 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2257 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2258 ops[-1]->op_type == OP_DBSTATE)
2263 if ((o = dofindlabel(kid, label, ops, oplimit)))
2282 register PERL_CONTEXT *cx;
2283 #define GOTO_DEPTH 64
2284 OP *enterops[GOTO_DEPTH];
2285 const char *label = 0;
2286 const bool do_dump = (PL_op->op_type == OP_DUMP);
2287 static const char must_have_label[] = "goto must have label";
2289 if (PL_op->op_flags & OPf_STACKED) {
2290 SV * const sv = POPs;
2292 /* This egregious kludge implements goto &subroutine */
2293 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2295 register PERL_CONTEXT *cx;
2296 CV* cv = (CV*)SvRV(sv);
2303 if (!CvROOT(cv) && !CvXSUB(cv)) {
2304 const GV * const gv = CvGV(cv);
2308 /* autoloaded stub? */
2309 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2311 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2312 GvNAMELEN(gv), FALSE);
2313 if (autogv && (cv = GvCV(autogv)))
2315 tmpstr = sv_newmortal();
2316 gv_efullname3(tmpstr, gv, Nullch);
2317 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2319 DIE(aTHX_ "Goto undefined subroutine");
2322 /* First do some returnish stuff. */
2323 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2325 cxix = dopoptosub(cxstack_ix);
2327 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2328 if (cxix < cxstack_ix)
2332 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2333 if (CxTYPE(cx) == CXt_EVAL) {
2335 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2337 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2339 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2340 /* put @_ back onto stack */
2341 AV* av = cx->blk_sub.argarray;
2343 items = AvFILLp(av) + 1;
2344 EXTEND(SP, items+1); /* @_ could have been extended. */
2345 Copy(AvARRAY(av), SP + 1, items, SV*);
2346 SvREFCNT_dec(GvAV(PL_defgv));
2347 GvAV(PL_defgv) = cx->blk_sub.savearray;
2349 /* abandon @_ if it got reified */
2354 av_extend(av, items-1);
2356 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2359 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2360 AV* const av = GvAV(PL_defgv);
2361 items = AvFILLp(av) + 1;
2362 EXTEND(SP, items+1); /* @_ could have been extended. */
2363 Copy(AvARRAY(av), SP + 1, items, SV*);
2367 if (CxTYPE(cx) == CXt_SUB &&
2368 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2369 SvREFCNT_dec(cx->blk_sub.cv);
2370 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2371 LEAVE_SCOPE(oldsave);
2373 /* Now do some callish stuff. */
2375 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2377 OP* retop = cx->blk_sub.retop;
2380 for (index=0; index<items; index++)
2381 sv_2mortal(SP[-index]);
2383 #ifdef PERL_XSUB_OLDSTYLE
2384 if (CvOLDSTYLE(cv)) {
2385 I32 (*fp3)(int,int,int);
2390 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2391 items = (*fp3)(CvXSUBANY(cv).any_i32,
2392 mark - PL_stack_base + 1,
2394 SP = PL_stack_base + items;
2397 #endif /* PERL_XSUB_OLDSTYLE */
2402 /* XS subs don't have a CxSUB, so pop it */
2403 POPBLOCK(cx, PL_curpm);
2404 /* Push a mark for the start of arglist */
2407 (void)(*CvXSUB(cv))(aTHX_ cv);
2408 /* Put these at the bottom since the vars are set but not used */
2409 PERL_UNUSED_VAR(newsp);
2410 PERL_UNUSED_VAR(gimme);
2416 AV* padlist = CvPADLIST(cv);
2417 if (CxTYPE(cx) == CXt_EVAL) {
2418 PL_in_eval = cx->blk_eval.old_in_eval;
2419 PL_eval_root = cx->blk_eval.old_eval_root;
2420 cx->cx_type = CXt_SUB;
2421 cx->blk_sub.hasargs = 0;
2423 cx->blk_sub.cv = cv;
2424 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2427 if (CvDEPTH(cv) < 2)
2428 (void)SvREFCNT_inc(cv);
2430 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2431 sub_crush_depth(cv);
2432 pad_push(padlist, CvDEPTH(cv));
2435 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2436 if (cx->blk_sub.hasargs)
2438 AV* av = (AV*)PAD_SVl(0);
2441 cx->blk_sub.savearray = GvAV(PL_defgv);
2442 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2443 CX_CURPAD_SAVE(cx->blk_sub);
2444 cx->blk_sub.argarray = av;
2446 if (items >= AvMAX(av) + 1) {
2448 if (AvARRAY(av) != ary) {
2449 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2450 SvPV_set(av, (char*)ary);
2452 if (items >= AvMAX(av) + 1) {
2453 AvMAX(av) = items - 1;
2454 Renew(ary,items+1,SV*);
2456 SvPV_set(av, (char*)ary);
2460 Copy(mark,AvARRAY(av),items,SV*);
2461 AvFILLp(av) = items - 1;
2462 assert(!AvREAL(av));
2464 /* transfer 'ownership' of refcnts to new @_ */
2474 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2476 * We do not care about using sv to call CV;
2477 * it's for informational purposes only.
2479 SV * const sv = GvSV(PL_DBsub);
2483 if (PERLDB_SUB_NN) {
2484 const int type = SvTYPE(sv);
2485 if (type < SVt_PVIV && type != SVt_IV)
2486 sv_upgrade(sv, SVt_PVIV);
2488 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2490 gv_efullname3(sv, CvGV(cv), Nullch);
2493 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2494 PUSHMARK( PL_stack_sp );
2495 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2499 RETURNOP(CvSTART(cv));
2503 label = SvPV_nolen_const(sv);
2504 if (!(do_dump || *label))
2505 DIE(aTHX_ must_have_label);
2508 else if (PL_op->op_flags & OPf_SPECIAL) {
2510 DIE(aTHX_ must_have_label);
2513 label = cPVOP->op_pv;
2515 if (label && *label) {
2517 bool leaving_eval = FALSE;
2518 bool in_block = FALSE;
2519 PERL_CONTEXT *last_eval_cx = 0;
2523 PL_lastgotoprobe = 0;
2525 for (ix = cxstack_ix; ix >= 0; ix--) {
2527 switch (CxTYPE(cx)) {
2529 leaving_eval = TRUE;
2530 if (!CxTRYBLOCK(cx)) {
2531 gotoprobe = (last_eval_cx ?
2532 last_eval_cx->blk_eval.old_eval_root :
2537 /* else fall through */
2539 gotoprobe = cx->blk_oldcop->op_sibling;
2545 gotoprobe = cx->blk_oldcop->op_sibling;
2548 gotoprobe = PL_main_root;
2551 if (CvDEPTH(cx->blk_sub.cv)) {
2552 gotoprobe = CvROOT(cx->blk_sub.cv);
2558 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2561 DIE(aTHX_ "panic: goto");
2562 gotoprobe = PL_main_root;
2566 retop = dofindlabel(gotoprobe, label,
2567 enterops, enterops + GOTO_DEPTH);
2571 PL_lastgotoprobe = gotoprobe;
2574 DIE(aTHX_ "Can't find label %s", label);
2576 /* if we're leaving an eval, check before we pop any frames
2577 that we're not going to punt, otherwise the error
2580 if (leaving_eval && *enterops && enterops[1]) {
2582 for (i = 1; enterops[i]; i++)
2583 if (enterops[i]->op_type == OP_ENTERITER)
2584 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2587 /* pop unwanted frames */
2589 if (ix < cxstack_ix) {
2596 oldsave = PL_scopestack[PL_scopestack_ix];
2597 LEAVE_SCOPE(oldsave);
2600 /* push wanted frames */
2602 if (*enterops && enterops[1]) {
2604 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2605 for (; enterops[ix]; ix++) {
2606 PL_op = enterops[ix];
2607 /* Eventually we may want to stack the needed arguments
2608 * for each op. For now, we punt on the hard ones. */
2609 if (PL_op->op_type == OP_ENTERITER)
2610 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2611 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2619 if (!retop) retop = PL_main_start;
2621 PL_restartop = retop;
2622 PL_do_undump = TRUE;
2626 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2627 PL_do_undump = FALSE;
2643 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2645 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2648 PL_exit_flags |= PERL_EXIT_EXPECTED;
2650 PUSHs(&PL_sv_undef);
2658 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2659 register I32 match = I_32(value);
2662 if (((NV)match) > value)
2663 --match; /* was fractional--truncate other way */
2665 match -= cCOP->uop.scop.scop_offset;
2668 else if (match > cCOP->uop.scop.scop_max)
2669 match = cCOP->uop.scop.scop_max;
2670 PL_op = cCOP->uop.scop.scop_next[match];
2680 PL_op = PL_op->op_next; /* can't assume anything */
2682 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2683 match -= cCOP->uop.scop.scop_offset;
2686 else if (match > cCOP->uop.scop.scop_max)
2687 match = cCOP->uop.scop.scop_max;
2688 PL_op = cCOP->uop.scop.scop_next[match];
2697 S_save_lines(pTHX_ AV *array, SV *sv)
2699 const char *s = SvPVX_const(sv);
2700 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2703 while (s && s < send) {
2705 SV * const tmpstr = NEWSV(85,0);
2707 sv_upgrade(tmpstr, SVt_PVMG);
2708 t = strchr(s, '\n');
2714 sv_setpvn(tmpstr, s, t - s);
2715 av_store(array, line++, tmpstr);
2721 S_docatch_body(pTHX)
2728 S_docatch(pTHX_ OP *o)
2731 OP * const oldop = PL_op;
2735 assert(CATCH_GET == TRUE);
2742 assert(cxstack_ix >= 0);
2743 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2744 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2749 /* die caught by an inner eval - continue inner loop */
2751 /* NB XXX we rely on the old popped CxEVAL still being at the top
2752 * of the stack; the way die_where() currently works, this
2753 * assumption is valid. In theory The cur_top_env value should be
2754 * returned in another global, the way retop (aka PL_restartop)
2756 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2759 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2761 PL_op = PL_restartop;
2778 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2779 /* sv Text to convert to OP tree. */
2780 /* startop op_free() this to undo. */
2781 /* code Short string id of the caller. */
2783 dVAR; dSP; /* Make POPBLOCK work. */
2790 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2791 char *tmpbuf = tbuf;
2794 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2799 /* switch to eval mode */
2801 if (IN_PERL_COMPILETIME) {
2802 SAVECOPSTASH_FREE(&PL_compiling);
2803 CopSTASH_set(&PL_compiling, PL_curstash);
2805 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2806 SV * const sv = sv_newmortal();
2807 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2808 code, (unsigned long)++PL_evalseq,
2809 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2813 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2814 SAVECOPFILE_FREE(&PL_compiling);
2815 CopFILE_set(&PL_compiling, tmpbuf+2);
2816 SAVECOPLINE(&PL_compiling);
2817 CopLINE_set(&PL_compiling, 1);
2818 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2819 deleting the eval's FILEGV from the stash before gv_check() runs
2820 (i.e. before run-time proper). To work around the coredump that
2821 ensues, we always turn GvMULTI_on for any globals that were
2822 introduced within evals. See force_ident(). GSAR 96-10-12 */
2823 safestr = savepv(tmpbuf);
2824 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2826 #ifdef OP_IN_REGISTER
2832 /* we get here either during compilation, or via pp_regcomp at runtime */
2833 runtime = IN_PERL_RUNTIME;
2835 runcv = find_runcv(NULL);
2838 PL_op->op_type = OP_ENTEREVAL;
2839 PL_op->op_flags = 0; /* Avoid uninit warning. */
2840 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2841 PUSHEVAL(cx, 0, Nullgv);
2844 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2846 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2847 POPBLOCK(cx,PL_curpm);
2850 (*startop)->op_type = OP_NULL;
2851 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2853 /* XXX DAPM do this properly one year */
2854 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2856 if (IN_PERL_COMPILETIME)
2857 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2858 #ifdef OP_IN_REGISTER
2861 PERL_UNUSED_VAR(newsp);
2862 PERL_UNUSED_VAR(optype);
2869 =for apidoc find_runcv
2871 Locate the CV corresponding to the currently executing sub or eval.
2872 If db_seqp is non_null, skip CVs that are in the DB package and populate
2873 *db_seqp with the cop sequence number at the point that the DB:: code was
2874 entered. (allows debuggers to eval in the scope of the breakpoint rather
2875 than in the scope of the debugger itself).
2881 Perl_find_runcv(pTHX_ U32 *db_seqp)
2886 *db_seqp = PL_curcop->cop_seq;
2887 for (si = PL_curstackinfo; si; si = si->si_prev) {
2889 for (ix = si->si_cxix; ix >= 0; ix--) {
2890 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2891 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2892 CV * const cv = cx->blk_sub.cv;
2893 /* skip DB:: code */
2894 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2895 *db_seqp = cx->blk_oldcop->cop_seq;
2900 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2908 /* Compile a require/do, an eval '', or a /(?{...})/.
2909 * In the last case, startop is non-null, and contains the address of
2910 * a pointer that should be set to the just-compiled code.
2911 * outside is the lexically enclosing CV (if any) that invoked us.
2914 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2916 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2919 OP * const saveop = PL_op;
2921 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2922 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2927 SAVESPTR(PL_compcv);
2928 PL_compcv = (CV*)NEWSV(1104,0);
2929 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2930 CvEVAL_on(PL_compcv);
2931 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2932 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2934 CvOUTSIDE_SEQ(PL_compcv) = seq;
2935 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2937 /* set up a scratch pad */
2939 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2942 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2944 /* make sure we compile in the right package */
2946 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2947 SAVESPTR(PL_curstash);
2948 PL_curstash = CopSTASH(PL_curcop);
2950 SAVESPTR(PL_beginav);
2951 PL_beginav = newAV();
2952 SAVEFREESV(PL_beginav);
2953 SAVEI32(PL_error_count);
2955 /* try to compile it */
2957 PL_eval_root = Nullop;
2959 PL_curcop = &PL_compiling;
2960 PL_curcop->cop_arybase = 0;
2961 if (saveop && saveop->op_flags & OPf_SPECIAL)
2962 PL_in_eval |= EVAL_KEEPERR;
2964 sv_setpvn(ERRSV,"",0);
2965 if (yyparse() || PL_error_count || !PL_eval_root) {
2966 SV **newsp; /* Used by POPBLOCK. */
2967 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2968 I32 optype = 0; /* Might be reset by POPEVAL. */
2973 op_free(PL_eval_root);
2974 PL_eval_root = Nullop;
2976 SP = PL_stack_base + POPMARK; /* pop original mark */
2978 POPBLOCK(cx,PL_curpm);
2984 msg = SvPVx_nolen_const(ERRSV);
2985 if (optype == OP_REQUIRE) {
2986 const SV * const nsv = cx->blk_eval.old_namesv;
2987 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2989 DIE(aTHX_ "%sCompilation failed in require",
2990 *msg ? msg : "Unknown error\n");
2993 POPBLOCK(cx,PL_curpm);
2995 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2996 (*msg ? msg : "Unknown error\n"));
3000 sv_setpv(ERRSV, "Compilation error");
3003 PERL_UNUSED_VAR(newsp);
3006 CopLINE_set(&PL_compiling, 0);
3008 *startop = PL_eval_root;
3010 SAVEFREEOP(PL_eval_root);
3012 /* Set the context for this new optree.
3013 * If the last op is an OP_REQUIRE, force scalar context.
3014 * Otherwise, propagate the context from the eval(). */
3015 if (PL_eval_root->op_type == OP_LEAVEEVAL
3016 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3017 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3019 scalar(PL_eval_root);
3020 else if (gimme & G_VOID)
3021 scalarvoid(PL_eval_root);
3022 else if (gimme & G_ARRAY)
3025 scalar(PL_eval_root);
3027 DEBUG_x(dump_eval());
3029 /* Register with debugger: */
3030 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3031 CV * const cv = get_cv("DB::postponed", FALSE);
3035 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3037 call_sv((SV*)cv, G_DISCARD);
3041 /* compiled okay, so do it */
3043 CvDEPTH(PL_compcv) = 1;
3044 SP = PL_stack_base + POPMARK; /* pop original mark */
3045 PL_op = saveop; /* The caller may need it. */
3046 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3048 RETURNOP(PL_eval_start);
3052 S_doopen_pm(pTHX_ const char *name, const char *mode)
3054 #ifndef PERL_DISABLE_PMC
3055 const STRLEN namelen = strlen(name);
3058 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3059 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3060 const char * const pmc = SvPV_nolen_const(pmcsv);
3062 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3063 fp = PerlIO_open(name, mode);
3067 if (PerlLIO_stat(name, &pmstat) < 0 ||
3068 pmstat.st_mtime < pmcstat.st_mtime)
3070 fp = PerlIO_open(pmc, mode);
3073 fp = PerlIO_open(name, mode);
3076 SvREFCNT_dec(pmcsv);
3079 fp = PerlIO_open(name, mode);
3083 return PerlIO_open(name, mode);
3084 #endif /* !PERL_DISABLE_PMC */
3090 register PERL_CONTEXT *cx;
3094 const char *tryname = Nullch;
3095 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_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 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3135 if (*svp != &PL_sv_undef)
3138 DIE(aTHX_ "Compilation failed in require");
3141 /* prepare to compile file */
3143 if (path_is_absolute(name)) {
3145 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3147 #ifdef MACOS_TRADITIONAL
3151 MacPerl_CanonDir(name, newname, 1);
3152 if (path_is_absolute(newname)) {
3154 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3159 AV *ar = GvAVn(PL_incgv);
3163 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3166 namesv = NEWSV(806, 0);
3167 for (i = 0; i <= AvFILL(ar); i++) {
3168 SV *dirsv = *av_fetch(ar, i, TRUE);
3174 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3175 && !sv_isobject(loader))
3177 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3180 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3181 PTR2UV(SvRV(dirsv)), name);
3182 tryname = SvPVX_const(namesv);
3193 if (sv_isobject(loader))
3194 count = call_method("INC", G_ARRAY);
3196 count = call_sv(loader, G_ARRAY);
3206 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3210 if (SvTYPE(arg) == SVt_PVGV) {
3211 IO *io = GvIO((GV *)arg);
3216 tryrsfp = IoIFP(io);
3217 if (IoTYPE(io) == IoTYPE_PIPE) {
3218 /* reading from a child process doesn't
3219 nest -- when returning from reading
3220 the inner module, the outer one is
3221 unreadable (closed?) I've tried to
3222 save the gv to manage the lifespan of
3223 the pipe, but this didn't help. XXX */
3224 filter_child_proc = (GV *)arg;
3225 (void)SvREFCNT_inc(filter_child_proc);
3228 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3229 PerlIO_close(IoOFP(io));
3241 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3243 (void)SvREFCNT_inc(filter_sub);
3246 filter_state = SP[i];
3247 (void)SvREFCNT_inc(filter_state);
3251 tryrsfp = PerlIO_open("/dev/null",
3267 filter_has_file = 0;
3268 if (filter_child_proc) {
3269 SvREFCNT_dec(filter_child_proc);
3270 filter_child_proc = 0;
3273 SvREFCNT_dec(filter_state);
3277 SvREFCNT_dec(filter_sub);
3282 if (!path_is_absolute(name)
3283 #ifdef MACOS_TRADITIONAL
3284 /* We consider paths of the form :a:b ambiguous and interpret them first
3285 as global then as local
3287 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3290 const char *dir = SvPVx_nolen_const(dirsv);
3291 #ifdef MACOS_TRADITIONAL
3295 MacPerl_CanonDir(name, buf2, 1);
3296 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3300 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3302 sv_setpv(namesv, unixdir);
3303 sv_catpv(namesv, unixname);
3306 if (PL_origfilename[0] &&
3307 PL_origfilename[1] == ':' &&
3308 !(dir[0] && dir[1] == ':'))
3309 Perl_sv_setpvf(aTHX_ namesv,
3314 Perl_sv_setpvf(aTHX_ namesv,
3318 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3322 TAINT_PROPER("require");
3323 tryname = SvPVX_const(namesv);
3324 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3326 if (tryname[0] == '.' && tryname[1] == '/')
3335 SAVECOPFILE_FREE(&PL_compiling);
3336 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3337 SvREFCNT_dec(namesv);
3339 if (PL_op->op_type == OP_REQUIRE) {
3340 const char *msgstr = name;
3341 if (namesv) { /* did we lookup @INC? */
3342 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3343 SV *dirmsgsv = NEWSV(0, 0);
3344 AV *ar = GvAVn(PL_incgv);
3346 sv_catpvn(msg, " in @INC", 8);
3347 if (instr(SvPVX_const(msg), ".h "))
3348 sv_catpv(msg, " (change .h to .ph maybe?)");
3349 if (instr(SvPVX_const(msg), ".ph "))
3350 sv_catpv(msg, " (did you run h2ph?)");
3351 sv_catpv(msg, " (@INC contains:");
3352 for (i = 0; i <= AvFILL(ar); i++) {
3353 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3354 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3355 sv_catsv(msg, dirmsgsv);
3357 sv_catpvn(msg, ")", 1);
3358 SvREFCNT_dec(dirmsgsv);
3359 msgstr = SvPV_nolen_const(msg);
3361 DIE(aTHX_ "Can't locate %s", msgstr);
3367 SETERRNO(0, SS_NORMAL);
3369 /* Assume success here to prevent recursive requirement. */
3371 /* Check whether a hook in @INC has already filled %INC */
3372 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3373 (void)hv_store(GvHVn(PL_incgv), name, len,
3374 (hook_sv ? SvREFCNT_inc(hook_sv)
3375 : newSVpv(CopFILE(&PL_compiling), 0)),
3381 lex_start(sv_2mortal(newSVpvn("",0)));
3382 SAVEGENERICSV(PL_rsfp_filters);
3383 PL_rsfp_filters = Nullav;
3388 SAVESPTR(PL_compiling.cop_warnings);
3389 if (PL_dowarn & G_WARN_ALL_ON)
3390 PL_compiling.cop_warnings = pWARN_ALL ;
3391 else if (PL_dowarn & G_WARN_ALL_OFF)
3392 PL_compiling.cop_warnings = pWARN_NONE ;
3393 else if (PL_taint_warn)
3394 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3396 PL_compiling.cop_warnings = pWARN_STD ;
3397 SAVESPTR(PL_compiling.cop_io);
3398 PL_compiling.cop_io = Nullsv;
3400 if (filter_sub || filter_child_proc) {
3401 SV * const datasv = filter_add(run_user_filter, Nullsv);
3402 IoLINES(datasv) = filter_has_file;
3403 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3404 IoTOP_GV(datasv) = (GV *)filter_state;
3405 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3408 /* switch to eval mode */
3409 PUSHBLOCK(cx, CXt_EVAL, SP);
3410 PUSHEVAL(cx, name, Nullgv);
3411 cx->blk_eval.retop = PL_op->op_next;
3413 SAVECOPLINE(&PL_compiling);
3414 CopLINE_set(&PL_compiling, 0);
3418 /* Store and reset encoding. */
3419 encoding = PL_encoding;
3420 PL_encoding = Nullsv;
3422 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3424 /* Restore encoding. */
3425 PL_encoding = encoding;
3432 return pp_require();
3438 register PERL_CONTEXT *cx;
3440 const I32 gimme = GIMME_V;
3441 const I32 was = PL_sub_generation;
3442 char tbuf[TYPE_DIGITS(long) + 12];
3443 char *tmpbuf = tbuf;
3450 if (!SvPV_const(sv,len))
3452 TAINT_PROPER("eval");
3458 /* switch to eval mode */
3460 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3461 SV * const sv = sv_newmortal();
3462 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3463 (unsigned long)++PL_evalseq,
3464 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3468 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3469 SAVECOPFILE_FREE(&PL_compiling);
3470 CopFILE_set(&PL_compiling, tmpbuf+2);
3471 SAVECOPLINE(&PL_compiling);
3472 CopLINE_set(&PL_compiling, 1);
3473 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3474 deleting the eval's FILEGV from the stash before gv_check() runs
3475 (i.e. before run-time proper). To work around the coredump that
3476 ensues, we always turn GvMULTI_on for any globals that were
3477 introduced within evals. See force_ident(). GSAR 96-10-12 */
3478 safestr = savepv(tmpbuf);
3479 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3481 PL_hints = PL_op->op_targ;
3482 SAVESPTR(PL_compiling.cop_warnings);
3483 if (specialWARN(PL_curcop->cop_warnings))
3484 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3486 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3487 SAVEFREESV(PL_compiling.cop_warnings);
3489 SAVESPTR(PL_compiling.cop_io);
3490 if (specialCopIO(PL_curcop->cop_io))
3491 PL_compiling.cop_io = PL_curcop->cop_io;
3493 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3494 SAVEFREESV(PL_compiling.cop_io);
3496 /* special case: an eval '' executed within the DB package gets lexically
3497 * placed in the first non-DB CV rather than the current CV - this
3498 * allows the debugger to execute code, find lexicals etc, in the
3499 * scope of the code being debugged. Passing &seq gets find_runcv
3500 * to do the dirty work for us */
3501 runcv = find_runcv(&seq);
3503 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3504 PUSHEVAL(cx, 0, Nullgv);
3505 cx->blk_eval.retop = PL_op->op_next;
3507 /* prepare to compile string */
3509 if (PERLDB_LINE && PL_curstash != PL_debstash)
3510 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3512 ret = doeval(gimme, NULL, runcv, seq);
3513 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3514 && ret != PL_op->op_next) { /* Successive compilation. */
3515 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3517 return DOCATCH(ret);
3527 register PERL_CONTEXT *cx;
3529 const U8 save_flags = PL_op -> op_flags;
3534 retop = cx->blk_eval.retop;
3537 if (gimme == G_VOID)
3539 else if (gimme == G_SCALAR) {
3542 if (SvFLAGS(TOPs) & SVs_TEMP)
3545 *MARK = sv_mortalcopy(TOPs);
3549 *MARK = &PL_sv_undef;
3554 /* in case LEAVE wipes old return values */
3555 for (mark = newsp + 1; mark <= SP; mark++) {
3556 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3557 *mark = sv_mortalcopy(*mark);
3558 TAINT_NOT; /* Each item is independent */
3562 PL_curpm = newpm; /* Don't pop $1 et al till now */
3565 assert(CvDEPTH(PL_compcv) == 1);
3567 CvDEPTH(PL_compcv) = 0;
3570 if (optype == OP_REQUIRE &&
3571 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3573 /* Unassume the success we assumed earlier. */
3574 SV * const nsv = cx->blk_eval.old_namesv;
3575 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3576 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3577 /* die_where() did LEAVE, or we won't be here */
3581 if (!(save_flags & OPf_SPECIAL))
3582 sv_setpvn(ERRSV,"",0);
3591 register PERL_CONTEXT *cx;
3592 const I32 gimme = GIMME_V;
3597 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3599 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3601 PL_in_eval = EVAL_INEVAL;
3602 sv_setpvn(ERRSV,"",0);
3604 return DOCATCH(PL_op->op_next);
3614 register PERL_CONTEXT *cx;
3619 PERL_UNUSED_VAR(optype);
3622 if (gimme == G_VOID)
3624 else if (gimme == G_SCALAR) {
3627 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3630 *MARK = sv_mortalcopy(TOPs);
3634 *MARK = &PL_sv_undef;
3639 /* in case LEAVE wipes old return values */
3640 for (mark = newsp + 1; mark <= SP; mark++) {
3641 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3642 *mark = sv_mortalcopy(*mark);
3643 TAINT_NOT; /* Each item is independent */
3647 PL_curpm = newpm; /* Don't pop $1 et al till now */
3650 sv_setpvn(ERRSV,"",0);
3655 S_doparseform(pTHX_ SV *sv)
3658 register char *s = SvPV_force(sv, len);
3659 register char *send = s + len;
3660 register char *base = Nullch;
3661 register I32 skipspaces = 0;
3662 bool noblank = FALSE;
3663 bool repeat = FALSE;
3664 bool postspace = FALSE;
3670 bool unchopnum = FALSE;
3671 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3674 Perl_croak(aTHX_ "Null picture in formline");
3676 /* estimate the buffer size needed */
3677 for (base = s; s <= send; s++) {
3678 if (*s == '\n' || *s == '@' || *s == '^')
3684 Newx(fops, maxops, U32);
3689 *fpc++ = FF_LINEMARK;
3690 noblank = repeat = FALSE;
3708 case ' ': case '\t':
3715 } /* else FALL THROUGH */
3723 *fpc++ = FF_LITERAL;
3731 *fpc++ = (U16)skipspaces;
3735 *fpc++ = FF_NEWLINE;
3739 arg = fpc - linepc + 1;
3746 *fpc++ = FF_LINEMARK;
3747 noblank = repeat = FALSE;
3756 ischop = s[-1] == '^';
3762 arg = (s - base) - 1;
3764 *fpc++ = FF_LITERAL;
3772 *fpc++ = 2; /* skip the @* or ^* */
3774 *fpc++ = FF_LINESNGL;
3777 *fpc++ = FF_LINEGLOB;
3779 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3780 arg = ischop ? 512 : 0;
3785 const char * const f = ++s;
3788 arg |= 256 + (s - f);
3790 *fpc++ = s - base; /* fieldsize for FETCH */
3791 *fpc++ = FF_DECIMAL;
3793 unchopnum |= ! ischop;
3795 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3796 arg = ischop ? 512 : 0;
3798 s++; /* skip the '0' first */
3802 const char * const f = ++s;
3805 arg |= 256 + (s - f);
3807 *fpc++ = s - base; /* fieldsize for FETCH */
3808 *fpc++ = FF_0DECIMAL;
3810 unchopnum |= ! ischop;
3814 bool ismore = FALSE;
3817 while (*++s == '>') ;
3818 prespace = FF_SPACE;
3820 else if (*s == '|') {
3821 while (*++s == '|') ;
3822 prespace = FF_HALFSPACE;
3827 while (*++s == '<') ;
3830 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3834 *fpc++ = s - base; /* fieldsize for FETCH */
3836 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3839 *fpc++ = (U16)prespace;
3853 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3855 { /* need to jump to the next word */
3857 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3858 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3859 s = SvPVX(sv) + SvCUR(sv) + z;
3861 Copy(fops, s, arg, U32);
3863 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3866 if (unchopnum && repeat)
3867 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3873 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3875 /* Can value be printed in fldsize chars, using %*.*f ? */
3879 int intsize = fldsize - (value < 0 ? 1 : 0);
3886 while (intsize--) pwr *= 10.0;
3887 while (frcsize--) eps /= 10.0;
3890 if (value + eps >= pwr)
3893 if (value - eps <= -pwr)
3900 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3903 SV *datasv = FILTER_DATA(idx);
3904 const int filter_has_file = IoLINES(datasv);
3905 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3906 SV *filter_state = (SV *)IoTOP_GV(datasv);
3907 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3910 /* I was having segfault trouble under Linux 2.2.5 after a
3911 parse error occured. (Had to hack around it with a test
3912 for PL_error_count == 0.) Solaris doesn't segfault --
3913 not sure where the trouble is yet. XXX */
3915 if (filter_has_file) {
3916 len = FILTER_READ(idx+1, buf_sv, maxlen);
3919 if (filter_sub && len >= 0) {
3930 PUSHs(sv_2mortal(newSViv(maxlen)));
3932 PUSHs(filter_state);
3935 count = call_sv(filter_sub, G_SCALAR);
3951 IoLINES(datasv) = 0;
3952 if (filter_child_proc) {
3953 SvREFCNT_dec(filter_child_proc);
3954 IoFMT_GV(datasv) = Nullgv;
3957 SvREFCNT_dec(filter_state);
3958 IoTOP_GV(datasv) = Nullgv;
3961 SvREFCNT_dec(filter_sub);
3962 IoBOTTOM_GV(datasv) = Nullgv;
3964 filter_del(run_user_filter);
3970 /* perhaps someone can come up with a better name for
3971 this? it is not really "absolute", per se ... */
3973 S_path_is_absolute(pTHX_ const char *name)
3975 if (PERL_FILE_IS_ABSOLUTE(name)
3976 #ifdef MACOS_TRADITIONAL
3979 || (*name == '.' && (name[1] == '/' ||
3980 (name[1] == '.' && name[2] == '/'))))
3991 * c-indentation-style: bsd
3993 * indent-tabs-mode: t
3996 * ex: set ts=8 sts=4 sw=4 noet: