3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
161 PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
163 if (cx->sb_iters++) {
164 I32 saviters = cx->sb_iters;
165 if (cx->sb_iters > cx->sb_maxiters)
166 DIE(aTHX_ "Substitution loop");
168 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
169 cx->sb_rxtainted |= 2;
170 sv_catsv(dstr, POPs);
173 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
174 s == m, cx->sb_targ, NULL,
175 ((cx->sb_rflags & REXEC_COPY_STR)
176 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
177 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
179 SV *targ = cx->sb_targ;
181 sv_catpvn(dstr, s, cx->sb_strend - s);
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 (void)SvOOK_off(targ);
185 Safefree(SvPVX(targ));
186 SvPVX(targ) = SvPVX(dstr);
187 SvCUR_set(targ, SvCUR(dstr));
188 SvLEN_set(targ, SvLEN(dstr));
194 TAINT_IF(cx->sb_rxtainted & 1);
195 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
197 (void)SvPOK_only_UTF8(targ);
198 TAINT_IF(cx->sb_rxtainted);
202 LEAVE_SCOPE(cx->sb_oldsave);
204 RETURNOP(pm->op_next);
206 cx->sb_iters = saviters;
208 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
211 cx->sb_orig = orig = rx->subbeg;
213 cx->sb_strend = s + (cx->sb_strend - m);
215 cx->sb_m = m = rx->startp[0] + orig;
217 sv_catpvn(dstr, s, m-s);
218 cx->sb_s = rx->endp[0] + orig;
219 { /* Update the pos() information. */
220 SV *sv = cx->sb_targ;
223 if (SvTYPE(sv) < SVt_PVMG)
224 (void)SvUPGRADE(sv, SVt_PVMG);
225 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
226 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
227 mg = mg_find(sv, PERL_MAGIC_regex_global);
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
235 rxres_save(&cx->sb_rxres, rx);
236 RETURNOP(pm->op_pmreplstart);
240 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
245 if (!p || p[1] < rx->nparens) {
246 i = 6 + rx->nparens * 2;
254 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
255 RX_MATCH_COPIED_off(rx);
259 *p++ = PTR2UV(rx->subbeg);
260 *p++ = (UV)rx->sublen;
261 for (i = 0; i <= rx->nparens; ++i) {
262 *p++ = (UV)rx->startp[i];
263 *p++ = (UV)rx->endp[i];
268 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
273 if (RX_MATCH_COPIED(rx))
274 Safefree(rx->subbeg);
275 RX_MATCH_COPIED_set(rx, *p);
280 rx->subbeg = INT2PTR(char*,*p++);
281 rx->sublen = (I32)(*p++);
282 for (i = 0; i <= rx->nparens; ++i) {
283 rx->startp[i] = (I32)(*p++);
284 rx->endp[i] = (I32)(*p++);
289 Perl_rxres_free(pTHX_ void **rsp)
294 Safefree(INT2PTR(char*,*p));
302 dSP; dMARK; dORIGMARK;
303 register SV *tmpForm = *++MARK;
310 register SV *sv = Nullsv;
315 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
316 char *chophere = Nullch;
317 char *linemark = Nullch;
319 bool gotsome = FALSE;
321 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
322 bool item_is_utf = FALSE;
324 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
325 if (SvREADONLY(tmpForm)) {
326 SvREADONLY_off(tmpForm);
327 doparseform(tmpForm);
328 SvREADONLY_on(tmpForm);
331 doparseform(tmpForm);
334 SvPV_force(PL_formtarget, len);
335 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
337 f = SvPV(tmpForm, len);
338 /* need to jump to the next word */
339 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
348 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
349 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
350 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
351 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
352 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
354 case FF_CHECKNL: name = "CHECKNL"; break;
355 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
356 case FF_SPACE: name = "SPACE"; break;
357 case FF_HALFSPACE: name = "HALFSPACE"; break;
358 case FF_ITEM: name = "ITEM"; break;
359 case FF_CHOP: name = "CHOP"; break;
360 case FF_LINEGLOB: name = "LINEGLOB"; break;
361 case FF_NEWLINE: name = "NEWLINE"; break;
362 case FF_MORE: name = "MORE"; break;
363 case FF_LINEMARK: name = "LINEMARK"; break;
364 case FF_END: name = "END"; break;
365 case FF_0DECIMAL: name = "0DECIMAL"; break;
368 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
370 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
398 if (ckWARN(WARN_SYNTAX))
399 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
404 item = s = SvPV(sv, len);
407 itemsize = sv_len_utf8(sv);
408 if (itemsize != (I32)len) {
410 if (itemsize > fieldsize) {
411 itemsize = fieldsize;
412 itembytes = itemsize;
413 sv_pos_u2b(sv, &itembytes, 0);
417 send = chophere = s + itembytes;
427 sv_pos_b2u(sv, &itemsize);
432 if (itemsize > fieldsize)
433 itemsize = fieldsize;
434 send = chophere = s + itemsize;
446 item = s = SvPV(sv, len);
449 itemsize = sv_len_utf8(sv);
450 if (itemsize != (I32)len) {
452 if (itemsize <= fieldsize) {
453 send = chophere = s + itemsize;
464 itemsize = fieldsize;
465 itembytes = itemsize;
466 sv_pos_u2b(sv, &itembytes, 0);
467 send = chophere = s + itembytes;
468 while (s < send || (s == send && isSPACE(*s))) {
478 if (strchr(PL_chopset, *s))
483 itemsize = chophere - item;
484 sv_pos_b2u(sv, &itemsize);
491 if (itemsize <= fieldsize) {
492 send = chophere = s + itemsize;
503 itemsize = fieldsize;
504 send = chophere = s + itemsize;
505 while (s < send || (s == send && isSPACE(*s))) {
515 if (strchr(PL_chopset, *s))
520 itemsize = chophere - item;
525 arg = fieldsize - itemsize;
534 arg = fieldsize - itemsize;
548 if (UTF8_IS_CONTINUED(*s)) {
549 STRLEN skip = UTF8SKIP(s);
566 if ( !((*t++ = *s++) & ~31) )
574 int ch = *t++ = *s++;
577 if ( !((*t++ = *s++) & ~31) )
586 while (*s && isSPACE(*s))
593 item = s = SvPV(sv, len);
595 item_is_utf = FALSE; /* XXX is this correct? */
607 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
608 sv_catpvn(PL_formtarget, item, itemsize);
609 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
610 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
615 /* If the field is marked with ^ and the value is undefined,
618 if ((arg & 512) && !SvOK(sv)) {
626 /* Formats aren't yet marked for locales, so assume "yes". */
628 STORE_NUMERIC_STANDARD_SET_LOCAL();
629 #if defined(USE_LONG_DOUBLE)
631 sprintf(t, "%#*.*" PERL_PRIfldbl,
632 (int) fieldsize, (int) arg & 255, value);
634 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
639 (int) fieldsize, (int) arg & 255, value);
642 (int) fieldsize, value);
645 RESTORE_NUMERIC_STANDARD();
651 /* If the field is marked with ^ and the value is undefined,
654 if ((arg & 512) && !SvOK(sv)) {
662 /* Formats aren't yet marked for locales, so assume "yes". */
664 STORE_NUMERIC_STANDARD_SET_LOCAL();
665 #if defined(USE_LONG_DOUBLE)
667 sprintf(t, "%#0*.*" PERL_PRIfldbl,
668 (int) fieldsize, (int) arg & 255, value);
669 /* is this legal? I don't have long doubles */
671 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
675 sprintf(t, "%#0*.*f",
676 (int) fieldsize, (int) arg & 255, value);
679 (int) fieldsize, value);
682 RESTORE_NUMERIC_STANDARD();
689 while (t-- > linemark && *t == ' ') ;
697 if (arg) { /* repeat until fields exhausted? */
699 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
700 lines += FmLINES(PL_formtarget);
703 if (strnEQ(linemark, linemark - arg, arg))
704 DIE(aTHX_ "Runaway format");
706 FmLINES(PL_formtarget) = lines;
708 RETURNOP(cLISTOP->op_first);
721 while (*s && isSPACE(*s) && s < send)
725 arg = fieldsize - itemsize;
732 if (strnEQ(s," ",3)) {
733 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
744 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
745 FmLINES(PL_formtarget) += lines;
757 if (PL_stack_base + *PL_markstack_ptr == SP) {
759 if (GIMME_V == G_SCALAR)
760 XPUSHs(sv_2mortal(newSViv(0)));
761 RETURNOP(PL_op->op_next->op_next);
763 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
764 pp_pushmark(); /* push dst */
765 pp_pushmark(); /* push src */
766 ENTER; /* enter outer scope */
769 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
771 ENTER; /* enter inner scope */
774 src = PL_stack_base[*PL_markstack_ptr];
779 if (PL_op->op_type == OP_MAPSTART)
780 pp_pushmark(); /* push top */
781 return ((LOGOP*)PL_op->op_next)->op_other;
786 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
792 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
798 /* first, move source pointer to the next item in the source list */
799 ++PL_markstack_ptr[-1];
801 /* if there are new items, push them into the destination list */
803 /* might need to make room back there first */
804 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
805 /* XXX this implementation is very pessimal because the stack
806 * is repeatedly extended for every set of items. Is possible
807 * to do this without any stack extension or copying at all
808 * by maintaining a separate list over which the map iterates
809 * (like foreach does). --gsar */
811 /* everything in the stack after the destination list moves
812 * towards the end the stack by the amount of room needed */
813 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
815 /* items to shift up (accounting for the moved source pointer) */
816 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
818 /* This optimization is by Ben Tilly and it does
819 * things differently from what Sarathy (gsar)
820 * is describing. The downside of this optimization is
821 * that leaves "holes" (uninitialized and hopefully unused areas)
822 * to the Perl stack, but on the other hand this
823 * shouldn't be a problem. If Sarathy's idea gets
824 * implemented, this optimization should become
825 * irrelevant. --jhi */
827 shift = count; /* Avoid shifting too often --Ben Tilly */
832 PL_markstack_ptr[-1] += shift;
833 *PL_markstack_ptr += shift;
837 /* copy the new items down to the destination list */
838 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
840 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
842 LEAVE; /* exit inner scope */
845 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
848 (void)POPMARK; /* pop top */
849 LEAVE; /* exit outer scope */
850 (void)POPMARK; /* pop src */
851 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
852 (void)POPMARK; /* pop dst */
853 SP = PL_stack_base + POPMARK; /* pop original mark */
854 if (gimme == G_SCALAR) {
858 else if (gimme == G_ARRAY)
865 ENTER; /* enter inner scope */
868 /* set $_ to the new source item */
869 src = PL_stack_base[PL_markstack_ptr[-1]];
873 RETURNOP(cLOGOP->op_other);
881 if (GIMME == G_ARRAY)
883 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
884 return cLOGOP->op_other;
893 if (GIMME == G_ARRAY) {
894 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
898 SV *targ = PAD_SV(PL_op->op_targ);
901 if (PL_op->op_private & OPpFLIP_LINENUM) {
902 if (GvIO(PL_last_in_gv)) {
903 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
906 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
907 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
913 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
914 if (PL_op->op_flags & OPf_SPECIAL) {
922 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
935 if (GIMME == G_ARRAY) {
941 if (SvGMAGICAL(left))
943 if (SvGMAGICAL(right))
946 if (SvNIOKp(left) || !SvPOKp(left) ||
947 SvNIOKp(right) || !SvPOKp(right) ||
948 (looks_like_number(left) && *SvPVX(left) != '0' &&
949 looks_like_number(right) && *SvPVX(right) != '0'))
951 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
952 DIE(aTHX_ "Range iterator outside integer range");
963 sv = sv_2mortal(newSViv(i++));
968 SV *final = sv_mortalcopy(right);
970 char *tmps = SvPV(final, len);
972 sv = sv_mortalcopy(left);
974 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
976 if (strEQ(SvPVX(sv),tmps))
978 sv = sv_2mortal(newSVsv(sv));
985 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
989 if (PL_op->op_private & OPpFLIP_LINENUM) {
990 if (GvIO(PL_last_in_gv)) {
991 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
994 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
995 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1003 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1004 sv_catpv(targ, "E0");
1015 S_dopoptolabel(pTHX_ char *label)
1018 register PERL_CONTEXT *cx;
1020 for (i = cxstack_ix; i >= 0; i--) {
1022 switch (CxTYPE(cx)) {
1024 if (ckWARN(WARN_EXITING))
1025 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1029 if (ckWARN(WARN_EXITING))
1030 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1034 if (ckWARN(WARN_EXITING))
1035 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1039 if (ckWARN(WARN_EXITING))
1040 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1044 if (ckWARN(WARN_EXITING))
1045 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1049 if (!cx->blk_loop.label ||
1050 strNE(label, cx->blk_loop.label) ) {
1051 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1052 (long)i, cx->blk_loop.label));
1055 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1063 Perl_dowantarray(pTHX)
1065 I32 gimme = block_gimme();
1066 return (gimme == G_VOID) ? G_SCALAR : gimme;
1070 Perl_block_gimme(pTHX)
1074 cxix = dopoptosub(cxstack_ix);
1078 switch (cxstack[cxix].blk_gimme) {
1086 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1093 Perl_is_lvalue_sub(pTHX)
1097 cxix = dopoptosub(cxstack_ix);
1098 assert(cxix >= 0); /* We should only be called from inside subs */
1100 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1101 return cxstack[cxix].blk_sub.lval;
1107 S_dopoptosub(pTHX_ I32 startingblock)
1109 return dopoptosub_at(cxstack, startingblock);
1113 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1116 register PERL_CONTEXT *cx;
1117 for (i = startingblock; i >= 0; i--) {
1119 switch (CxTYPE(cx)) {
1125 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1133 S_dopoptoeval(pTHX_ I32 startingblock)
1136 register PERL_CONTEXT *cx;
1137 for (i = startingblock; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1143 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1151 S_dopoptoloop(pTHX_ I32 startingblock)
1154 register PERL_CONTEXT *cx;
1155 for (i = startingblock; i >= 0; i--) {
1157 switch (CxTYPE(cx)) {
1159 if (ckWARN(WARN_EXITING))
1160 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1164 if (ckWARN(WARN_EXITING))
1165 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1169 if (ckWARN(WARN_EXITING))
1170 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1174 if (ckWARN(WARN_EXITING))
1175 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1179 if (ckWARN(WARN_EXITING))
1180 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1184 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1192 Perl_dounwind(pTHX_ I32 cxix)
1194 register PERL_CONTEXT *cx;
1197 while (cxstack_ix > cxix) {
1199 cx = &cxstack[cxstack_ix];
1200 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1201 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1202 /* Note: we don't need to restore the base context info till the end. */
1203 switch (CxTYPE(cx)) {
1206 continue; /* not break */
1228 Perl_qerror(pTHX_ SV *err)
1231 sv_catsv(ERRSV, err);
1233 sv_catsv(PL_errors, err);
1235 Perl_warn(aTHX_ "%"SVf, err);
1240 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1248 register PERL_CONTEXT *cx;
1253 if (PL_in_eval & EVAL_KEEPERR) {
1254 static char prefix[] = "\t(in cleanup) ";
1259 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1262 if (*e != *message || strNE(e,message))
1266 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1267 sv_catpvn(err, prefix, sizeof(prefix)-1);
1268 sv_catpvn(err, message, msglen);
1269 if (ckWARN(WARN_MISC)) {
1270 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1271 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1276 sv_setpvn(ERRSV, message, msglen);
1280 message = SvPVx(ERRSV, msglen);
1282 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1283 && PL_curstackinfo->si_prev)
1292 if (cxix < cxstack_ix)
1295 POPBLOCK(cx,PL_curpm);
1296 if (CxTYPE(cx) != CXt_EVAL) {
1297 PerlIO_write(Perl_error_log, "panic: die ", 11);
1298 PerlIO_write(Perl_error_log, message, msglen);
1303 if (gimme == G_SCALAR)
1304 *++newsp = &PL_sv_undef;
1305 PL_stack_sp = newsp;
1309 /* LEAVE could clobber PL_curcop (see save_re_context())
1310 * XXX it might be better to find a way to avoid messing with
1311 * PL_curcop in save_re_context() instead, but this is a more
1312 * minimal fix --GSAR */
1313 PL_curcop = cx->blk_oldcop;
1315 if (optype == OP_REQUIRE) {
1316 char* msg = SvPVx(ERRSV, n_a);
1317 DIE(aTHX_ "%sCompilation failed in require",
1318 *msg ? msg : "Unknown error\n");
1320 return pop_return();
1324 message = SvPVx(ERRSV, msglen);
1326 /* if STDERR is tied, print to it instead */
1327 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1328 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1331 XPUSHs(SvTIED_obj((SV*)io, mg));
1332 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1334 call_method("PRINT", G_SCALAR);
1339 /* SFIO can really mess with your errno */
1342 PerlIO *serr = Perl_error_log;
1344 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1345 (void)PerlIO_flush(serr);
1358 if (SvTRUE(left) != SvTRUE(right))
1370 RETURNOP(cLOGOP->op_other);
1379 RETURNOP(cLOGOP->op_other);
1388 if (!sv || !SvANY(sv)) {
1389 RETURNOP(cLOGOP->op_other);
1392 switch (SvTYPE(sv)) {
1394 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1398 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1402 if (CvROOT(sv) || CvXSUB(sv))
1412 RETURNOP(cLOGOP->op_other);
1418 register I32 cxix = dopoptosub(cxstack_ix);
1419 register PERL_CONTEXT *cx;
1420 register PERL_CONTEXT *ccstack = cxstack;
1421 PERL_SI *top_si = PL_curstackinfo;
1432 /* we may be in a higher stacklevel, so dig down deeper */
1433 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1434 top_si = top_si->si_prev;
1435 ccstack = top_si->si_cxstack;
1436 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1439 if (GIMME != G_ARRAY) {
1445 if (PL_DBsub && cxix >= 0 &&
1446 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1450 cxix = dopoptosub_at(ccstack, cxix - 1);
1453 cx = &ccstack[cxix];
1454 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1455 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1456 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1457 field below is defined for any cx. */
1458 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1459 cx = &ccstack[dbcxix];
1462 stashname = CopSTASHPV(cx->blk_oldcop);
1463 if (GIMME != G_ARRAY) {
1466 PUSHs(&PL_sv_undef);
1469 sv_setpv(TARG, stashname);
1478 PUSHs(&PL_sv_undef);
1480 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1481 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1482 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1485 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1486 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1487 /* So is ccstack[dbcxix]. */
1490 gv_efullname3(sv, cvgv, Nullch);
1491 PUSHs(sv_2mortal(sv));
1492 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1495 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1496 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1500 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1501 PUSHs(sv_2mortal(newSViv(0)));
1503 gimme = (I32)cx->blk_gimme;
1504 if (gimme == G_VOID)
1505 PUSHs(&PL_sv_undef);
1507 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1508 if (CxTYPE(cx) == CXt_EVAL) {
1510 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1511 PUSHs(cx->blk_eval.cur_text);
1515 else if (cx->blk_eval.old_namesv) {
1516 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1519 /* eval BLOCK (try blocks have old_namesv == 0) */
1521 PUSHs(&PL_sv_undef);
1522 PUSHs(&PL_sv_undef);
1526 PUSHs(&PL_sv_undef);
1527 PUSHs(&PL_sv_undef);
1529 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1530 && CopSTASH_eq(PL_curcop, PL_debstash))
1532 AV *ary = cx->blk_sub.argarray;
1533 int off = AvARRAY(ary) - AvALLOC(ary);
1537 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1540 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1543 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1544 av_extend(PL_dbargs, AvFILLp(ary) + off);
1545 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1546 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1548 /* XXX only hints propagated via op_private are currently
1549 * visible (others are not easily accessible, since they
1550 * use the global PL_hints) */
1551 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1552 HINT_PRIVATE_MASK)));
1555 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1557 if (old_warnings == pWARN_NONE ||
1558 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1559 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1560 else if (old_warnings == pWARN_ALL ||
1561 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1562 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1564 mask = newSVsv(old_warnings);
1565 PUSHs(sv_2mortal(mask));
1580 sv_reset(tmps, CopSTASH(PL_curcop));
1590 /* like pp_nextstate, but used instead when the debugger is active */
1594 PL_curcop = (COP*)PL_op;
1595 TAINT_NOT; /* Each statement is presumed innocent */
1596 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1599 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1603 register PERL_CONTEXT *cx;
1604 I32 gimme = G_ARRAY;
1611 DIE(aTHX_ "No DB::DB routine defined");
1613 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1614 /* don't do recursive DB::DB call */
1626 push_return(PL_op->op_next);
1627 PUSHBLOCK(cx, CXt_SUB, SP);
1630 (void)SvREFCNT_inc(cv);
1631 PAD_SET_CUR(CvPADLIST(cv),1);
1632 RETURNOP(CvSTART(cv));
1646 register PERL_CONTEXT *cx;
1647 I32 gimme = GIMME_V;
1649 U32 cxtype = CXt_LOOP;
1657 if (PL_op->op_targ) {
1658 #ifndef USE_ITHREADS
1659 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1662 SAVEPADSV(PL_op->op_targ);
1663 iterdata = INT2PTR(void*, PL_op->op_targ);
1664 cxtype |= CXp_PADVAR;
1669 svp = &GvSV(gv); /* symbol table variable */
1670 SAVEGENERICSV(*svp);
1673 iterdata = (void*)gv;
1679 PUSHBLOCK(cx, cxtype, SP);
1681 PUSHLOOP(cx, iterdata, MARK);
1683 PUSHLOOP(cx, svp, MARK);
1685 if (PL_op->op_flags & OPf_STACKED) {
1686 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1687 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1689 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1690 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1691 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1692 looks_like_number((SV*)cx->blk_loop.iterary) &&
1693 *SvPVX(cx->blk_loop.iterary) != '0'))
1695 if (SvNV(sv) < IV_MIN ||
1696 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1697 DIE(aTHX_ "Range iterator outside integer range");
1698 cx->blk_loop.iterix = SvIV(sv);
1699 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1702 cx->blk_loop.iterlval = newSVsv(sv);
1706 cx->blk_loop.iterary = PL_curstack;
1707 AvFILLp(PL_curstack) = SP - PL_stack_base;
1708 cx->blk_loop.iterix = MARK - PL_stack_base;
1717 register PERL_CONTEXT *cx;
1718 I32 gimme = GIMME_V;
1724 PUSHBLOCK(cx, CXt_LOOP, SP);
1725 PUSHLOOP(cx, 0, SP);
1733 register PERL_CONTEXT *cx;
1741 newsp = PL_stack_base + cx->blk_loop.resetsp;
1744 if (gimme == G_VOID)
1746 else if (gimme == G_SCALAR) {
1748 *++newsp = sv_mortalcopy(*SP);
1750 *++newsp = &PL_sv_undef;
1754 *++newsp = sv_mortalcopy(*++mark);
1755 TAINT_NOT; /* Each item is independent */
1761 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1762 PL_curpm = newpm; /* ... and pop $1 et al */
1774 register PERL_CONTEXT *cx;
1775 bool popsub2 = FALSE;
1776 bool clear_errsv = FALSE;
1783 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1784 if (cxstack_ix == PL_sortcxix
1785 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1787 if (cxstack_ix > PL_sortcxix)
1788 dounwind(PL_sortcxix);
1789 AvARRAY(PL_curstack)[1] = *SP;
1790 PL_stack_sp = PL_stack_base + 1;
1795 cxix = dopoptosub(cxstack_ix);
1797 DIE(aTHX_ "Can't return outside a subroutine");
1798 if (cxix < cxstack_ix)
1802 switch (CxTYPE(cx)) {
1807 if (!(PL_in_eval & EVAL_KEEPERR))
1813 if (optype == OP_REQUIRE &&
1814 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1816 /* Unassume the success we assumed earlier. */
1817 SV *nsv = cx->blk_eval.old_namesv;
1818 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1819 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1826 DIE(aTHX_ "panic: return");
1830 if (gimme == G_SCALAR) {
1833 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1835 *++newsp = SvREFCNT_inc(*SP);
1840 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1842 *++newsp = sv_mortalcopy(sv);
1847 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1850 *++newsp = sv_mortalcopy(*SP);
1853 *++newsp = &PL_sv_undef;
1855 else if (gimme == G_ARRAY) {
1856 while (++MARK <= SP) {
1857 *++newsp = (popsub2 && SvTEMP(*MARK))
1858 ? *MARK : sv_mortalcopy(*MARK);
1859 TAINT_NOT; /* Each item is independent */
1862 PL_stack_sp = newsp;
1864 /* Stack values are safe: */
1866 POPSUB(cx,sv); /* release CV and @_ ... */
1870 PL_curpm = newpm; /* ... and pop $1 et al */
1876 return pop_return();
1883 register PERL_CONTEXT *cx;
1893 if (PL_op->op_flags & OPf_SPECIAL) {
1894 cxix = dopoptoloop(cxstack_ix);
1896 DIE(aTHX_ "Can't \"last\" outside a loop block");
1899 cxix = dopoptolabel(cPVOP->op_pv);
1901 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1903 if (cxix < cxstack_ix)
1908 switch (CxTYPE(cx)) {
1911 newsp = PL_stack_base + cx->blk_loop.resetsp;
1912 nextop = cx->blk_loop.last_op->op_next;
1916 nextop = pop_return();
1920 nextop = pop_return();
1924 nextop = pop_return();
1927 DIE(aTHX_ "panic: last");
1931 if (gimme == G_SCALAR) {
1933 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1934 ? *SP : sv_mortalcopy(*SP);
1936 *++newsp = &PL_sv_undef;
1938 else if (gimme == G_ARRAY) {
1939 while (++MARK <= SP) {
1940 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1941 ? *MARK : sv_mortalcopy(*MARK);
1942 TAINT_NOT; /* Each item is independent */
1948 /* Stack values are safe: */
1951 POPLOOP(cx); /* release loop vars ... */
1955 POPSUB(cx,sv); /* release CV and @_ ... */
1958 PL_curpm = newpm; /* ... and pop $1 et al */
1968 register PERL_CONTEXT *cx;
1971 if (PL_op->op_flags & OPf_SPECIAL) {
1972 cxix = dopoptoloop(cxstack_ix);
1974 DIE(aTHX_ "Can't \"next\" outside a loop block");
1977 cxix = dopoptolabel(cPVOP->op_pv);
1979 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1981 if (cxix < cxstack_ix)
1984 /* clear off anything above the scope we're re-entering, but
1985 * save the rest until after a possible continue block */
1986 inner = PL_scopestack_ix;
1988 if (PL_scopestack_ix < inner)
1989 leave_scope(PL_scopestack[PL_scopestack_ix]);
1990 return cx->blk_loop.next_op;
1996 register PERL_CONTEXT *cx;
1999 if (PL_op->op_flags & OPf_SPECIAL) {
2000 cxix = dopoptoloop(cxstack_ix);
2002 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2005 cxix = dopoptolabel(cPVOP->op_pv);
2007 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2009 if (cxix < cxstack_ix)
2013 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2014 LEAVE_SCOPE(oldsave);
2015 return cx->blk_loop.redo_op;
2019 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2023 static char too_deep[] = "Target of goto is too deeply nested";
2026 Perl_croak(aTHX_ too_deep);
2027 if (o->op_type == OP_LEAVE ||
2028 o->op_type == OP_SCOPE ||
2029 o->op_type == OP_LEAVELOOP ||
2030 o->op_type == OP_LEAVETRY)
2032 *ops++ = cUNOPo->op_first;
2034 Perl_croak(aTHX_ too_deep);
2037 if (o->op_flags & OPf_KIDS) {
2038 /* First try all the kids at this level, since that's likeliest. */
2039 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2040 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2041 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2044 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2045 if (kid == PL_lastgotoprobe)
2047 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2049 (ops[-1]->op_type != OP_NEXTSTATE &&
2050 ops[-1]->op_type != OP_DBSTATE)))
2052 if ((o = dofindlabel(kid, label, ops, oplimit)))
2071 register PERL_CONTEXT *cx;
2072 #define GOTO_DEPTH 64
2073 OP *enterops[GOTO_DEPTH];
2075 int do_dump = (PL_op->op_type == OP_DUMP);
2076 static char must_have_label[] = "goto must have label";
2079 if (PL_op->op_flags & OPf_STACKED) {
2083 /* This egregious kludge implements goto &subroutine */
2084 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2086 register PERL_CONTEXT *cx;
2087 CV* cv = (CV*)SvRV(sv);
2093 if (!CvROOT(cv) && !CvXSUB(cv)) {
2098 /* autoloaded stub? */
2099 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2101 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2102 GvNAMELEN(gv), FALSE);
2103 if (autogv && (cv = GvCV(autogv)))
2105 tmpstr = sv_newmortal();
2106 gv_efullname3(tmpstr, gv, Nullch);
2107 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2109 DIE(aTHX_ "Goto undefined subroutine");
2112 /* First do some returnish stuff. */
2113 cxix = dopoptosub(cxstack_ix);
2115 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2116 if (cxix < cxstack_ix)
2120 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2122 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2123 /* put @_ back onto stack */
2124 AV* av = cx->blk_sub.argarray;
2126 items = AvFILLp(av) + 1;
2128 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2129 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2130 PL_stack_sp += items;
2131 SvREFCNT_dec(GvAV(PL_defgv));
2132 GvAV(PL_defgv) = cx->blk_sub.savearray;
2133 /* abandon @_ if it got reified */
2135 (void)sv_2mortal((SV*)av); /* delay until return */
2137 av_extend(av, items-1);
2138 AvFLAGS(av) = AVf_REIFY;
2139 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2142 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2144 av = GvAV(PL_defgv);
2145 items = AvFILLp(av) + 1;
2147 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2148 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2149 PL_stack_sp += items;
2151 if (CxTYPE(cx) == CXt_SUB &&
2152 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2153 SvREFCNT_dec(cx->blk_sub.cv);
2154 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2155 LEAVE_SCOPE(oldsave);
2157 /* Now do some callish stuff. */
2160 #ifdef PERL_XSUB_OLDSTYLE
2161 if (CvOLDSTYLE(cv)) {
2162 I32 (*fp3)(int,int,int);
2167 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2168 items = (*fp3)(CvXSUBANY(cv).any_i32,
2169 mark - PL_stack_base + 1,
2171 SP = PL_stack_base + items;
2174 #endif /* PERL_XSUB_OLDSTYLE */
2179 PL_stack_sp--; /* There is no cv arg. */
2180 /* Push a mark for the start of arglist */
2182 (void)(*CvXSUB(cv))(aTHX_ cv);
2183 /* Pop the current context like a decent sub should */
2184 POPBLOCK(cx, PL_curpm);
2185 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2188 return pop_return();
2191 AV* padlist = CvPADLIST(cv);
2192 if (CxTYPE(cx) == CXt_EVAL) {
2193 PL_in_eval = cx->blk_eval.old_in_eval;
2194 PL_eval_root = cx->blk_eval.old_eval_root;
2195 cx->cx_type = CXt_SUB;
2196 cx->blk_sub.hasargs = 0;
2198 cx->blk_sub.cv = cv;
2199 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2202 if (CvDEPTH(cv) < 2)
2203 (void)SvREFCNT_inc(cv);
2205 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2206 sub_crush_depth(cv);
2207 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2209 PAD_SET_CUR(padlist, CvDEPTH(cv));
2210 if (cx->blk_sub.hasargs)
2212 AV* av = (AV*)PAD_SVl(0);
2215 cx->blk_sub.savearray = GvAV(PL_defgv);
2216 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2217 CX_CURPAD_SAVE(cx->blk_sub);
2218 cx->blk_sub.argarray = av;
2221 if (items >= AvMAX(av) + 1) {
2223 if (AvARRAY(av) != ary) {
2224 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2225 SvPVX(av) = (char*)ary;
2227 if (items >= AvMAX(av) + 1) {
2228 AvMAX(av) = items - 1;
2229 Renew(ary,items+1,SV*);
2231 SvPVX(av) = (char*)ary;
2234 Copy(mark,AvARRAY(av),items,SV*);
2235 AvFILLp(av) = items - 1;
2236 assert(!AvREAL(av));
2243 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2245 * We do not care about using sv to call CV;
2246 * it's for informational purposes only.
2248 SV *sv = GvSV(PL_DBsub);
2251 if (PERLDB_SUB_NN) {
2252 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2255 gv_efullname3(sv, CvGV(cv), Nullch);
2258 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2259 PUSHMARK( PL_stack_sp );
2260 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2264 RETURNOP(CvSTART(cv));
2268 label = SvPV(sv,n_a);
2269 if (!(do_dump || *label))
2270 DIE(aTHX_ must_have_label);
2273 else if (PL_op->op_flags & OPf_SPECIAL) {
2275 DIE(aTHX_ must_have_label);
2278 label = cPVOP->op_pv;
2280 if (label && *label) {
2282 bool leaving_eval = FALSE;
2283 PERL_CONTEXT *last_eval_cx = 0;
2287 PL_lastgotoprobe = 0;
2289 for (ix = cxstack_ix; ix >= 0; ix--) {
2291 switch (CxTYPE(cx)) {
2293 leaving_eval = TRUE;
2294 if (CxREALEVAL(cx)) {
2295 gotoprobe = (last_eval_cx ?
2296 last_eval_cx->blk_eval.old_eval_root :
2301 /* else fall through */
2303 gotoprobe = cx->blk_oldcop->op_sibling;
2309 gotoprobe = cx->blk_oldcop->op_sibling;
2311 gotoprobe = PL_main_root;
2314 if (CvDEPTH(cx->blk_sub.cv)) {
2315 gotoprobe = CvROOT(cx->blk_sub.cv);
2321 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2324 DIE(aTHX_ "panic: goto");
2325 gotoprobe = PL_main_root;
2329 retop = dofindlabel(gotoprobe, label,
2330 enterops, enterops + GOTO_DEPTH);
2334 PL_lastgotoprobe = gotoprobe;
2337 DIE(aTHX_ "Can't find label %s", label);
2339 /* if we're leaving an eval, check before we pop any frames
2340 that we're not going to punt, otherwise the error
2343 if (leaving_eval && *enterops && enterops[1]) {
2345 for (i = 1; enterops[i]; i++)
2346 if (enterops[i]->op_type == OP_ENTERITER)
2347 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2350 /* pop unwanted frames */
2352 if (ix < cxstack_ix) {
2359 oldsave = PL_scopestack[PL_scopestack_ix];
2360 LEAVE_SCOPE(oldsave);
2363 /* push wanted frames */
2365 if (*enterops && enterops[1]) {
2367 for (ix = 1; enterops[ix]; ix++) {
2368 PL_op = enterops[ix];
2369 /* Eventually we may want to stack the needed arguments
2370 * for each op. For now, we punt on the hard ones. */
2371 if (PL_op->op_type == OP_ENTERITER)
2372 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2373 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2381 if (!retop) retop = PL_main_start;
2383 PL_restartop = retop;
2384 PL_do_undump = TRUE;
2388 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2389 PL_do_undump = FALSE;
2405 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2407 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2410 PL_exit_flags |= PERL_EXIT_EXPECTED;
2412 PUSHs(&PL_sv_undef);
2420 NV value = SvNVx(GvSV(cCOP->cop_gv));
2421 register I32 match = I_32(value);
2424 if (((NV)match) > value)
2425 --match; /* was fractional--truncate other way */
2427 match -= cCOP->uop.scop.scop_offset;
2430 else if (match > cCOP->uop.scop.scop_max)
2431 match = cCOP->uop.scop.scop_max;
2432 PL_op = cCOP->uop.scop.scop_next[match];
2442 PL_op = PL_op->op_next; /* can't assume anything */
2445 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2446 match -= cCOP->uop.scop.scop_offset;
2449 else if (match > cCOP->uop.scop.scop_max)
2450 match = cCOP->uop.scop.scop_max;
2451 PL_op = cCOP->uop.scop.scop_next[match];
2460 S_save_lines(pTHX_ AV *array, SV *sv)
2462 register char *s = SvPVX(sv);
2463 register char *send = SvPVX(sv) + SvCUR(sv);
2465 register I32 line = 1;
2467 while (s && s < send) {
2468 SV *tmpstr = NEWSV(85,0);
2470 sv_upgrade(tmpstr, SVt_PVMG);
2471 t = strchr(s, '\n');
2477 sv_setpvn(tmpstr, s, t - s);
2478 av_store(array, line++, tmpstr);
2483 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2485 S_docatch_body(pTHX_ va_list args)
2487 return docatch_body();
2492 S_docatch_body(pTHX)
2499 S_docatch(pTHX_ OP *o)
2504 volatile PERL_SI *cursi = PL_curstackinfo;
2508 assert(CATCH_GET == TRUE);
2512 /* Normally, the leavetry at the end of this block of ops will
2513 * pop an op off the return stack and continue there. By setting
2514 * the op to Nullop, we force an exit from the inner runops()
2517 retop = pop_return();
2518 push_return(Nullop);
2520 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2522 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2528 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2534 /* die caught by an inner eval - continue inner loop */
2535 if (PL_restartop && cursi == PL_curstackinfo) {
2536 PL_op = PL_restartop;
2540 /* a die in this eval - continue in outer loop */
2556 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2557 /* sv Text to convert to OP tree. */
2558 /* startop op_free() this to undo. */
2559 /* code Short string id of the caller. */
2561 dSP; /* Make POPBLOCK work. */
2564 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2568 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2569 char *tmpbuf = tbuf;
2575 /* switch to eval mode */
2577 if (PL_curcop == &PL_compiling) {
2578 SAVECOPSTASH_FREE(&PL_compiling);
2579 CopSTASH_set(&PL_compiling, PL_curstash);
2581 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2582 SV *sv = sv_newmortal();
2583 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2584 code, (unsigned long)++PL_evalseq,
2585 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2589 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2590 SAVECOPFILE_FREE(&PL_compiling);
2591 CopFILE_set(&PL_compiling, tmpbuf+2);
2592 SAVECOPLINE(&PL_compiling);
2593 CopLINE_set(&PL_compiling, 1);
2594 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2595 deleting the eval's FILEGV from the stash before gv_check() runs
2596 (i.e. before run-time proper). To work around the coredump that
2597 ensues, we always turn GvMULTI_on for any globals that were
2598 introduced within evals. See force_ident(). GSAR 96-10-12 */
2599 safestr = savepv(tmpbuf);
2600 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2602 #ifdef OP_IN_REGISTER
2607 PL_hints &= HINT_UTF8;
2610 PL_op->op_type = OP_ENTEREVAL;
2611 PL_op->op_flags = 0; /* Avoid uninit warning. */
2612 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2613 PUSHEVAL(cx, 0, Nullgv);
2614 rop = doeval(G_SCALAR, startop);
2615 POPBLOCK(cx,PL_curpm);
2618 (*startop)->op_type = OP_NULL;
2619 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2621 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2623 if (PL_curcop == &PL_compiling)
2624 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2625 #ifdef OP_IN_REGISTER
2631 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2633 S_doeval(pTHX_ int gimme, OP** startop)
2640 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2641 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2647 for (i = cxstack_ix - 1; i >= 0; i--) {
2648 PERL_CONTEXT *cx = &cxstack[i];
2649 if (CxTYPE(cx) == CXt_EVAL)
2651 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2652 caller = cx->blk_sub.cv;
2657 SAVESPTR(PL_compcv);
2658 PL_compcv = (CV*)NEWSV(1104,0);
2659 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2660 CvEVAL_on(PL_compcv);
2661 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2662 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2664 /* set up a scratch pad */
2666 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2669 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2671 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2674 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2676 /* make sure we compile in the right package */
2678 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2679 SAVESPTR(PL_curstash);
2680 PL_curstash = CopSTASH(PL_curcop);
2682 SAVESPTR(PL_beginav);
2683 PL_beginav = newAV();
2684 SAVEFREESV(PL_beginav);
2685 SAVEI32(PL_error_count);
2687 /* try to compile it */
2689 PL_eval_root = Nullop;
2691 PL_curcop = &PL_compiling;
2692 PL_curcop->cop_arybase = 0;
2693 if (saveop && saveop->op_flags & OPf_SPECIAL)
2694 PL_in_eval |= EVAL_KEEPERR;
2697 if (yyparse() || PL_error_count || !PL_eval_root) {
2701 I32 optype = 0; /* Might be reset by POPEVAL. */
2706 op_free(PL_eval_root);
2707 PL_eval_root = Nullop;
2709 SP = PL_stack_base + POPMARK; /* pop original mark */
2711 POPBLOCK(cx,PL_curpm);
2717 if (optype == OP_REQUIRE) {
2718 char* msg = SvPVx(ERRSV, n_a);
2719 DIE(aTHX_ "%sCompilation failed in require",
2720 *msg ? msg : "Unknown error\n");
2723 char* msg = SvPVx(ERRSV, n_a);
2725 POPBLOCK(cx,PL_curpm);
2727 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2728 (*msg ? msg : "Unknown error\n"));
2732 CopLINE_set(&PL_compiling, 0);
2734 *startop = PL_eval_root;
2735 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2736 CvOUTSIDE(PL_compcv) = Nullcv;
2738 SAVEFREEOP(PL_eval_root);
2740 scalarvoid(PL_eval_root);
2741 else if (gimme & G_ARRAY)
2744 scalar(PL_eval_root);
2746 DEBUG_x(dump_eval());
2748 /* Register with debugger: */
2749 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2750 CV *cv = get_cv("DB::postponed", FALSE);
2754 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2756 call_sv((SV*)cv, G_DISCARD);
2760 /* compiled okay, so do it */
2762 CvDEPTH(PL_compcv) = 1;
2763 SP = PL_stack_base + POPMARK; /* pop original mark */
2764 PL_op = saveop; /* The caller may need it. */
2765 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2767 RETURNOP(PL_eval_start);
2771 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2773 STRLEN namelen = strlen(name);
2776 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2777 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2778 char *pmc = SvPV_nolen(pmcsv);
2781 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2782 fp = PerlIO_open(name, mode);
2785 if (PerlLIO_stat(name, &pmstat) < 0 ||
2786 pmstat.st_mtime < pmcstat.st_mtime)
2788 fp = PerlIO_open(pmc, mode);
2791 fp = PerlIO_open(name, mode);
2794 SvREFCNT_dec(pmcsv);
2797 fp = PerlIO_open(name, mode);
2805 register PERL_CONTEXT *cx;
2809 char *tryname = Nullch;
2810 SV *namesv = Nullsv;
2812 I32 gimme = GIMME_V;
2813 PerlIO *tryrsfp = 0;
2815 int filter_has_file = 0;
2816 GV *filter_child_proc = 0;
2817 SV *filter_state = 0;
2824 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2825 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2826 UV rev = 0, ver = 0, sver = 0;
2828 U8 *s = (U8*)SvPVX(sv);
2829 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2831 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2834 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2837 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2840 if (PERL_REVISION < rev
2841 || (PERL_REVISION == rev
2842 && (PERL_VERSION < ver
2843 || (PERL_VERSION == ver
2844 && PERL_SUBVERSION < sver))))
2846 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2847 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2848 PERL_VERSION, PERL_SUBVERSION);
2850 if (ckWARN(WARN_PORTABLE))
2851 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2852 "v-string in use/require non-portable");
2855 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2856 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2857 + ((NV)PERL_SUBVERSION/(NV)1000000)
2858 + 0.00000099 < SvNV(sv))
2862 NV nver = (nrev - rev) * 1000;
2863 UV ver = (UV)(nver + 0.0009);
2864 NV nsver = (nver - ver) * 1000;
2865 UV sver = (UV)(nsver + 0.0009);
2867 /* help out with the "use 5.6" confusion */
2868 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2869 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2870 " (did you mean v%"UVuf".%03"UVuf"?)--"
2871 "this is only v%d.%d.%d, stopped",
2872 rev, ver, sver, rev, ver/100,
2873 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2876 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2877 "this is only v%d.%d.%d, stopped",
2878 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2885 name = SvPV(sv, len);
2886 if (!(name && len > 0 && *name))
2887 DIE(aTHX_ "Null filename used");
2888 TAINT_PROPER("require");
2889 if (PL_op->op_type == OP_REQUIRE &&
2890 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2891 *svp != &PL_sv_undef)
2894 /* prepare to compile file */
2896 if (path_is_absolute(name)) {
2898 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2900 #ifdef MACOS_TRADITIONAL
2904 MacPerl_CanonDir(name, newname, 1);
2905 if (path_is_absolute(newname)) {
2907 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2912 AV *ar = GvAVn(PL_incgv);
2916 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2919 namesv = NEWSV(806, 0);
2920 for (i = 0; i <= AvFILL(ar); i++) {
2921 SV *dirsv = *av_fetch(ar, i, TRUE);
2927 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2928 && !sv_isobject(loader))
2930 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2933 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2934 PTR2UV(SvRV(dirsv)), name);
2935 tryname = SvPVX(namesv);
2946 if (sv_isobject(loader))
2947 count = call_method("INC", G_ARRAY);
2949 count = call_sv(loader, G_ARRAY);
2959 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2963 if (SvTYPE(arg) == SVt_PVGV) {
2964 IO *io = GvIO((GV *)arg);
2969 tryrsfp = IoIFP(io);
2970 if (IoTYPE(io) == IoTYPE_PIPE) {
2971 /* reading from a child process doesn't
2972 nest -- when returning from reading
2973 the inner module, the outer one is
2974 unreadable (closed?) I've tried to
2975 save the gv to manage the lifespan of
2976 the pipe, but this didn't help. XXX */
2977 filter_child_proc = (GV *)arg;
2978 (void)SvREFCNT_inc(filter_child_proc);
2981 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2982 PerlIO_close(IoOFP(io));
2994 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2996 (void)SvREFCNT_inc(filter_sub);
2999 filter_state = SP[i];
3000 (void)SvREFCNT_inc(filter_state);
3004 tryrsfp = PerlIO_open("/dev/null",
3019 filter_has_file = 0;
3020 if (filter_child_proc) {
3021 SvREFCNT_dec(filter_child_proc);
3022 filter_child_proc = 0;
3025 SvREFCNT_dec(filter_state);
3029 SvREFCNT_dec(filter_sub);
3034 if (!path_is_absolute(name)
3035 #ifdef MACOS_TRADITIONAL
3036 /* We consider paths of the form :a:b ambiguous and interpret them first
3037 as global then as local
3039 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3042 char *dir = SvPVx(dirsv, n_a);
3043 #ifdef MACOS_TRADITIONAL
3047 MacPerl_CanonDir(name, buf2, 1);
3048 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3052 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3054 sv_setpv(namesv, unixdir);
3055 sv_catpv(namesv, unixname);
3057 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3060 TAINT_PROPER("require");
3061 tryname = SvPVX(namesv);
3062 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3064 if (tryname[0] == '.' && tryname[1] == '/')
3073 SAVECOPFILE_FREE(&PL_compiling);
3074 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3075 SvREFCNT_dec(namesv);
3077 if (PL_op->op_type == OP_REQUIRE) {
3078 char *msgstr = name;
3079 if (namesv) { /* did we lookup @INC? */
3080 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3081 SV *dirmsgsv = NEWSV(0, 0);
3082 AV *ar = GvAVn(PL_incgv);
3084 sv_catpvn(msg, " in @INC", 8);
3085 if (instr(SvPVX(msg), ".h "))
3086 sv_catpv(msg, " (change .h to .ph maybe?)");
3087 if (instr(SvPVX(msg), ".ph "))
3088 sv_catpv(msg, " (did you run h2ph?)");
3089 sv_catpv(msg, " (@INC contains:");
3090 for (i = 0; i <= AvFILL(ar); i++) {
3091 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3092 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3093 sv_catsv(msg, dirmsgsv);
3095 sv_catpvn(msg, ")", 1);
3096 SvREFCNT_dec(dirmsgsv);
3097 msgstr = SvPV_nolen(msg);
3099 DIE(aTHX_ "Can't locate %s", msgstr);
3105 SETERRNO(0, SS_NORMAL);
3107 /* Assume success here to prevent recursive requirement. */
3109 /* Check whether a hook in @INC has already filled %INC */
3110 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3111 (void)hv_store(GvHVn(PL_incgv), name, len,
3112 (hook_sv ? SvREFCNT_inc(hook_sv)
3113 : newSVpv(CopFILE(&PL_compiling), 0)),
3119 lex_start(sv_2mortal(newSVpvn("",0)));
3120 SAVEGENERICSV(PL_rsfp_filters);
3121 PL_rsfp_filters = Nullav;
3126 SAVESPTR(PL_compiling.cop_warnings);
3127 if (PL_dowarn & G_WARN_ALL_ON)
3128 PL_compiling.cop_warnings = pWARN_ALL ;
3129 else if (PL_dowarn & G_WARN_ALL_OFF)
3130 PL_compiling.cop_warnings = pWARN_NONE ;
3131 else if (PL_taint_warn)
3132 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3134 PL_compiling.cop_warnings = pWARN_STD ;
3135 SAVESPTR(PL_compiling.cop_io);
3136 PL_compiling.cop_io = Nullsv;
3138 if (filter_sub || filter_child_proc) {
3139 SV *datasv = filter_add(run_user_filter, Nullsv);
3140 IoLINES(datasv) = filter_has_file;
3141 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3142 IoTOP_GV(datasv) = (GV *)filter_state;
3143 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3146 /* switch to eval mode */
3147 push_return(PL_op->op_next);
3148 PUSHBLOCK(cx, CXt_EVAL, SP);
3149 PUSHEVAL(cx, name, Nullgv);
3151 SAVECOPLINE(&PL_compiling);
3152 CopLINE_set(&PL_compiling, 0);
3156 /* Store and reset encoding. */
3157 encoding = PL_encoding;
3158 PL_encoding = Nullsv;
3160 op = DOCATCH(doeval(gimme, NULL));
3162 /* Restore encoding. */
3163 PL_encoding = encoding;
3170 return pp_require();
3176 register PERL_CONTEXT *cx;
3178 I32 gimme = GIMME_V, was = PL_sub_generation;
3179 char tbuf[TYPE_DIGITS(long) + 12];
3180 char *tmpbuf = tbuf;
3187 TAINT_PROPER("eval");
3193 /* switch to eval mode */
3195 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3196 SV *sv = sv_newmortal();
3197 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3198 (unsigned long)++PL_evalseq,
3199 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3203 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3204 SAVECOPFILE_FREE(&PL_compiling);
3205 CopFILE_set(&PL_compiling, tmpbuf+2);
3206 SAVECOPLINE(&PL_compiling);
3207 CopLINE_set(&PL_compiling, 1);
3208 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3209 deleting the eval's FILEGV from the stash before gv_check() runs
3210 (i.e. before run-time proper). To work around the coredump that
3211 ensues, we always turn GvMULTI_on for any globals that were
3212 introduced within evals. See force_ident(). GSAR 96-10-12 */
3213 safestr = savepv(tmpbuf);
3214 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3216 PL_hints = PL_op->op_targ;
3217 SAVESPTR(PL_compiling.cop_warnings);
3218 if (specialWARN(PL_curcop->cop_warnings))
3219 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3221 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3222 SAVEFREESV(PL_compiling.cop_warnings);
3224 SAVESPTR(PL_compiling.cop_io);
3225 if (specialCopIO(PL_curcop->cop_io))
3226 PL_compiling.cop_io = PL_curcop->cop_io;
3228 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3229 SAVEFREESV(PL_compiling.cop_io);
3232 push_return(PL_op->op_next);
3233 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3234 PUSHEVAL(cx, 0, Nullgv);
3236 /* prepare to compile string */
3238 if (PERLDB_LINE && PL_curstash != PL_debstash)
3239 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3241 ret = doeval(gimme, NULL);
3242 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3243 && ret != PL_op->op_next) { /* Successive compilation. */
3244 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3246 return DOCATCH(ret);
3256 register PERL_CONTEXT *cx;
3258 U8 save_flags = PL_op -> op_flags;
3263 retop = pop_return();
3266 if (gimme == G_VOID)
3268 else if (gimme == G_SCALAR) {
3271 if (SvFLAGS(TOPs) & SVs_TEMP)
3274 *MARK = sv_mortalcopy(TOPs);
3278 *MARK = &PL_sv_undef;
3283 /* in case LEAVE wipes old return values */
3284 for (mark = newsp + 1; mark <= SP; mark++) {
3285 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3286 *mark = sv_mortalcopy(*mark);
3287 TAINT_NOT; /* Each item is independent */
3291 PL_curpm = newpm; /* Don't pop $1 et al till now */
3294 assert(CvDEPTH(PL_compcv) == 1);
3296 CvDEPTH(PL_compcv) = 0;
3299 if (optype == OP_REQUIRE &&
3300 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3302 /* Unassume the success we assumed earlier. */
3303 SV *nsv = cx->blk_eval.old_namesv;
3304 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3305 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3306 /* die_where() did LEAVE, or we won't be here */
3310 if (!(save_flags & OPf_SPECIAL))
3320 register PERL_CONTEXT *cx;
3321 I32 gimme = GIMME_V;
3326 push_return(cLOGOP->op_other->op_next);
3327 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3330 PL_in_eval = EVAL_INEVAL;
3333 return DOCATCH(PL_op->op_next);
3344 register PERL_CONTEXT *cx;
3349 retop = pop_return();
3352 if (gimme == G_VOID)
3354 else if (gimme == G_SCALAR) {
3357 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3360 *MARK = sv_mortalcopy(TOPs);
3364 *MARK = &PL_sv_undef;
3369 /* in case LEAVE wipes old return values */
3370 for (mark = newsp + 1; mark <= SP; mark++) {
3371 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3372 *mark = sv_mortalcopy(*mark);
3373 TAINT_NOT; /* Each item is independent */
3377 PL_curpm = newpm; /* Don't pop $1 et al till now */
3385 S_doparseform(pTHX_ SV *sv)
3388 register char *s = SvPV_force(sv, len);
3389 register char *send = s + len;
3390 register char *base = Nullch;
3391 register I32 skipspaces = 0;
3392 bool noblank = FALSE;
3393 bool repeat = FALSE;
3394 bool postspace = FALSE;
3402 Perl_croak(aTHX_ "Null picture in formline");
3404 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3409 *fpc++ = FF_LINEMARK;
3410 noblank = repeat = FALSE;
3428 case ' ': case '\t':
3439 *fpc++ = FF_LITERAL;
3447 *fpc++ = (U16)skipspaces;
3451 *fpc++ = FF_NEWLINE;
3455 arg = fpc - linepc + 1;
3462 *fpc++ = FF_LINEMARK;
3463 noblank = repeat = FALSE;
3472 ischop = s[-1] == '^';
3478 arg = (s - base) - 1;
3480 *fpc++ = FF_LITERAL;
3489 *fpc++ = FF_LINEGLOB;
3491 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3492 arg = ischop ? 512 : 0;
3502 arg |= 256 + (s - f);
3504 *fpc++ = s - base; /* fieldsize for FETCH */
3505 *fpc++ = FF_DECIMAL;
3508 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3509 arg = ischop ? 512 : 0;
3511 s++; /* skip the '0' first */
3520 arg |= 256 + (s - f);
3522 *fpc++ = s - base; /* fieldsize for FETCH */
3523 *fpc++ = FF_0DECIMAL;
3528 bool ismore = FALSE;
3531 while (*++s == '>') ;
3532 prespace = FF_SPACE;
3534 else if (*s == '|') {
3535 while (*++s == '|') ;
3536 prespace = FF_HALFSPACE;
3541 while (*++s == '<') ;
3544 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3548 *fpc++ = s - base; /* fieldsize for FETCH */
3550 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3553 *fpc++ = (U16)prespace;
3568 { /* need to jump to the next word */
3570 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3571 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3572 s = SvPVX(sv) + SvCUR(sv) + z;
3574 Copy(fops, s, arg, U16);
3576 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3581 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3583 SV *datasv = FILTER_DATA(idx);
3584 int filter_has_file = IoLINES(datasv);
3585 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3586 SV *filter_state = (SV *)IoTOP_GV(datasv);
3587 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3590 /* I was having segfault trouble under Linux 2.2.5 after a
3591 parse error occured. (Had to hack around it with a test
3592 for PL_error_count == 0.) Solaris doesn't segfault --
3593 not sure where the trouble is yet. XXX */
3595 if (filter_has_file) {
3596 len = FILTER_READ(idx+1, buf_sv, maxlen);
3599 if (filter_sub && len >= 0) {
3610 PUSHs(sv_2mortal(newSViv(maxlen)));
3612 PUSHs(filter_state);
3615 count = call_sv(filter_sub, G_SCALAR);
3631 IoLINES(datasv) = 0;
3632 if (filter_child_proc) {
3633 SvREFCNT_dec(filter_child_proc);
3634 IoFMT_GV(datasv) = Nullgv;
3637 SvREFCNT_dec(filter_state);
3638 IoTOP_GV(datasv) = Nullgv;
3641 SvREFCNT_dec(filter_sub);
3642 IoBOTTOM_GV(datasv) = Nullgv;
3644 filter_del(run_user_filter);
3650 /* perhaps someone can come up with a better name for
3651 this? it is not really "absolute", per se ... */
3653 S_path_is_absolute(pTHX_ char *name)
3655 if (PERL_FILE_IS_ABSOLUTE(name)
3656 #ifdef MACOS_TRADITIONAL
3659 || (*name == '.' && (name[1] == '/' ||
3660 (name[1] == '.' && name[2] == '/'))))