3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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;
84 MAGIC *mg = Null(MAGIC*);
86 /* prevent recompiling under /o and ithreads. */
87 #if defined(USE_ITHREADS)
88 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
89 if (PL_op->op_flags & OPf_STACKED) {
98 if (PL_op->op_flags & OPf_STACKED) {
99 /* multiple args; concatentate them */
101 tmpstr = PAD_SV(ARGTARG);
102 sv_setpvn(tmpstr, "", 0);
103 while (++MARK <= SP) {
104 if (PL_amagic_generation) {
106 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
107 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
109 sv_setsv(tmpstr, sv);
113 sv_catsv(tmpstr, *MARK);
122 SV *sv = SvRV(tmpstr);
124 mg = mg_find(sv, PERL_MAGIC_qr);
127 regexp *re = (regexp *)mg->mg_obj;
128 ReREFCNT_dec(PM_GETRE(pm));
129 PM_SETRE(pm, ReREFCNT_inc(re));
132 t = SvPV(tmpstr, len);
134 /* Check against the last compiled regexp. */
135 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
136 PM_GETRE(pm)->prelen != (I32)len ||
137 memNE(PM_GETRE(pm)->precomp, t, len))
140 ReREFCNT_dec(PM_GETRE(pm));
141 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
143 if (PL_op->op_flags & OPf_SPECIAL)
144 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
146 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
148 pm->op_pmdynflags |= PMdf_DYN_UTF8;
150 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
151 if (pm->op_pmdynflags & PMdf_UTF8)
152 t = (char*)bytes_to_utf8((U8*)t, &len);
154 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
155 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
157 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
158 inside tie/overload accessors. */
162 #ifndef INCOMPLETE_TAINTS
165 pm->op_pmdynflags |= PMdf_TAINTED;
167 pm->op_pmdynflags &= ~PMdf_TAINTED;
171 if (!PM_GETRE(pm)->prelen && PL_curpm)
173 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
174 pm->op_pmflags |= PMf_WHITE;
176 pm->op_pmflags &= ~PMf_WHITE;
178 /* XXX runtime compiled output needs to move to the pad */
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
181 #if !defined(USE_ITHREADS)
182 /* XXX can't change the optree at runtime either */
183 cLOGOP->op_first->op_next = PL_op->op_next;
192 register PMOP *pm = (PMOP*) cLOGOP->op_other;
193 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
194 register SV *dstr = cx->sb_dstr;
195 register char *s = cx->sb_s;
196 register char *m = cx->sb_m;
197 char *orig = cx->sb_orig;
198 register REGEXP *rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 rxres_restore(&cx->sb_rxres, rx);
208 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
210 if (cx->sb_iters++) {
211 I32 saviters = cx->sb_iters;
212 if (cx->sb_iters > cx->sb_maxiters)
213 DIE(aTHX_ "Substitution loop");
215 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
216 cx->sb_rxtainted |= 2;
217 sv_catsv(dstr, POPs);
220 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
221 s == m, cx->sb_targ, NULL,
222 ((cx->sb_rflags & REXEC_COPY_STR)
223 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
224 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
226 SV *targ = cx->sb_targ;
228 assert(cx->sb_strend >= s);
229 if(cx->sb_strend > s) {
230 if (DO_UTF8(dstr) && !SvUTF8(targ))
231 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
233 sv_catpvn(dstr, s, cx->sb_strend - s);
235 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
237 #ifdef PERL_COPY_ON_WRITE
239 sv_force_normal_flags(targ, SV_COW_DROP_PV);
245 Safefree(SvPVX(targ));
247 SvPVX(targ) = SvPVX(dstr);
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
255 TAINT_IF(cx->sb_rxtainted & 1);
256 PUSHs(sv_2mortal(newSViv(saviters - 1)));
258 (void)SvPOK_only_UTF8(targ);
259 TAINT_IF(cx->sb_rxtainted);
263 LEAVE_SCOPE(cx->sb_oldsave);
266 RETURNOP(pm->op_next);
268 cx->sb_iters = saviters;
270 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
273 cx->sb_orig = orig = rx->subbeg;
275 cx->sb_strend = s + (cx->sb_strend - m);
277 cx->sb_m = m = rx->startp[0] + orig;
279 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
280 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
282 sv_catpvn(dstr, s, m-s);
284 cx->sb_s = rx->endp[0] + orig;
285 { /* Update the pos() information. */
286 SV *sv = cx->sb_targ;
289 if (SvTYPE(sv) < SVt_PVMG)
290 (void)SvUPGRADE(sv, SVt_PVMG);
291 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
292 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
293 mg = mg_find(sv, PERL_MAGIC_regex_global);
302 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
303 rxres_save(&cx->sb_rxres, rx);
304 RETURNOP(pm->op_pmreplstart);
308 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
313 if (!p || p[1] < rx->nparens) {
314 #ifdef PERL_COPY_ON_WRITE
315 i = 7 + rx->nparens * 2;
317 i = 6 + rx->nparens * 2;
326 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
327 RX_MATCH_COPIED_off(rx);
329 #ifdef PERL_COPY_ON_WRITE
330 *p++ = PTR2UV(rx->saved_copy);
331 rx->saved_copy = Nullsv;
336 *p++ = PTR2UV(rx->subbeg);
337 *p++ = (UV)rx->sublen;
338 for (i = 0; i <= rx->nparens; ++i) {
339 *p++ = (UV)rx->startp[i];
340 *p++ = (UV)rx->endp[i];
345 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
350 RX_MATCH_COPY_FREE(rx);
351 RX_MATCH_COPIED_set(rx, *p);
354 #ifdef PERL_COPY_ON_WRITE
356 SvREFCNT_dec (rx->saved_copy);
357 rx->saved_copy = INT2PTR(SV*,*p);
363 rx->subbeg = INT2PTR(char*,*p++);
364 rx->sublen = (I32)(*p++);
365 for (i = 0; i <= rx->nparens; ++i) {
366 rx->startp[i] = (I32)(*p++);
367 rx->endp[i] = (I32)(*p++);
372 Perl_rxres_free(pTHX_ void **rsp)
377 Safefree(INT2PTR(char*,*p));
378 #ifdef PERL_COPY_ON_WRITE
380 SvREFCNT_dec (INT2PTR(SV*,p[1]));
390 dSP; dMARK; dORIGMARK;
391 register SV *tmpForm = *++MARK;
398 register SV *sv = Nullsv;
403 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
404 char *chophere = Nullch;
405 char *linemark = Nullch;
407 bool gotsome = FALSE;
409 STRLEN fudge = SvPOK(tmpForm)
410 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
411 bool item_is_utf8 = FALSE;
412 bool targ_is_utf8 = FALSE;
418 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
419 if (SvREADONLY(tmpForm)) {
420 SvREADONLY_off(tmpForm);
421 parseres = doparseform(tmpForm);
422 SvREADONLY_on(tmpForm);
425 parseres = doparseform(tmpForm);
429 SvPV_force(PL_formtarget, len);
430 if (DO_UTF8(PL_formtarget))
432 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
434 f = SvPV(tmpForm, len);
435 /* need to jump to the next word */
436 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
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(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(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");
517 item = s = SvPV(sv, len);
520 itemsize = sv_len_utf8(sv);
521 if (itemsize != (I32)len) {
523 if (itemsize > fieldsize) {
524 itemsize = fieldsize;
525 itembytes = itemsize;
526 sv_pos_u2b(sv, &itembytes, 0);
530 send = chophere = s + itembytes;
540 sv_pos_b2u(sv, &itemsize);
544 item_is_utf8 = FALSE;
545 if (itemsize > fieldsize)
546 itemsize = fieldsize;
547 send = chophere = s + itemsize;
559 item = s = SvPV(sv, len);
562 itemsize = sv_len_utf8(sv);
563 if (itemsize != (I32)len) {
565 if (itemsize <= fieldsize) {
566 send = chophere = s + itemsize;
578 itemsize = fieldsize;
579 itembytes = itemsize;
580 sv_pos_u2b(sv, &itembytes, 0);
581 send = chophere = s + itembytes;
582 while (s < send || (s == send && isSPACE(*s))) {
592 if (strchr(PL_chopset, *s))
597 itemsize = chophere - item;
598 sv_pos_b2u(sv, &itemsize);
604 item_is_utf8 = FALSE;
605 if (itemsize <= fieldsize) {
606 send = chophere = s + itemsize;
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
630 if (strchr(PL_chopset, *s))
635 itemsize = chophere - item;
640 arg = fieldsize - itemsize;
649 arg = fieldsize - itemsize;
663 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
665 sv_utf8_upgrade(PL_formtarget);
666 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
667 t = SvEND(PL_formtarget);
671 if (UTF8_IS_CONTINUED(*s)) {
672 STRLEN skip = UTF8SKIP(s);
689 if ( !((*t++ = *s++) & ~31) )
695 if (targ_is_utf8 && !item_is_utf8) {
696 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
698 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
699 for (; t < SvEND(PL_formtarget); t++) {
712 int ch = *t++ = *s++;
715 if ( !((*t++ = *s++) & ~31) )
724 while (*s && isSPACE(*s))
738 item = s = SvPV(sv, len);
740 if ((item_is_utf8 = DO_UTF8(sv)))
741 itemsize = sv_len_utf8(sv);
743 bool chopped = FALSE;
746 chophere = s + itemsize;
762 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
764 SvUTF8_on(PL_formtarget);
766 SvCUR_set(sv, chophere - item);
767 sv_catsv(PL_formtarget, sv);
768 SvCUR_set(sv, itemsize);
770 sv_catsv(PL_formtarget, sv);
772 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
773 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
774 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
782 #if defined(USE_LONG_DOUBLE)
783 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
785 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
790 #if defined(USE_LONG_DOUBLE)
791 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
793 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
796 /* If the field is marked with ^ and the value is undefined,
798 if ((arg & 512) && !SvOK(sv)) {
806 /* overflow evidence */
807 if (num_overflow(value, fieldsize, arg)) {
813 /* Formats aren't yet marked for locales, so assume "yes". */
815 STORE_NUMERIC_STANDARD_SET_LOCAL();
816 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
817 RESTORE_NUMERIC_STANDARD();
824 while (t-- > linemark && *t == ' ') ;
832 if (arg) { /* repeat until fields exhausted? */
834 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
835 lines += FmLINES(PL_formtarget);
838 if (strnEQ(linemark, linemark - arg, arg))
839 DIE(aTHX_ "Runaway format");
842 SvUTF8_on(PL_formtarget);
843 FmLINES(PL_formtarget) = lines;
845 RETURNOP(cLISTOP->op_first);
858 while (*s && isSPACE(*s) && s < send)
862 arg = fieldsize - itemsize;
869 if (strnEQ(s," ",3)) {
870 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
881 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
883 SvUTF8_on(PL_formtarget);
884 FmLINES(PL_formtarget) += lines;
896 if (PL_stack_base + *PL_markstack_ptr == SP) {
898 if (GIMME_V == G_SCALAR)
899 XPUSHs(sv_2mortal(newSViv(0)));
900 RETURNOP(PL_op->op_next->op_next);
902 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
903 pp_pushmark(); /* push dst */
904 pp_pushmark(); /* push src */
905 ENTER; /* enter outer scope */
908 if (PL_op->op_private & OPpGREP_LEX)
909 SAVESPTR(PAD_SVl(PL_op->op_targ));
912 ENTER; /* enter inner scope */
915 src = PL_stack_base[*PL_markstack_ptr];
917 if (PL_op->op_private & OPpGREP_LEX)
918 PAD_SVl(PL_op->op_targ) = src;
923 if (PL_op->op_type == OP_MAPSTART)
924 pp_pushmark(); /* push top */
925 return ((LOGOP*)PL_op->op_next)->op_other;
930 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
937 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
943 /* first, move source pointer to the next item in the source list */
944 ++PL_markstack_ptr[-1];
946 /* if there are new items, push them into the destination list */
947 if (items && gimme != G_VOID) {
948 /* might need to make room back there first */
949 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
950 /* XXX this implementation is very pessimal because the stack
951 * is repeatedly extended for every set of items. Is possible
952 * to do this without any stack extension or copying at all
953 * by maintaining a separate list over which the map iterates
954 * (like foreach does). --gsar */
956 /* everything in the stack after the destination list moves
957 * towards the end the stack by the amount of room needed */
958 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
960 /* items to shift up (accounting for the moved source pointer) */
961 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
963 /* This optimization is by Ben Tilly and it does
964 * things differently from what Sarathy (gsar)
965 * is describing. The downside of this optimization is
966 * that leaves "holes" (uninitialized and hopefully unused areas)
967 * to the Perl stack, but on the other hand this
968 * shouldn't be a problem. If Sarathy's idea gets
969 * implemented, this optimization should become
970 * irrelevant. --jhi */
972 shift = count; /* Avoid shifting too often --Ben Tilly */
977 PL_markstack_ptr[-1] += shift;
978 *PL_markstack_ptr += shift;
982 /* copy the new items down to the destination list */
983 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
984 if (gimme == G_ARRAY) {
986 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
989 /* scalar context: we don't care about which values map returns
990 * (we use undef here). And so we certainly don't want to do mortal
991 * copies of meaningless values. */
992 while (items-- > 0) {
994 *dst-- = &PL_sv_undef;
998 LEAVE; /* exit inner scope */
1001 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1003 (void)POPMARK; /* pop top */
1004 LEAVE; /* exit outer scope */
1005 (void)POPMARK; /* pop src */
1006 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1007 (void)POPMARK; /* pop dst */
1008 SP = PL_stack_base + POPMARK; /* pop original mark */
1009 if (gimme == G_SCALAR) {
1010 if (PL_op->op_private & OPpGREP_LEX) {
1011 SV* sv = sv_newmortal();
1012 sv_setiv(sv, items);
1020 else if (gimme == G_ARRAY)
1027 ENTER; /* enter inner scope */
1030 /* set $_ to the new source item */
1031 src = PL_stack_base[PL_markstack_ptr[-1]];
1033 if (PL_op->op_private & OPpGREP_LEX)
1034 PAD_SVl(PL_op->op_targ) = src;
1038 RETURNOP(cLOGOP->op_other);
1046 if (GIMME == G_ARRAY)
1048 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1049 return cLOGOP->op_other;
1058 if (GIMME == G_ARRAY) {
1059 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1063 SV *targ = PAD_SV(PL_op->op_targ);
1066 if (PL_op->op_private & OPpFLIP_LINENUM) {
1067 if (GvIO(PL_last_in_gv)) {
1068 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1071 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1072 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1078 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1079 if (PL_op->op_flags & OPf_SPECIAL) {
1087 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1096 /* This code tries to decide if "$left .. $right" should use the
1097 magical string increment, or if the range is numeric (we make
1098 an exception for .."0" [#18165]). AMS 20021031. */
1100 #define RANGE_IS_NUMERIC(left,right) ( \
1101 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1102 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1103 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1104 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1105 && (!SvOK(right) || looks_like_number(right))))
1111 if (GIMME == G_ARRAY) {
1117 if (SvGMAGICAL(left))
1119 if (SvGMAGICAL(right))
1122 if (RANGE_IS_NUMERIC(left,right)) {
1123 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1124 (SvOK(right) && SvNV(right) > IV_MAX))
1125 DIE(aTHX_ "Range iterator outside integer range");
1136 sv = sv_2mortal(newSViv(i++));
1141 SV *final = sv_mortalcopy(right);
1143 char *tmps = SvPV(final, len);
1145 sv = sv_mortalcopy(left);
1147 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1149 if (strEQ(SvPVX(sv),tmps))
1151 sv = sv_2mortal(newSVsv(sv));
1158 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1162 if (PL_op->op_private & OPpFLIP_LINENUM) {
1163 if (GvIO(PL_last_in_gv)) {
1164 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1167 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1168 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1176 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1177 sv_catpv(targ, "E0");
1187 static char *context_name[] = {
1198 S_dopoptolabel(pTHX_ char *label)
1201 register PERL_CONTEXT *cx;
1203 for (i = cxstack_ix; i >= 0; i--) {
1205 switch (CxTYPE(cx)) {
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1213 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1214 if (CxTYPE(cx) == CXt_NULL)
1218 if (!cx->blk_loop.label ||
1219 strNE(label, cx->blk_loop.label) ) {
1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1221 (long)i, cx->blk_loop.label));
1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1232 Perl_dowantarray(pTHX)
1234 I32 gimme = block_gimme();
1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1239 Perl_block_gimme(pTHX)
1243 cxix = dopoptosub(cxstack_ix);
1247 switch (cxstack[cxix].blk_gimme) {
1255 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1262 Perl_is_lvalue_sub(pTHX)
1266 cxix = dopoptosub(cxstack_ix);
1267 assert(cxix >= 0); /* We should only be called from inside subs */
1269 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1270 return cxstack[cxix].blk_sub.lval;
1276 S_dopoptosub(pTHX_ I32 startingblock)
1278 return dopoptosub_at(cxstack, startingblock);
1282 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1285 register PERL_CONTEXT *cx;
1286 for (i = startingblock; i >= 0; i--) {
1288 switch (CxTYPE(cx)) {
1294 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1302 S_dopoptoeval(pTHX_ I32 startingblock)
1305 register PERL_CONTEXT *cx;
1306 for (i = startingblock; i >= 0; i--) {
1308 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1323 register PERL_CONTEXT *cx;
1324 for (i = startingblock; i >= 0; i--) {
1326 switch (CxTYPE(cx)) {
1332 if (ckWARN(WARN_EXITING))
1333 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335 if ((CxTYPE(cx)) == CXt_NULL)
1339 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1347 Perl_dounwind(pTHX_ I32 cxix)
1349 register PERL_CONTEXT *cx;
1352 while (cxstack_ix > cxix) {
1354 cx = &cxstack[cxstack_ix];
1355 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1356 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1357 /* Note: we don't need to restore the base context info till the end. */
1358 switch (CxTYPE(cx)) {
1361 continue; /* not break */
1383 Perl_qerror(pTHX_ SV *err)
1386 sv_catsv(ERRSV, err);
1388 sv_catsv(PL_errors, err);
1390 Perl_warn(aTHX_ "%"SVf, err);
1395 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1401 register PERL_CONTEXT *cx;
1406 if (PL_in_eval & EVAL_KEEPERR) {
1407 static char prefix[] = "\t(in cleanup) ";
1412 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1415 if (*e != *message || strNE(e,message))
1419 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1420 sv_catpvn(err, prefix, sizeof(prefix)-1);
1421 sv_catpvn(err, message, msglen);
1422 if (ckWARN(WARN_MISC)) {
1423 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1424 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1429 sv_setpvn(ERRSV, message, msglen);
1433 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1434 && PL_curstackinfo->si_prev)
1443 if (cxix < cxstack_ix)
1446 POPBLOCK(cx,PL_curpm);
1447 if (CxTYPE(cx) != CXt_EVAL) {
1449 message = SvPVx(ERRSV, msglen);
1450 PerlIO_write(Perl_error_log, "panic: die ", 11);
1451 PerlIO_write(Perl_error_log, message, msglen);
1456 if (gimme == G_SCALAR)
1457 *++newsp = &PL_sv_undef;
1458 PL_stack_sp = newsp;
1462 /* LEAVE could clobber PL_curcop (see save_re_context())
1463 * XXX it might be better to find a way to avoid messing with
1464 * PL_curcop in save_re_context() instead, but this is a more
1465 * minimal fix --GSAR */
1466 PL_curcop = cx->blk_oldcop;
1468 if (optype == OP_REQUIRE) {
1469 char* msg = SvPVx(ERRSV, n_a);
1470 SV *nsv = cx->blk_eval.old_namesv;
1471 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1473 DIE(aTHX_ "%sCompilation failed in require",
1474 *msg ? msg : "Unknown error\n");
1476 assert(CxTYPE(cx) == CXt_EVAL);
1477 return cx->blk_eval.retop;
1481 message = SvPVx(ERRSV, msglen);
1483 write_to_stderr(message, msglen);
1492 if (SvTRUE(left) != SvTRUE(right))
1504 RETURNOP(cLOGOP->op_other);
1513 RETURNOP(cLOGOP->op_other);
1522 if (!sv || !SvANY(sv)) {
1523 RETURNOP(cLOGOP->op_other);
1526 switch (SvTYPE(sv)) {
1528 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1532 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1536 if (CvROOT(sv) || CvXSUB(sv))
1546 RETURNOP(cLOGOP->op_other);
1552 register I32 cxix = dopoptosub(cxstack_ix);
1553 register PERL_CONTEXT *cx;
1554 register PERL_CONTEXT *ccstack = cxstack;
1555 PERL_SI *top_si = PL_curstackinfo;
1566 /* we may be in a higher stacklevel, so dig down deeper */
1567 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1568 top_si = top_si->si_prev;
1569 ccstack = top_si->si_cxstack;
1570 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1573 if (GIMME != G_ARRAY) {
1579 if (PL_DBsub && cxix >= 0 &&
1580 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1584 cxix = dopoptosub_at(ccstack, cxix - 1);
1587 cx = &ccstack[cxix];
1588 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1589 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1590 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1591 field below is defined for any cx. */
1592 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1593 cx = &ccstack[dbcxix];
1596 stashname = CopSTASHPV(cx->blk_oldcop);
1597 if (GIMME != G_ARRAY) {
1600 PUSHs(&PL_sv_undef);
1603 sv_setpv(TARG, stashname);
1612 PUSHs(&PL_sv_undef);
1614 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1615 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1616 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1619 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1620 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1621 /* So is ccstack[dbcxix]. */
1624 gv_efullname3(sv, cvgv, Nullch);
1625 PUSHs(sv_2mortal(sv));
1626 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1629 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1630 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1634 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1635 PUSHs(sv_2mortal(newSViv(0)));
1637 gimme = (I32)cx->blk_gimme;
1638 if (gimme == G_VOID)
1639 PUSHs(&PL_sv_undef);
1641 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1642 if (CxTYPE(cx) == CXt_EVAL) {
1644 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1645 PUSHs(cx->blk_eval.cur_text);
1649 else if (cx->blk_eval.old_namesv) {
1650 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1653 /* eval BLOCK (try blocks have old_namesv == 0) */
1655 PUSHs(&PL_sv_undef);
1656 PUSHs(&PL_sv_undef);
1660 PUSHs(&PL_sv_undef);
1661 PUSHs(&PL_sv_undef);
1663 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1664 && CopSTASH_eq(PL_curcop, PL_debstash))
1666 AV *ary = cx->blk_sub.argarray;
1667 int off = AvARRAY(ary) - AvALLOC(ary);
1671 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1674 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1677 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1678 av_extend(PL_dbargs, AvFILLp(ary) + off);
1679 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1680 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1682 /* XXX only hints propagated via op_private are currently
1683 * visible (others are not easily accessible, since they
1684 * use the global PL_hints) */
1685 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1686 HINT_PRIVATE_MASK)));
1689 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1691 if (old_warnings == pWARN_NONE ||
1692 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1693 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1694 else if (old_warnings == pWARN_ALL ||
1695 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1696 /* Get the bit mask for $warnings::Bits{all}, because
1697 * it could have been extended by warnings::register */
1699 HV *bits = get_hv("warnings::Bits", FALSE);
1700 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1701 mask = newSVsv(*bits_all);
1704 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1708 mask = newSVsv(old_warnings);
1709 PUSHs(sv_2mortal(mask));
1724 sv_reset(tmps, CopSTASH(PL_curcop));
1734 /* like pp_nextstate, but used instead when the debugger is active */
1738 PL_curcop = (COP*)PL_op;
1739 TAINT_NOT; /* Each statement is presumed innocent */
1740 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1743 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1744 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1748 register PERL_CONTEXT *cx;
1749 I32 gimme = G_ARRAY;
1756 DIE(aTHX_ "No DB::DB routine defined");
1758 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1759 /* don't do recursive DB::DB call */
1771 PUSHBLOCK(cx, CXt_SUB, SP);
1773 cx->blk_sub.retop = PL_op->op_next;
1775 PAD_SET_CUR(CvPADLIST(cv),1);
1776 RETURNOP(CvSTART(cv));
1790 register PERL_CONTEXT *cx;
1791 I32 gimme = GIMME_V;
1793 U32 cxtype = CXt_LOOP;
1801 if (PL_op->op_targ) {
1802 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1803 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1804 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1805 SVs_PADSTALE, SVs_PADSTALE);
1807 #ifndef USE_ITHREADS
1808 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1811 SAVEPADSV(PL_op->op_targ);
1812 iterdata = INT2PTR(void*, PL_op->op_targ);
1813 cxtype |= CXp_PADVAR;
1818 svp = &GvSV(gv); /* symbol table variable */
1819 SAVEGENERICSV(*svp);
1822 iterdata = (void*)gv;
1828 PUSHBLOCK(cx, cxtype, SP);
1830 PUSHLOOP(cx, iterdata, MARK);
1832 PUSHLOOP(cx, svp, MARK);
1834 if (PL_op->op_flags & OPf_STACKED) {
1835 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1836 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1838 SV *right = (SV*)cx->blk_loop.iterary;
1839 if (RANGE_IS_NUMERIC(sv,right)) {
1840 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1841 (SvOK(right) && SvNV(right) >= IV_MAX))
1842 DIE(aTHX_ "Range iterator outside integer range");
1843 cx->blk_loop.iterix = SvIV(sv);
1844 cx->blk_loop.itermax = SvIV(right);
1848 cx->blk_loop.iterlval = newSVsv(sv);
1849 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1850 (void) SvPV(right,n_a);
1853 else if (PL_op->op_private & OPpITER_REVERSED) {
1854 cx->blk_loop.itermax = -1;
1855 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1860 cx->blk_loop.iterary = PL_curstack;
1861 AvFILLp(PL_curstack) = SP - PL_stack_base;
1862 if (PL_op->op_private & OPpITER_REVERSED) {
1863 cx->blk_loop.itermax = MARK - PL_stack_base;
1864 cx->blk_loop.iterix = cx->blk_oldsp;
1867 cx->blk_loop.iterix = MARK - PL_stack_base;
1877 register PERL_CONTEXT *cx;
1878 I32 gimme = GIMME_V;
1884 PUSHBLOCK(cx, CXt_LOOP, SP);
1885 PUSHLOOP(cx, 0, SP);
1893 register PERL_CONTEXT *cx;
1901 newsp = PL_stack_base + cx->blk_loop.resetsp;
1904 if (gimme == G_VOID)
1906 else if (gimme == G_SCALAR) {
1908 *++newsp = sv_mortalcopy(*SP);
1910 *++newsp = &PL_sv_undef;
1914 *++newsp = sv_mortalcopy(*++mark);
1915 TAINT_NOT; /* Each item is independent */
1921 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1922 PL_curpm = newpm; /* ... and pop $1 et al */
1934 register PERL_CONTEXT *cx;
1935 bool popsub2 = FALSE;
1936 bool clear_errsv = FALSE;
1944 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1945 if (cxstack_ix == PL_sortcxix
1946 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1948 if (cxstack_ix > PL_sortcxix)
1949 dounwind(PL_sortcxix);
1950 AvARRAY(PL_curstack)[1] = *SP;
1951 PL_stack_sp = PL_stack_base + 1;
1956 cxix = dopoptosub(cxstack_ix);
1958 DIE(aTHX_ "Can't return outside a subroutine");
1959 if (cxix < cxstack_ix)
1963 switch (CxTYPE(cx)) {
1966 retop = cx->blk_sub.retop;
1967 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1970 if (!(PL_in_eval & EVAL_KEEPERR))
1973 retop = cx->blk_eval.retop;
1977 if (optype == OP_REQUIRE &&
1978 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1980 /* Unassume the success we assumed earlier. */
1981 SV *nsv = cx->blk_eval.old_namesv;
1982 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1983 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1988 retop = cx->blk_sub.retop;
1991 DIE(aTHX_ "panic: return");
1995 if (gimme == G_SCALAR) {
1998 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2000 *++newsp = SvREFCNT_inc(*SP);
2005 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2007 *++newsp = sv_mortalcopy(sv);
2012 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2015 *++newsp = sv_mortalcopy(*SP);
2018 *++newsp = &PL_sv_undef;
2020 else if (gimme == G_ARRAY) {
2021 while (++MARK <= SP) {
2022 *++newsp = (popsub2 && SvTEMP(*MARK))
2023 ? *MARK : sv_mortalcopy(*MARK);
2024 TAINT_NOT; /* Each item is independent */
2027 PL_stack_sp = newsp;
2030 /* Stack values are safe: */
2033 POPSUB(cx,sv); /* release CV and @_ ... */
2037 PL_curpm = newpm; /* ... and pop $1 et al */
2049 register PERL_CONTEXT *cx;
2059 if (PL_op->op_flags & OPf_SPECIAL) {
2060 cxix = dopoptoloop(cxstack_ix);
2062 DIE(aTHX_ "Can't \"last\" outside a loop block");
2065 cxix = dopoptolabel(cPVOP->op_pv);
2067 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2069 if (cxix < cxstack_ix)
2073 cxstack_ix++; /* temporarily protect top context */
2075 switch (CxTYPE(cx)) {
2078 newsp = PL_stack_base + cx->blk_loop.resetsp;
2079 nextop = cx->blk_loop.last_op->op_next;
2083 nextop = cx->blk_sub.retop;
2087 nextop = cx->blk_eval.retop;
2091 nextop = cx->blk_sub.retop;
2094 DIE(aTHX_ "panic: last");
2098 if (gimme == G_SCALAR) {
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2101 ? *SP : sv_mortalcopy(*SP);
2103 *++newsp = &PL_sv_undef;
2105 else if (gimme == G_ARRAY) {
2106 while (++MARK <= SP) {
2107 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2108 ? *MARK : sv_mortalcopy(*MARK);
2109 TAINT_NOT; /* Each item is independent */
2117 /* Stack values are safe: */
2120 POPLOOP(cx); /* release loop vars ... */
2124 POPSUB(cx,sv); /* release CV and @_ ... */
2127 PL_curpm = newpm; /* ... and pop $1 et al */
2136 register PERL_CONTEXT *cx;
2139 if (PL_op->op_flags & OPf_SPECIAL) {
2140 cxix = dopoptoloop(cxstack_ix);
2142 DIE(aTHX_ "Can't \"next\" outside a loop block");
2145 cxix = dopoptolabel(cPVOP->op_pv);
2147 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2149 if (cxix < cxstack_ix)
2152 /* clear off anything above the scope we're re-entering, but
2153 * save the rest until after a possible continue block */
2154 inner = PL_scopestack_ix;
2156 if (PL_scopestack_ix < inner)
2157 leave_scope(PL_scopestack[PL_scopestack_ix]);
2158 return cx->blk_loop.next_op;
2164 register PERL_CONTEXT *cx;
2167 if (PL_op->op_flags & OPf_SPECIAL) {
2168 cxix = dopoptoloop(cxstack_ix);
2170 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2173 cxix = dopoptolabel(cPVOP->op_pv);
2175 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2177 if (cxix < cxstack_ix)
2181 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2182 LEAVE_SCOPE(oldsave);
2184 return cx->blk_loop.redo_op;
2188 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2192 static char too_deep[] = "Target of goto is too deeply nested";
2195 Perl_croak(aTHX_ too_deep);
2196 if (o->op_type == OP_LEAVE ||
2197 o->op_type == OP_SCOPE ||
2198 o->op_type == OP_LEAVELOOP ||
2199 o->op_type == OP_LEAVESUB ||
2200 o->op_type == OP_LEAVETRY)
2202 *ops++ = cUNOPo->op_first;
2204 Perl_croak(aTHX_ too_deep);
2207 if (o->op_flags & OPf_KIDS) {
2208 /* First try all the kids at this level, since that's likeliest. */
2209 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2210 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2211 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2214 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2215 if (kid == PL_lastgotoprobe)
2217 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2220 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2221 ops[-1]->op_type == OP_DBSTATE)
2226 if ((o = dofindlabel(kid, label, ops, oplimit)))
2245 register PERL_CONTEXT *cx;
2246 #define GOTO_DEPTH 64
2247 OP *enterops[GOTO_DEPTH];
2249 int do_dump = (PL_op->op_type == OP_DUMP);
2250 static char must_have_label[] = "goto must have label";
2253 if (PL_op->op_flags & OPf_STACKED) {
2257 /* This egregious kludge implements goto &subroutine */
2258 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2260 register PERL_CONTEXT *cx;
2261 CV* cv = (CV*)SvRV(sv);
2268 if (!CvROOT(cv) && !CvXSUB(cv)) {
2273 /* autoloaded stub? */
2274 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2276 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2277 GvNAMELEN(gv), FALSE);
2278 if (autogv && (cv = GvCV(autogv)))
2280 tmpstr = sv_newmortal();
2281 gv_efullname3(tmpstr, gv, Nullch);
2282 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2284 DIE(aTHX_ "Goto undefined subroutine");
2287 /* First do some returnish stuff. */
2288 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2290 cxix = dopoptosub(cxstack_ix);
2292 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2293 if (cxix < cxstack_ix)
2297 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2298 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2299 /* put @_ back onto stack */
2300 AV* av = cx->blk_sub.argarray;
2302 items = AvFILLp(av) + 1;
2303 EXTEND(SP, items+1); /* @_ could have been extended. */
2304 Copy(AvARRAY(av), SP + 1, items, SV*);
2305 SvREFCNT_dec(GvAV(PL_defgv));
2306 GvAV(PL_defgv) = cx->blk_sub.savearray;
2308 /* abandon @_ if it got reified */
2313 av_extend(av, items-1);
2314 AvFLAGS(av) = AVf_REIFY;
2315 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2318 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2320 av = GvAV(PL_defgv);
2321 items = AvFILLp(av) + 1;
2322 EXTEND(SP, items+1); /* @_ could have been extended. */
2323 Copy(AvARRAY(av), SP + 1, items, SV*);
2327 if (CxTYPE(cx) == CXt_SUB &&
2328 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2329 SvREFCNT_dec(cx->blk_sub.cv);
2330 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2331 LEAVE_SCOPE(oldsave);
2333 /* Now do some callish stuff. */
2335 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2339 for (index=0; index<items; index++)
2340 sv_2mortal(SP[-index]);
2342 #ifdef PERL_XSUB_OLDSTYLE
2343 if (CvOLDSTYLE(cv)) {
2344 I32 (*fp3)(int,int,int);
2349 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2350 items = (*fp3)(CvXSUBANY(cv).any_i32,
2351 mark - PL_stack_base + 1,
2353 SP = PL_stack_base + items;
2356 #endif /* PERL_XSUB_OLDSTYLE */
2361 /* Push a mark for the start of arglist */
2364 (void)(*CvXSUB(cv))(aTHX_ cv);
2365 /* Pop the current context like a decent sub should */
2366 POPBLOCK(cx, PL_curpm);
2367 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2370 assert(CxTYPE(cx) == CXt_SUB);
2371 return cx->blk_sub.retop;
2374 AV* padlist = CvPADLIST(cv);
2375 if (CxTYPE(cx) == CXt_EVAL) {
2376 PL_in_eval = cx->blk_eval.old_in_eval;
2377 PL_eval_root = cx->blk_eval.old_eval_root;
2378 cx->cx_type = CXt_SUB;
2379 cx->blk_sub.hasargs = 0;
2381 cx->blk_sub.cv = cv;
2382 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2385 if (CvDEPTH(cv) < 2)
2386 (void)SvREFCNT_inc(cv);
2388 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2389 sub_crush_depth(cv);
2390 pad_push(padlist, CvDEPTH(cv), 1);
2392 PAD_SET_CUR(padlist, CvDEPTH(cv));
2393 if (cx->blk_sub.hasargs)
2395 AV* av = (AV*)PAD_SVl(0);
2398 cx->blk_sub.savearray = GvAV(PL_defgv);
2399 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2400 CX_CURPAD_SAVE(cx->blk_sub);
2401 cx->blk_sub.argarray = av;
2403 if (items >= AvMAX(av) + 1) {
2405 if (AvARRAY(av) != ary) {
2406 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407 SvPVX(av) = (char*)ary;
2409 if (items >= AvMAX(av) + 1) {
2410 AvMAX(av) = items - 1;
2411 Renew(ary,items+1,SV*);
2413 SvPVX(av) = (char*)ary;
2417 Copy(mark,AvARRAY(av),items,SV*);
2418 AvFILLp(av) = items - 1;
2419 assert(!AvREAL(av));
2421 /* transfer 'ownership' of refcnts to new @_ */
2431 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2433 * We do not care about using sv to call CV;
2434 * it's for informational purposes only.
2436 SV *sv = GvSV(PL_DBsub);
2439 if (PERLDB_SUB_NN) {
2440 (void)SvUPGRADE(sv, SVt_PVIV);
2443 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2446 gv_efullname3(sv, CvGV(cv), Nullch);
2449 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2450 PUSHMARK( PL_stack_sp );
2451 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2455 RETURNOP(CvSTART(cv));
2459 label = SvPV(sv,n_a);
2460 if (!(do_dump || *label))
2461 DIE(aTHX_ must_have_label);
2464 else if (PL_op->op_flags & OPf_SPECIAL) {
2466 DIE(aTHX_ must_have_label);
2469 label = cPVOP->op_pv;
2471 if (label && *label) {
2473 bool leaving_eval = FALSE;
2474 bool in_block = FALSE;
2475 PERL_CONTEXT *last_eval_cx = 0;
2479 PL_lastgotoprobe = 0;
2481 for (ix = cxstack_ix; ix >= 0; ix--) {
2483 switch (CxTYPE(cx)) {
2485 leaving_eval = TRUE;
2486 if (!CxTRYBLOCK(cx)) {
2487 gotoprobe = (last_eval_cx ?
2488 last_eval_cx->blk_eval.old_eval_root :
2493 /* else fall through */
2495 gotoprobe = cx->blk_oldcop->op_sibling;
2501 gotoprobe = cx->blk_oldcop->op_sibling;
2504 gotoprobe = PL_main_root;
2507 if (CvDEPTH(cx->blk_sub.cv)) {
2508 gotoprobe = CvROOT(cx->blk_sub.cv);
2514 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2517 DIE(aTHX_ "panic: goto");
2518 gotoprobe = PL_main_root;
2522 retop = dofindlabel(gotoprobe, label,
2523 enterops, enterops + GOTO_DEPTH);
2527 PL_lastgotoprobe = gotoprobe;
2530 DIE(aTHX_ "Can't find label %s", label);
2532 /* if we're leaving an eval, check before we pop any frames
2533 that we're not going to punt, otherwise the error
2536 if (leaving_eval && *enterops && enterops[1]) {
2538 for (i = 1; enterops[i]; i++)
2539 if (enterops[i]->op_type == OP_ENTERITER)
2540 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2543 /* pop unwanted frames */
2545 if (ix < cxstack_ix) {
2552 oldsave = PL_scopestack[PL_scopestack_ix];
2553 LEAVE_SCOPE(oldsave);
2556 /* push wanted frames */
2558 if (*enterops && enterops[1]) {
2560 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2561 for (; enterops[ix]; ix++) {
2562 PL_op = enterops[ix];
2563 /* Eventually we may want to stack the needed arguments
2564 * for each op. For now, we punt on the hard ones. */
2565 if (PL_op->op_type == OP_ENTERITER)
2566 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2567 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2575 if (!retop) retop = PL_main_start;
2577 PL_restartop = retop;
2578 PL_do_undump = TRUE;
2582 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2583 PL_do_undump = FALSE;
2599 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2601 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2604 PL_exit_flags |= PERL_EXIT_EXPECTED;
2606 PUSHs(&PL_sv_undef);
2614 NV value = SvNVx(GvSV(cCOP->cop_gv));
2615 register I32 match = I_32(value);
2618 if (((NV)match) > value)
2619 --match; /* was fractional--truncate other way */
2621 match -= cCOP->uop.scop.scop_offset;
2624 else if (match > cCOP->uop.scop.scop_max)
2625 match = cCOP->uop.scop.scop_max;
2626 PL_op = cCOP->uop.scop.scop_next[match];
2636 PL_op = PL_op->op_next; /* can't assume anything */
2639 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2640 match -= cCOP->uop.scop.scop_offset;
2643 else if (match > cCOP->uop.scop.scop_max)
2644 match = cCOP->uop.scop.scop_max;
2645 PL_op = cCOP->uop.scop.scop_next[match];
2654 S_save_lines(pTHX_ AV *array, SV *sv)
2656 register char *s = SvPVX(sv);
2657 register char *send = SvPVX(sv) + SvCUR(sv);
2659 register I32 line = 1;
2661 while (s && s < send) {
2662 SV *tmpstr = NEWSV(85,0);
2664 sv_upgrade(tmpstr, SVt_PVMG);
2665 t = strchr(s, '\n');
2671 sv_setpvn(tmpstr, s, t - s);
2672 av_store(array, line++, tmpstr);
2677 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2679 S_docatch_body(pTHX_ va_list args)
2681 return docatch_body();
2686 S_docatch_body(pTHX)
2693 S_docatch(pTHX_ OP *o)
2698 volatile PERL_SI *cursi = PL_curstackinfo;
2702 assert(CATCH_GET == TRUE);
2706 /* Normally, the leavetry at the end of this block of ops will
2707 * pop an op off the return stack and continue there. By setting
2708 * the op to Nullop, we force an exit from the inner runops()
2711 assert(cxstack_ix >= 0);
2712 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2713 retop = cxstack[cxstack_ix].blk_eval.retop;
2714 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2716 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2718 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2724 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2730 /* die caught by an inner eval - continue inner loop */
2731 if (PL_restartop && cursi == PL_curstackinfo) {
2732 PL_op = PL_restartop;
2736 /* a die in this eval - continue in outer loop */
2752 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2753 /* sv Text to convert to OP tree. */
2754 /* startop op_free() this to undo. */
2755 /* code Short string id of the caller. */
2757 dSP; /* Make POPBLOCK work. */
2760 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2764 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2765 char *tmpbuf = tbuf;
2768 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2773 /* switch to eval mode */
2775 if (IN_PERL_COMPILETIME) {
2776 SAVECOPSTASH_FREE(&PL_compiling);
2777 CopSTASH_set(&PL_compiling, PL_curstash);
2779 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2780 SV *sv = sv_newmortal();
2781 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2782 code, (unsigned long)++PL_evalseq,
2783 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2787 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2788 SAVECOPFILE_FREE(&PL_compiling);
2789 CopFILE_set(&PL_compiling, tmpbuf+2);
2790 SAVECOPLINE(&PL_compiling);
2791 CopLINE_set(&PL_compiling, 1);
2792 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2793 deleting the eval's FILEGV from the stash before gv_check() runs
2794 (i.e. before run-time proper). To work around the coredump that
2795 ensues, we always turn GvMULTI_on for any globals that were
2796 introduced within evals. See force_ident(). GSAR 96-10-12 */
2797 safestr = savepv(tmpbuf);
2798 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2800 #ifdef OP_IN_REGISTER
2806 /* we get here either during compilation, or via pp_regcomp at runtime */
2807 runtime = IN_PERL_RUNTIME;
2809 runcv = find_runcv(NULL);
2812 PL_op->op_type = OP_ENTEREVAL;
2813 PL_op->op_flags = 0; /* Avoid uninit warning. */
2814 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2815 PUSHEVAL(cx, 0, Nullgv);
2818 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2820 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2821 POPBLOCK(cx,PL_curpm);
2824 (*startop)->op_type = OP_NULL;
2825 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2827 /* XXX DAPM do this properly one year */
2828 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2830 if (IN_PERL_COMPILETIME)
2831 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2832 #ifdef OP_IN_REGISTER
2840 =for apidoc find_runcv
2842 Locate the CV corresponding to the currently executing sub or eval.
2843 If db_seqp is non_null, skip CVs that are in the DB package and populate
2844 *db_seqp with the cop sequence number at the point that the DB:: code was
2845 entered. (allows debuggers to eval in the scope of the breakpoint rather
2846 than in in the scope of the debugger itself).
2852 Perl_find_runcv(pTHX_ U32 *db_seqp)
2859 *db_seqp = PL_curcop->cop_seq;
2860 for (si = PL_curstackinfo; si; si = si->si_prev) {
2861 for (ix = si->si_cxix; ix >= 0; ix--) {
2862 cx = &(si->si_cxstack[ix]);
2863 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2864 CV *cv = cx->blk_sub.cv;
2865 /* skip DB:: code */
2866 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2867 *db_seqp = cx->blk_oldcop->cop_seq;
2872 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2880 /* Compile a require/do, an eval '', or a /(?{...})/.
2881 * In the last case, startop is non-null, and contains the address of
2882 * a pointer that should be set to the just-compiled code.
2883 * outside is the lexically enclosing CV (if any) that invoked us.
2886 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2888 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2893 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2894 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2899 SAVESPTR(PL_compcv);
2900 PL_compcv = (CV*)NEWSV(1104,0);
2901 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2902 CvEVAL_on(PL_compcv);
2903 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2904 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2906 CvOUTSIDE_SEQ(PL_compcv) = seq;
2907 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2909 /* set up a scratch pad */
2911 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2914 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2916 /* make sure we compile in the right package */
2918 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2919 SAVESPTR(PL_curstash);
2920 PL_curstash = CopSTASH(PL_curcop);
2922 SAVESPTR(PL_beginav);
2923 PL_beginav = newAV();
2924 SAVEFREESV(PL_beginav);
2925 SAVEI32(PL_error_count);
2927 /* try to compile it */
2929 PL_eval_root = Nullop;
2931 PL_curcop = &PL_compiling;
2932 PL_curcop->cop_arybase = 0;
2933 if (saveop && saveop->op_flags & OPf_SPECIAL)
2934 PL_in_eval |= EVAL_KEEPERR;
2937 if (yyparse() || PL_error_count || !PL_eval_root) {
2938 SV **newsp; /* Used by POPBLOCK. */
2939 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2940 I32 optype = 0; /* Might be reset by POPEVAL. */
2945 op_free(PL_eval_root);
2946 PL_eval_root = Nullop;
2948 SP = PL_stack_base + POPMARK; /* pop original mark */
2950 POPBLOCK(cx,PL_curpm);
2955 if (optype == OP_REQUIRE) {
2956 char* msg = SvPVx(ERRSV, n_a);
2957 SV *nsv = cx->blk_eval.old_namesv;
2958 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2960 DIE(aTHX_ "%sCompilation failed in require",
2961 *msg ? msg : "Unknown error\n");
2964 char* msg = SvPVx(ERRSV, n_a);
2966 POPBLOCK(cx,PL_curpm);
2968 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2969 (*msg ? msg : "Unknown error\n"));
2972 char* msg = SvPVx(ERRSV, n_a);
2974 sv_setpv(ERRSV, "Compilation error");
2979 CopLINE_set(&PL_compiling, 0);
2981 *startop = PL_eval_root;
2983 SAVEFREEOP(PL_eval_root);
2985 /* Set the context for this new optree.
2986 * If the last op is an OP_REQUIRE, force scalar context.
2987 * Otherwise, propagate the context from the eval(). */
2988 if (PL_eval_root->op_type == OP_LEAVEEVAL
2989 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2990 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2992 scalar(PL_eval_root);
2993 else if (gimme & G_VOID)
2994 scalarvoid(PL_eval_root);
2995 else if (gimme & G_ARRAY)
2998 scalar(PL_eval_root);
3000 DEBUG_x(dump_eval());
3002 /* Register with debugger: */
3003 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3004 CV *cv = get_cv("DB::postponed", FALSE);
3008 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3010 call_sv((SV*)cv, G_DISCARD);
3014 /* compiled okay, so do it */
3016 CvDEPTH(PL_compcv) = 1;
3017 SP = PL_stack_base + POPMARK; /* pop original mark */
3018 PL_op = saveop; /* The caller may need it. */
3019 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3021 RETURNOP(PL_eval_start);
3025 S_doopen_pm(pTHX_ const char *name, const char *mode)
3027 #ifndef PERL_DISABLE_PMC
3028 STRLEN namelen = strlen(name);
3031 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3032 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3033 char *pmc = SvPV_nolen(pmcsv);
3036 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037 fp = PerlIO_open(name, mode);
3040 if (PerlLIO_stat(name, &pmstat) < 0 ||
3041 pmstat.st_mtime < pmcstat.st_mtime)
3043 fp = PerlIO_open(pmc, mode);
3046 fp = PerlIO_open(name, mode);
3049 SvREFCNT_dec(pmcsv);
3052 fp = PerlIO_open(name, mode);
3056 return PerlIO_open(name, mode);
3057 #endif /* !PERL_DISABLE_PMC */
3063 register PERL_CONTEXT *cx;
3067 char *tryname = Nullch;
3068 SV *namesv = Nullsv;
3070 I32 gimme = GIMME_V;
3071 PerlIO *tryrsfp = 0;
3073 int filter_has_file = 0;
3074 GV *filter_child_proc = 0;
3075 SV *filter_state = 0;
3082 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3083 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3084 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3085 "v-string in use/require non-portable");
3087 sv = new_version(sv);
3088 if (!sv_derived_from(PL_patchlevel, "version"))
3089 (void *)upg_version(PL_patchlevel);
3090 if ( vcmp(sv,PL_patchlevel) > 0 )
3091 DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
3092 vstringify(sv), vstringify(PL_patchlevel));
3096 name = SvPV(sv, len);
3097 if (!(name && len > 0 && *name))
3098 DIE(aTHX_ "Null filename used");
3099 TAINT_PROPER("require");
3100 if (PL_op->op_type == OP_REQUIRE &&
3101 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3102 if (*svp != &PL_sv_undef)
3105 DIE(aTHX_ "Compilation failed in require");
3108 /* prepare to compile file */
3110 if (path_is_absolute(name)) {
3112 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3114 #ifdef MACOS_TRADITIONAL
3118 MacPerl_CanonDir(name, newname, 1);
3119 if (path_is_absolute(newname)) {
3121 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3126 AV *ar = GvAVn(PL_incgv);
3130 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3133 namesv = NEWSV(806, 0);
3134 for (i = 0; i <= AvFILL(ar); i++) {
3135 SV *dirsv = *av_fetch(ar, i, TRUE);
3141 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3142 && !sv_isobject(loader))
3144 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3147 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3148 PTR2UV(SvRV(dirsv)), name);
3149 tryname = SvPVX(namesv);
3160 if (sv_isobject(loader))
3161 count = call_method("INC", G_ARRAY);
3163 count = call_sv(loader, G_ARRAY);
3173 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3177 if (SvTYPE(arg) == SVt_PVGV) {
3178 IO *io = GvIO((GV *)arg);
3183 tryrsfp = IoIFP(io);
3184 if (IoTYPE(io) == IoTYPE_PIPE) {
3185 /* reading from a child process doesn't
3186 nest -- when returning from reading
3187 the inner module, the outer one is
3188 unreadable (closed?) I've tried to
3189 save the gv to manage the lifespan of
3190 the pipe, but this didn't help. XXX */
3191 filter_child_proc = (GV *)arg;
3192 (void)SvREFCNT_inc(filter_child_proc);
3195 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3196 PerlIO_close(IoOFP(io));
3208 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3210 (void)SvREFCNT_inc(filter_sub);
3213 filter_state = SP[i];
3214 (void)SvREFCNT_inc(filter_state);
3218 tryrsfp = PerlIO_open("/dev/null",
3234 filter_has_file = 0;
3235 if (filter_child_proc) {
3236 SvREFCNT_dec(filter_child_proc);
3237 filter_child_proc = 0;
3240 SvREFCNT_dec(filter_state);
3244 SvREFCNT_dec(filter_sub);
3249 if (!path_is_absolute(name)
3250 #ifdef MACOS_TRADITIONAL
3251 /* We consider paths of the form :a:b ambiguous and interpret them first
3252 as global then as local
3254 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3257 char *dir = SvPVx(dirsv, n_a);
3258 #ifdef MACOS_TRADITIONAL
3262 MacPerl_CanonDir(name, buf2, 1);
3263 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3267 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3269 sv_setpv(namesv, unixdir);
3270 sv_catpv(namesv, unixname);
3272 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3275 TAINT_PROPER("require");
3276 tryname = SvPVX(namesv);
3277 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3279 if (tryname[0] == '.' && tryname[1] == '/')
3288 SAVECOPFILE_FREE(&PL_compiling);
3289 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3290 SvREFCNT_dec(namesv);
3292 if (PL_op->op_type == OP_REQUIRE) {
3293 char *msgstr = name;
3294 if (namesv) { /* did we lookup @INC? */
3295 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3296 SV *dirmsgsv = NEWSV(0, 0);
3297 AV *ar = GvAVn(PL_incgv);
3299 sv_catpvn(msg, " in @INC", 8);
3300 if (instr(SvPVX(msg), ".h "))
3301 sv_catpv(msg, " (change .h to .ph maybe?)");
3302 if (instr(SvPVX(msg), ".ph "))
3303 sv_catpv(msg, " (did you run h2ph?)");
3304 sv_catpv(msg, " (@INC contains:");
3305 for (i = 0; i <= AvFILL(ar); i++) {
3306 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3307 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3308 sv_catsv(msg, dirmsgsv);
3310 sv_catpvn(msg, ")", 1);
3311 SvREFCNT_dec(dirmsgsv);
3312 msgstr = SvPV_nolen(msg);
3314 DIE(aTHX_ "Can't locate %s", msgstr);
3320 SETERRNO(0, SS_NORMAL);
3322 /* Assume success here to prevent recursive requirement. */
3324 /* Check whether a hook in @INC has already filled %INC */
3325 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3326 (void)hv_store(GvHVn(PL_incgv), name, len,
3327 (hook_sv ? SvREFCNT_inc(hook_sv)
3328 : newSVpv(CopFILE(&PL_compiling), 0)),
3334 lex_start(sv_2mortal(newSVpvn("",0)));
3335 SAVEGENERICSV(PL_rsfp_filters);
3336 PL_rsfp_filters = Nullav;
3341 SAVESPTR(PL_compiling.cop_warnings);
3342 if (PL_dowarn & G_WARN_ALL_ON)
3343 PL_compiling.cop_warnings = pWARN_ALL ;
3344 else if (PL_dowarn & G_WARN_ALL_OFF)
3345 PL_compiling.cop_warnings = pWARN_NONE ;
3346 else if (PL_taint_warn)
3347 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3349 PL_compiling.cop_warnings = pWARN_STD ;
3350 SAVESPTR(PL_compiling.cop_io);
3351 PL_compiling.cop_io = Nullsv;
3353 if (filter_sub || filter_child_proc) {
3354 SV *datasv = filter_add(run_user_filter, Nullsv);
3355 IoLINES(datasv) = filter_has_file;
3356 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3357 IoTOP_GV(datasv) = (GV *)filter_state;
3358 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3361 /* switch to eval mode */
3362 PUSHBLOCK(cx, CXt_EVAL, SP);
3363 PUSHEVAL(cx, name, Nullgv);
3364 cx->blk_eval.retop = PL_op->op_next;
3366 SAVECOPLINE(&PL_compiling);
3367 CopLINE_set(&PL_compiling, 0);
3371 /* Store and reset encoding. */
3372 encoding = PL_encoding;
3373 PL_encoding = Nullsv;
3375 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3377 /* Restore encoding. */
3378 PL_encoding = encoding;
3385 return pp_require();
3391 register PERL_CONTEXT *cx;
3393 I32 gimme = GIMME_V, was = PL_sub_generation;
3394 char tbuf[TYPE_DIGITS(long) + 12];
3395 char *tmpbuf = tbuf;
3404 TAINT_PROPER("eval");
3410 /* switch to eval mode */
3412 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3413 SV *sv = sv_newmortal();
3414 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3415 (unsigned long)++PL_evalseq,
3416 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3420 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3421 SAVECOPFILE_FREE(&PL_compiling);
3422 CopFILE_set(&PL_compiling, tmpbuf+2);
3423 SAVECOPLINE(&PL_compiling);
3424 CopLINE_set(&PL_compiling, 1);
3425 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3426 deleting the eval's FILEGV from the stash before gv_check() runs
3427 (i.e. before run-time proper). To work around the coredump that
3428 ensues, we always turn GvMULTI_on for any globals that were
3429 introduced within evals. See force_ident(). GSAR 96-10-12 */
3430 safestr = savepv(tmpbuf);
3431 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3433 PL_hints = PL_op->op_targ;
3434 SAVESPTR(PL_compiling.cop_warnings);
3435 if (specialWARN(PL_curcop->cop_warnings))
3436 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3438 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3439 SAVEFREESV(PL_compiling.cop_warnings);
3441 SAVESPTR(PL_compiling.cop_io);
3442 if (specialCopIO(PL_curcop->cop_io))
3443 PL_compiling.cop_io = PL_curcop->cop_io;
3445 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3446 SAVEFREESV(PL_compiling.cop_io);
3448 /* special case: an eval '' executed within the DB package gets lexically
3449 * placed in the first non-DB CV rather than the current CV - this
3450 * allows the debugger to execute code, find lexicals etc, in the
3451 * scope of the code being debugged. Passing &seq gets find_runcv
3452 * to do the dirty work for us */
3453 runcv = find_runcv(&seq);
3455 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3456 PUSHEVAL(cx, 0, Nullgv);
3457 cx->blk_eval.retop = PL_op->op_next;
3459 /* prepare to compile string */
3461 if (PERLDB_LINE && PL_curstash != PL_debstash)
3462 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3464 ret = doeval(gimme, NULL, runcv, seq);
3465 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3466 && ret != PL_op->op_next) { /* Successive compilation. */
3467 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3469 return DOCATCH(ret);
3479 register PERL_CONTEXT *cx;
3481 U8 save_flags = PL_op -> op_flags;
3486 retop = cx->blk_eval.retop;
3489 if (gimme == G_VOID)
3491 else if (gimme == G_SCALAR) {
3494 if (SvFLAGS(TOPs) & SVs_TEMP)
3497 *MARK = sv_mortalcopy(TOPs);
3501 *MARK = &PL_sv_undef;
3506 /* in case LEAVE wipes old return values */
3507 for (mark = newsp + 1; mark <= SP; mark++) {
3508 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3509 *mark = sv_mortalcopy(*mark);
3510 TAINT_NOT; /* Each item is independent */
3514 PL_curpm = newpm; /* Don't pop $1 et al till now */
3517 assert(CvDEPTH(PL_compcv) == 1);
3519 CvDEPTH(PL_compcv) = 0;
3522 if (optype == OP_REQUIRE &&
3523 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3525 /* Unassume the success we assumed earlier. */
3526 SV *nsv = cx->blk_eval.old_namesv;
3527 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3528 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3529 /* die_where() did LEAVE, or we won't be here */
3533 if (!(save_flags & OPf_SPECIAL))
3543 register PERL_CONTEXT *cx;
3544 I32 gimme = GIMME_V;
3549 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3551 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3553 PL_in_eval = EVAL_INEVAL;
3556 return DOCATCH(PL_op->op_next);
3567 register PERL_CONTEXT *cx;
3572 retop = cx->blk_eval.retop;
3575 if (gimme == G_VOID)
3577 else if (gimme == G_SCALAR) {
3580 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3583 *MARK = sv_mortalcopy(TOPs);
3587 *MARK = &PL_sv_undef;
3592 /* in case LEAVE wipes old return values */
3593 for (mark = newsp + 1; mark <= SP; mark++) {
3594 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3595 *mark = sv_mortalcopy(*mark);
3596 TAINT_NOT; /* Each item is independent */
3600 PL_curpm = newpm; /* Don't pop $1 et al till now */
3608 S_doparseform(pTHX_ SV *sv)
3611 register char *s = SvPV_force(sv, len);
3612 register char *send = s + len;
3613 register char *base = Nullch;
3614 register I32 skipspaces = 0;
3615 bool noblank = FALSE;
3616 bool repeat = FALSE;
3617 bool postspace = FALSE;
3623 bool unchopnum = FALSE;
3624 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3627 Perl_croak(aTHX_ "Null picture in formline");
3629 /* estimate the buffer size needed */
3630 for (base = s; s <= send; s++) {
3631 if (*s == '\n' || *s == '@' || *s == '^')
3637 New(804, fops, maxops, U32);
3642 *fpc++ = FF_LINEMARK;
3643 noblank = repeat = FALSE;
3661 case ' ': case '\t':
3668 } /* else FALL THROUGH */
3676 *fpc++ = FF_LITERAL;
3684 *fpc++ = (U16)skipspaces;
3688 *fpc++ = FF_NEWLINE;
3692 arg = fpc - linepc + 1;
3699 *fpc++ = FF_LINEMARK;
3700 noblank = repeat = FALSE;
3709 ischop = s[-1] == '^';
3715 arg = (s - base) - 1;
3717 *fpc++ = FF_LITERAL;
3725 *fpc++ = 2; /* skip the @* or ^* */
3727 *fpc++ = FF_LINESNGL;
3730 *fpc++ = FF_LINEGLOB;
3732 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3733 arg = ischop ? 512 : 0;
3743 arg |= 256 + (s - f);
3745 *fpc++ = s - base; /* fieldsize for FETCH */
3746 *fpc++ = FF_DECIMAL;
3748 unchopnum |= ! ischop;
3750 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3751 arg = ischop ? 512 : 0;
3753 s++; /* skip the '0' first */
3762 arg |= 256 + (s - f);
3764 *fpc++ = s - base; /* fieldsize for FETCH */
3765 *fpc++ = FF_0DECIMAL;
3767 unchopnum |= ! ischop;
3771 bool ismore = FALSE;
3774 while (*++s == '>') ;
3775 prespace = FF_SPACE;
3777 else if (*s == '|') {
3778 while (*++s == '|') ;
3779 prespace = FF_HALFSPACE;
3784 while (*++s == '<') ;
3787 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3791 *fpc++ = s - base; /* fieldsize for FETCH */
3793 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3796 *fpc++ = (U16)prespace;
3810 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3812 { /* need to jump to the next word */
3814 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3815 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3816 s = SvPVX(sv) + SvCUR(sv) + z;
3818 Copy(fops, s, arg, U32);
3820 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3823 if (unchopnum && repeat)
3824 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3830 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3832 /* Can value be printed in fldsize chars, using %*.*f ? */
3836 int intsize = fldsize - (value < 0 ? 1 : 0);
3843 while (intsize--) pwr *= 10.0;
3844 while (frcsize--) eps /= 10.0;
3847 if (value + eps >= pwr)
3850 if (value - eps <= -pwr)
3857 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3859 SV *datasv = FILTER_DATA(idx);
3860 int filter_has_file = IoLINES(datasv);
3861 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3862 SV *filter_state = (SV *)IoTOP_GV(datasv);
3863 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3866 /* I was having segfault trouble under Linux 2.2.5 after a
3867 parse error occured. (Had to hack around it with a test
3868 for PL_error_count == 0.) Solaris doesn't segfault --
3869 not sure where the trouble is yet. XXX */
3871 if (filter_has_file) {
3872 len = FILTER_READ(idx+1, buf_sv, maxlen);
3875 if (filter_sub && len >= 0) {
3886 PUSHs(sv_2mortal(newSViv(maxlen)));
3888 PUSHs(filter_state);
3891 count = call_sv(filter_sub, G_SCALAR);
3907 IoLINES(datasv) = 0;
3908 if (filter_child_proc) {
3909 SvREFCNT_dec(filter_child_proc);
3910 IoFMT_GV(datasv) = Nullgv;
3913 SvREFCNT_dec(filter_state);
3914 IoTOP_GV(datasv) = Nullgv;
3917 SvREFCNT_dec(filter_sub);
3918 IoBOTTOM_GV(datasv) = Nullgv;
3920 filter_del(run_user_filter);
3926 /* perhaps someone can come up with a better name for
3927 this? it is not really "absolute", per se ... */
3929 S_path_is_absolute(pTHX_ char *name)
3931 if (PERL_FILE_IS_ABSOLUTE(name)
3932 #ifdef MACOS_TRADITIONAL
3935 || (*name == '.' && (name[1] == '/' ||
3936 (name[1] == '.' && name[2] == '/'))))