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) || defined(USE_5005THREADS)
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) && !defined(USE_5005THREADS)
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);
1385 register I32 cxix = dopoptosub(cxstack_ix);
1386 register PERL_CONTEXT *cx;
1387 register PERL_CONTEXT *ccstack = cxstack;
1388 PERL_SI *top_si = PL_curstackinfo;
1399 /* we may be in a higher stacklevel, so dig down deeper */
1400 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1401 top_si = top_si->si_prev;
1402 ccstack = top_si->si_cxstack;
1403 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1406 if (GIMME != G_ARRAY) {
1412 if (PL_DBsub && cxix >= 0 &&
1413 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1417 cxix = dopoptosub_at(ccstack, cxix - 1);
1420 cx = &ccstack[cxix];
1421 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1422 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1423 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1424 field below is defined for any cx. */
1425 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1426 cx = &ccstack[dbcxix];
1429 stashname = CopSTASHPV(cx->blk_oldcop);
1430 if (GIMME != G_ARRAY) {
1433 PUSHs(&PL_sv_undef);
1436 sv_setpv(TARG, stashname);
1445 PUSHs(&PL_sv_undef);
1447 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1448 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1449 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1452 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1453 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1454 /* So is ccstack[dbcxix]. */
1457 gv_efullname3(sv, cvgv, Nullch);
1458 PUSHs(sv_2mortal(sv));
1459 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1462 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1463 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1467 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1468 PUSHs(sv_2mortal(newSViv(0)));
1470 gimme = (I32)cx->blk_gimme;
1471 if (gimme == G_VOID)
1472 PUSHs(&PL_sv_undef);
1474 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1475 if (CxTYPE(cx) == CXt_EVAL) {
1477 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1478 PUSHs(cx->blk_eval.cur_text);
1482 else if (cx->blk_eval.old_namesv) {
1483 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1486 /* eval BLOCK (try blocks have old_namesv == 0) */
1488 PUSHs(&PL_sv_undef);
1489 PUSHs(&PL_sv_undef);
1493 PUSHs(&PL_sv_undef);
1494 PUSHs(&PL_sv_undef);
1496 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1497 && CopSTASH_eq(PL_curcop, PL_debstash))
1499 AV *ary = cx->blk_sub.argarray;
1500 int off = AvARRAY(ary) - AvALLOC(ary);
1504 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1507 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1510 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1511 av_extend(PL_dbargs, AvFILLp(ary) + off);
1512 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1513 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1515 /* XXX only hints propagated via op_private are currently
1516 * visible (others are not easily accessible, since they
1517 * use the global PL_hints) */
1518 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1519 HINT_PRIVATE_MASK)));
1522 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1524 if (old_warnings == pWARN_NONE ||
1525 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1526 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1527 else if (old_warnings == pWARN_ALL ||
1528 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1529 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1531 mask = newSVsv(old_warnings);
1532 PUSHs(sv_2mortal(mask));
1547 sv_reset(tmps, CopSTASH(PL_curcop));
1559 PL_curcop = (COP*)PL_op;
1560 TAINT_NOT; /* Each statement is presumed innocent */
1561 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1564 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1568 register PERL_CONTEXT *cx;
1569 I32 gimme = G_ARRAY;
1576 DIE(aTHX_ "No DB::DB routine defined");
1578 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1579 /* don't do recursive DB::DB call */
1591 push_return(PL_op->op_next);
1592 PUSHBLOCK(cx, CXt_SUB, SP);
1595 (void)SvREFCNT_inc(cv);
1596 SAVEVPTR(PL_curpad);
1597 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1598 RETURNOP(CvSTART(cv));
1612 register PERL_CONTEXT *cx;
1613 I32 gimme = GIMME_V;
1615 U32 cxtype = CXt_LOOP;
1623 #ifdef USE_5005THREADS
1624 if (PL_op->op_flags & OPf_SPECIAL) {
1625 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1626 SAVEGENERICSV(*svp);
1630 #endif /* USE_5005THREADS */
1631 if (PL_op->op_targ) {
1632 #ifndef USE_ITHREADS
1633 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1636 SAVEPADSV(PL_op->op_targ);
1637 iterdata = INT2PTR(void*, PL_op->op_targ);
1638 cxtype |= CXp_PADVAR;
1643 svp = &GvSV(gv); /* symbol table variable */
1644 SAVEGENERICSV(*svp);
1647 iterdata = (void*)gv;
1653 PUSHBLOCK(cx, cxtype, SP);
1655 PUSHLOOP(cx, iterdata, MARK);
1657 PUSHLOOP(cx, svp, MARK);
1659 if (PL_op->op_flags & OPf_STACKED) {
1660 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1661 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1663 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1664 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1665 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1666 looks_like_number((SV*)cx->blk_loop.iterary) &&
1667 *SvPVX(cx->blk_loop.iterary) != '0'))
1669 if (SvNV(sv) < IV_MIN ||
1670 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1671 DIE(aTHX_ "Range iterator outside integer range");
1672 cx->blk_loop.iterix = SvIV(sv);
1673 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1676 cx->blk_loop.iterlval = newSVsv(sv);
1680 cx->blk_loop.iterary = PL_curstack;
1681 AvFILLp(PL_curstack) = SP - PL_stack_base;
1682 cx->blk_loop.iterix = MARK - PL_stack_base;
1691 register PERL_CONTEXT *cx;
1692 I32 gimme = GIMME_V;
1698 PUSHBLOCK(cx, CXt_LOOP, SP);
1699 PUSHLOOP(cx, 0, SP);
1707 register PERL_CONTEXT *cx;
1715 newsp = PL_stack_base + cx->blk_loop.resetsp;
1718 if (gimme == G_VOID)
1720 else if (gimme == G_SCALAR) {
1722 *++newsp = sv_mortalcopy(*SP);
1724 *++newsp = &PL_sv_undef;
1728 *++newsp = sv_mortalcopy(*++mark);
1729 TAINT_NOT; /* Each item is independent */
1735 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1736 PL_curpm = newpm; /* ... and pop $1 et al */
1748 register PERL_CONTEXT *cx;
1749 bool popsub2 = FALSE;
1750 bool clear_errsv = FALSE;
1757 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1758 if (cxstack_ix == PL_sortcxix
1759 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1761 if (cxstack_ix > PL_sortcxix)
1762 dounwind(PL_sortcxix);
1763 AvARRAY(PL_curstack)[1] = *SP;
1764 PL_stack_sp = PL_stack_base + 1;
1769 cxix = dopoptosub(cxstack_ix);
1771 DIE(aTHX_ "Can't return outside a subroutine");
1772 if (cxix < cxstack_ix)
1776 switch (CxTYPE(cx)) {
1781 if (!(PL_in_eval & EVAL_KEEPERR))
1787 if (optype == OP_REQUIRE &&
1788 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1790 /* Unassume the success we assumed earlier. */
1791 SV *nsv = cx->blk_eval.old_namesv;
1792 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1793 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1800 DIE(aTHX_ "panic: return");
1804 if (gimme == G_SCALAR) {
1807 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1809 *++newsp = SvREFCNT_inc(*SP);
1814 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1816 *++newsp = sv_mortalcopy(sv);
1821 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1824 *++newsp = sv_mortalcopy(*SP);
1827 *++newsp = &PL_sv_undef;
1829 else if (gimme == G_ARRAY) {
1830 while (++MARK <= SP) {
1831 *++newsp = (popsub2 && SvTEMP(*MARK))
1832 ? *MARK : sv_mortalcopy(*MARK);
1833 TAINT_NOT; /* Each item is independent */
1836 PL_stack_sp = newsp;
1838 /* Stack values are safe: */
1840 POPSUB(cx,sv); /* release CV and @_ ... */
1844 PL_curpm = newpm; /* ... and pop $1 et al */
1850 return pop_return();
1857 register PERL_CONTEXT *cx;
1867 if (PL_op->op_flags & OPf_SPECIAL) {
1868 cxix = dopoptoloop(cxstack_ix);
1870 DIE(aTHX_ "Can't \"last\" outside a loop block");
1873 cxix = dopoptolabel(cPVOP->op_pv);
1875 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1877 if (cxix < cxstack_ix)
1882 switch (CxTYPE(cx)) {
1885 newsp = PL_stack_base + cx->blk_loop.resetsp;
1886 nextop = cx->blk_loop.last_op->op_next;
1890 nextop = pop_return();
1894 nextop = pop_return();
1898 nextop = pop_return();
1901 DIE(aTHX_ "panic: last");
1905 if (gimme == G_SCALAR) {
1907 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1908 ? *SP : sv_mortalcopy(*SP);
1910 *++newsp = &PL_sv_undef;
1912 else if (gimme == G_ARRAY) {
1913 while (++MARK <= SP) {
1914 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1915 ? *MARK : sv_mortalcopy(*MARK);
1916 TAINT_NOT; /* Each item is independent */
1922 /* Stack values are safe: */
1925 POPLOOP(cx); /* release loop vars ... */
1929 POPSUB(cx,sv); /* release CV and @_ ... */
1932 PL_curpm = newpm; /* ... and pop $1 et al */
1942 register PERL_CONTEXT *cx;
1945 if (PL_op->op_flags & OPf_SPECIAL) {
1946 cxix = dopoptoloop(cxstack_ix);
1948 DIE(aTHX_ "Can't \"next\" outside a loop block");
1951 cxix = dopoptolabel(cPVOP->op_pv);
1953 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1955 if (cxix < cxstack_ix)
1958 /* clear off anything above the scope we're re-entering, but
1959 * save the rest until after a possible continue block */
1960 inner = PL_scopestack_ix;
1962 if (PL_scopestack_ix < inner)
1963 leave_scope(PL_scopestack[PL_scopestack_ix]);
1964 return cx->blk_loop.next_op;
1970 register PERL_CONTEXT *cx;
1973 if (PL_op->op_flags & OPf_SPECIAL) {
1974 cxix = dopoptoloop(cxstack_ix);
1976 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1979 cxix = dopoptolabel(cPVOP->op_pv);
1981 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1983 if (cxix < cxstack_ix)
1987 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1988 LEAVE_SCOPE(oldsave);
1989 return cx->blk_loop.redo_op;
1993 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1997 static char too_deep[] = "Target of goto is too deeply nested";
2000 Perl_croak(aTHX_ too_deep);
2001 if (o->op_type == OP_LEAVE ||
2002 o->op_type == OP_SCOPE ||
2003 o->op_type == OP_LEAVELOOP ||
2004 o->op_type == OP_LEAVETRY)
2006 *ops++ = cUNOPo->op_first;
2008 Perl_croak(aTHX_ too_deep);
2011 if (o->op_flags & OPf_KIDS) {
2012 /* First try all the kids at this level, since that's likeliest. */
2013 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2014 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2015 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2018 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2019 if (kid == PL_lastgotoprobe)
2021 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2023 (ops[-1]->op_type != OP_NEXTSTATE &&
2024 ops[-1]->op_type != OP_DBSTATE)))
2026 if ((o = dofindlabel(kid, label, ops, oplimit)))
2045 register PERL_CONTEXT *cx;
2046 #define GOTO_DEPTH 64
2047 OP *enterops[GOTO_DEPTH];
2049 int do_dump = (PL_op->op_type == OP_DUMP);
2050 static char must_have_label[] = "goto must have label";
2053 if (PL_op->op_flags & OPf_STACKED) {
2057 /* This egregious kludge implements goto &subroutine */
2058 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2060 register PERL_CONTEXT *cx;
2061 CV* cv = (CV*)SvRV(sv);
2067 if (!CvROOT(cv) && !CvXSUB(cv)) {
2072 /* autoloaded stub? */
2073 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2075 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2076 GvNAMELEN(gv), FALSE);
2077 if (autogv && (cv = GvCV(autogv)))
2079 tmpstr = sv_newmortal();
2080 gv_efullname3(tmpstr, gv, Nullch);
2081 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2083 DIE(aTHX_ "Goto undefined subroutine");
2086 /* First do some returnish stuff. */
2087 cxix = dopoptosub(cxstack_ix);
2089 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2090 if (cxix < cxstack_ix)
2094 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2096 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2097 /* put @_ back onto stack */
2098 AV* av = cx->blk_sub.argarray;
2100 items = AvFILLp(av) + 1;
2102 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2103 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2104 PL_stack_sp += items;
2105 #ifndef USE_5005THREADS
2106 SvREFCNT_dec(GvAV(PL_defgv));
2107 GvAV(PL_defgv) = cx->blk_sub.savearray;
2108 #endif /* USE_5005THREADS */
2109 /* abandon @_ if it got reified */
2111 (void)sv_2mortal((SV*)av); /* delay until return */
2113 av_extend(av, items-1);
2114 AvFLAGS(av) = AVf_REIFY;
2115 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2118 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2120 #ifdef USE_5005THREADS
2121 av = (AV*)PL_curpad[0];
2123 av = GvAV(PL_defgv);
2125 items = AvFILLp(av) + 1;
2127 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2128 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2129 PL_stack_sp += items;
2131 if (CxTYPE(cx) == CXt_SUB &&
2132 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2133 SvREFCNT_dec(cx->blk_sub.cv);
2134 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2135 LEAVE_SCOPE(oldsave);
2137 /* Now do some callish stuff. */
2140 #ifdef PERL_XSUB_OLDSTYLE
2141 if (CvOLDSTYLE(cv)) {
2142 I32 (*fp3)(int,int,int);
2147 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2148 items = (*fp3)(CvXSUBANY(cv).any_i32,
2149 mark - PL_stack_base + 1,
2151 SP = PL_stack_base + items;
2154 #endif /* PERL_XSUB_OLDSTYLE */
2159 PL_stack_sp--; /* There is no cv arg. */
2160 /* Push a mark for the start of arglist */
2162 (void)(*CvXSUB(cv))(aTHX_ cv);
2163 /* Pop the current context like a decent sub should */
2164 POPBLOCK(cx, PL_curpm);
2165 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2168 return pop_return();
2171 AV* padlist = CvPADLIST(cv);
2172 SV** svp = AvARRAY(padlist);
2173 if (CxTYPE(cx) == CXt_EVAL) {
2174 PL_in_eval = cx->blk_eval.old_in_eval;
2175 PL_eval_root = cx->blk_eval.old_eval_root;
2176 cx->cx_type = CXt_SUB;
2177 cx->blk_sub.hasargs = 0;
2179 cx->blk_sub.cv = cv;
2180 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2182 if (CvDEPTH(cv) < 2)
2183 (void)SvREFCNT_inc(cv);
2184 else { /* save temporaries on recursion? */
2185 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2186 sub_crush_depth(cv);
2187 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2188 AV *newpad = newAV();
2189 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2190 I32 ix = AvFILLp((AV*)svp[1]);
2191 I32 names_fill = AvFILLp((AV*)svp[0]);
2192 svp = AvARRAY(svp[0]);
2193 for ( ;ix > 0; ix--) {
2194 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2195 char *name = SvPVX(svp[ix]);
2196 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2199 /* outer lexical or anon code */
2200 av_store(newpad, ix,
2201 SvREFCNT_inc(oldpad[ix]) );
2203 else { /* our own lexical */
2205 av_store(newpad, ix, sv = (SV*)newAV());
2206 else if (*name == '%')
2207 av_store(newpad, ix, sv = (SV*)newHV());
2209 av_store(newpad, ix, sv = NEWSV(0,0));
2213 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2214 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2217 av_store(newpad, ix, sv = NEWSV(0,0));
2221 if (cx->blk_sub.hasargs) {
2224 av_store(newpad, 0, (SV*)av);
2225 AvFLAGS(av) = AVf_REIFY;
2227 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2228 AvFILLp(padlist) = CvDEPTH(cv);
2229 svp = AvARRAY(padlist);
2232 #ifdef USE_5005THREADS
2233 if (!cx->blk_sub.hasargs) {
2234 AV* av = (AV*)PL_curpad[0];
2236 items = AvFILLp(av) + 1;
2238 /* Mark is at the end of the stack. */
2240 Copy(AvARRAY(av), SP + 1, items, SV*);
2245 #endif /* USE_5005THREADS */
2246 SAVEVPTR(PL_curpad);
2247 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2248 #ifndef USE_5005THREADS
2249 if (cx->blk_sub.hasargs)
2250 #endif /* USE_5005THREADS */
2252 AV* av = (AV*)PL_curpad[0];
2255 #ifndef USE_5005THREADS
2256 cx->blk_sub.savearray = GvAV(PL_defgv);
2257 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2258 #endif /* USE_5005THREADS */
2259 cx->blk_sub.oldcurpad = PL_curpad;
2260 cx->blk_sub.argarray = av;
2263 if (items >= AvMAX(av) + 1) {
2265 if (AvARRAY(av) != ary) {
2266 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2267 SvPVX(av) = (char*)ary;
2269 if (items >= AvMAX(av) + 1) {
2270 AvMAX(av) = items - 1;
2271 Renew(ary,items+1,SV*);
2273 SvPVX(av) = (char*)ary;
2276 Copy(mark,AvARRAY(av),items,SV*);
2277 AvFILLp(av) = items - 1;
2278 assert(!AvREAL(av));
2285 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2287 * We do not care about using sv to call CV;
2288 * it's for informational purposes only.
2290 SV *sv = GvSV(PL_DBsub);
2293 if (PERLDB_SUB_NN) {
2294 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2297 gv_efullname3(sv, CvGV(cv), Nullch);
2300 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2301 PUSHMARK( PL_stack_sp );
2302 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2306 RETURNOP(CvSTART(cv));
2310 label = SvPV(sv,n_a);
2311 if (!(do_dump || *label))
2312 DIE(aTHX_ must_have_label);
2315 else if (PL_op->op_flags & OPf_SPECIAL) {
2317 DIE(aTHX_ must_have_label);
2320 label = cPVOP->op_pv;
2322 if (label && *label) {
2324 bool leaving_eval = FALSE;
2325 PERL_CONTEXT *last_eval_cx = 0;
2329 PL_lastgotoprobe = 0;
2331 for (ix = cxstack_ix; ix >= 0; ix--) {
2333 switch (CxTYPE(cx)) {
2335 leaving_eval = TRUE;
2336 if (CxREALEVAL(cx)) {
2337 gotoprobe = (last_eval_cx ?
2338 last_eval_cx->blk_eval.old_eval_root :
2343 /* else fall through */
2345 gotoprobe = cx->blk_oldcop->op_sibling;
2351 gotoprobe = cx->blk_oldcop->op_sibling;
2353 gotoprobe = PL_main_root;
2356 if (CvDEPTH(cx->blk_sub.cv)) {
2357 gotoprobe = CvROOT(cx->blk_sub.cv);
2363 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2366 DIE(aTHX_ "panic: goto");
2367 gotoprobe = PL_main_root;
2371 retop = dofindlabel(gotoprobe, label,
2372 enterops, enterops + GOTO_DEPTH);
2376 PL_lastgotoprobe = gotoprobe;
2379 DIE(aTHX_ "Can't find label %s", label);
2381 /* if we're leaving an eval, check before we pop any frames
2382 that we're not going to punt, otherwise the error
2385 if (leaving_eval && *enterops && enterops[1]) {
2387 for (i = 1; enterops[i]; i++)
2388 if (enterops[i]->op_type == OP_ENTERITER)
2389 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2392 /* pop unwanted frames */
2394 if (ix < cxstack_ix) {
2401 oldsave = PL_scopestack[PL_scopestack_ix];
2402 LEAVE_SCOPE(oldsave);
2405 /* push wanted frames */
2407 if (*enterops && enterops[1]) {
2409 for (ix = 1; enterops[ix]; ix++) {
2410 PL_op = enterops[ix];
2411 /* Eventually we may want to stack the needed arguments
2412 * for each op. For now, we punt on the hard ones. */
2413 if (PL_op->op_type == OP_ENTERITER)
2414 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2415 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2423 if (!retop) retop = PL_main_start;
2425 PL_restartop = retop;
2426 PL_do_undump = TRUE;
2430 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2431 PL_do_undump = FALSE;
2447 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2449 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2452 PL_exit_flags |= PERL_EXIT_EXPECTED;
2454 PUSHs(&PL_sv_undef);
2462 NV value = SvNVx(GvSV(cCOP->cop_gv));
2463 register I32 match = I_32(value);
2466 if (((NV)match) > value)
2467 --match; /* was fractional--truncate other way */
2469 match -= cCOP->uop.scop.scop_offset;
2472 else if (match > cCOP->uop.scop.scop_max)
2473 match = cCOP->uop.scop.scop_max;
2474 PL_op = cCOP->uop.scop.scop_next[match];
2484 PL_op = PL_op->op_next; /* can't assume anything */
2487 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2488 match -= cCOP->uop.scop.scop_offset;
2491 else if (match > cCOP->uop.scop.scop_max)
2492 match = cCOP->uop.scop.scop_max;
2493 PL_op = cCOP->uop.scop.scop_next[match];
2502 S_save_lines(pTHX_ AV *array, SV *sv)
2504 register char *s = SvPVX(sv);
2505 register char *send = SvPVX(sv) + SvCUR(sv);
2507 register I32 line = 1;
2509 while (s && s < send) {
2510 SV *tmpstr = NEWSV(85,0);
2512 sv_upgrade(tmpstr, SVt_PVMG);
2513 t = strchr(s, '\n');
2519 sv_setpvn(tmpstr, s, t - s);
2520 av_store(array, line++, tmpstr);
2525 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2527 S_docatch_body(pTHX_ va_list args)
2529 return docatch_body();
2534 S_docatch_body(pTHX)
2541 S_docatch(pTHX_ OP *o)
2546 volatile PERL_SI *cursi = PL_curstackinfo;
2550 assert(CATCH_GET == TRUE);
2554 /* Normally, the leavetry at the end of this block of ops will
2555 * pop an op off the return stack and continue there. By setting
2556 * the op to Nullop, we force an exit from the inner runops()
2559 retop = pop_return();
2560 push_return(Nullop);
2562 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2564 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2570 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2576 /* die caught by an inner eval - continue inner loop */
2577 if (PL_restartop && cursi == PL_curstackinfo) {
2578 PL_op = PL_restartop;
2582 /* a die in this eval - continue in outer loop */
2598 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2599 /* sv Text to convert to OP tree. */
2600 /* startop op_free() this to undo. */
2601 /* code Short string id of the caller. */
2603 dSP; /* Make POPBLOCK work. */
2606 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2610 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2611 char *tmpbuf = tbuf;
2617 /* switch to eval mode */
2619 if (PL_curcop == &PL_compiling) {
2620 SAVECOPSTASH_FREE(&PL_compiling);
2621 CopSTASH_set(&PL_compiling, PL_curstash);
2623 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2624 SV *sv = sv_newmortal();
2625 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2626 code, (unsigned long)++PL_evalseq,
2627 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2631 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2632 SAVECOPFILE_FREE(&PL_compiling);
2633 CopFILE_set(&PL_compiling, tmpbuf+2);
2634 SAVECOPLINE(&PL_compiling);
2635 CopLINE_set(&PL_compiling, 1);
2636 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2637 deleting the eval's FILEGV from the stash before gv_check() runs
2638 (i.e. before run-time proper). To work around the coredump that
2639 ensues, we always turn GvMULTI_on for any globals that were
2640 introduced within evals. See force_ident(). GSAR 96-10-12 */
2641 safestr = savepv(tmpbuf);
2642 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2644 #ifdef OP_IN_REGISTER
2649 PL_hints &= HINT_UTF8;
2652 PL_op->op_type = OP_ENTEREVAL;
2653 PL_op->op_flags = 0; /* Avoid uninit warning. */
2654 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2655 PUSHEVAL(cx, 0, Nullgv);
2656 rop = doeval(G_SCALAR, startop);
2657 POPBLOCK(cx,PL_curpm);
2660 (*startop)->op_type = OP_NULL;
2661 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2663 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2665 if (PL_curcop == &PL_compiling)
2666 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2667 #ifdef OP_IN_REGISTER
2673 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2675 S_doeval(pTHX_ int gimme, OP** startop)
2683 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2684 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2689 /* set up a scratch pad */
2692 SAVEVPTR(PL_curpad);
2693 SAVESPTR(PL_comppad);
2694 SAVESPTR(PL_comppad_name);
2695 SAVEI32(PL_comppad_name_fill);
2696 SAVEI32(PL_min_intro_pending);
2697 SAVEI32(PL_max_intro_pending);
2700 for (i = cxstack_ix - 1; i >= 0; i--) {
2701 PERL_CONTEXT *cx = &cxstack[i];
2702 if (CxTYPE(cx) == CXt_EVAL)
2704 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2705 caller = cx->blk_sub.cv;
2710 SAVESPTR(PL_compcv);
2711 PL_compcv = (CV*)NEWSV(1104,0);
2712 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2713 CvEVAL_on(PL_compcv);
2714 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2715 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2717 #ifdef USE_5005THREADS
2718 CvOWNER(PL_compcv) = 0;
2719 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2720 MUTEX_INIT(CvMUTEXP(PL_compcv));
2721 #endif /* USE_5005THREADS */
2723 PL_comppad = newAV();
2724 av_push(PL_comppad, Nullsv);
2725 PL_curpad = AvARRAY(PL_comppad);
2726 PL_comppad_name = newAV();
2727 PL_comppad_name_fill = 0;
2728 PL_min_intro_pending = 0;
2730 #ifdef USE_5005THREADS
2731 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2732 PL_curpad[0] = (SV*)newAV();
2733 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2734 #endif /* USE_5005THREADS */
2736 comppadlist = newAV();
2737 AvREAL_off(comppadlist);
2738 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2739 av_store(comppadlist, 1, (SV*)PL_comppad);
2740 CvPADLIST(PL_compcv) = comppadlist;
2743 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2745 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2748 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2750 /* make sure we compile in the right package */
2752 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2753 SAVESPTR(PL_curstash);
2754 PL_curstash = CopSTASH(PL_curcop);
2756 SAVESPTR(PL_beginav);
2757 PL_beginav = newAV();
2758 SAVEFREESV(PL_beginav);
2759 SAVEI32(PL_error_count);
2761 /* try to compile it */
2763 PL_eval_root = Nullop;
2765 PL_curcop = &PL_compiling;
2766 PL_curcop->cop_arybase = 0;
2767 if (saveop && saveop->op_flags & OPf_SPECIAL)
2768 PL_in_eval |= EVAL_KEEPERR;
2771 if (yyparse() || PL_error_count || !PL_eval_root) {
2775 I32 optype = 0; /* Might be reset by POPEVAL. */
2780 op_free(PL_eval_root);
2781 PL_eval_root = Nullop;
2783 SP = PL_stack_base + POPMARK; /* pop original mark */
2785 POPBLOCK(cx,PL_curpm);
2791 if (optype == OP_REQUIRE) {
2792 char* msg = SvPVx(ERRSV, n_a);
2793 DIE(aTHX_ "%sCompilation failed in require",
2794 *msg ? msg : "Unknown error\n");
2797 char* msg = SvPVx(ERRSV, n_a);
2799 POPBLOCK(cx,PL_curpm);
2801 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2802 (*msg ? msg : "Unknown error\n"));
2804 #ifdef USE_5005THREADS
2805 MUTEX_LOCK(&PL_eval_mutex);
2807 COND_SIGNAL(&PL_eval_cond);
2808 MUTEX_UNLOCK(&PL_eval_mutex);
2809 #endif /* USE_5005THREADS */
2812 CopLINE_set(&PL_compiling, 0);
2814 *startop = PL_eval_root;
2815 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2816 CvOUTSIDE(PL_compcv) = Nullcv;
2818 SAVEFREEOP(PL_eval_root);
2820 scalarvoid(PL_eval_root);
2821 else if (gimme & G_ARRAY)
2824 scalar(PL_eval_root);
2826 DEBUG_x(dump_eval());
2828 /* Register with debugger: */
2829 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2830 CV *cv = get_cv("DB::postponed", FALSE);
2834 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2836 call_sv((SV*)cv, G_DISCARD);
2840 /* compiled okay, so do it */
2842 CvDEPTH(PL_compcv) = 1;
2843 SP = PL_stack_base + POPMARK; /* pop original mark */
2844 PL_op = saveop; /* The caller may need it. */
2845 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2846 #ifdef USE_5005THREADS
2847 MUTEX_LOCK(&PL_eval_mutex);
2849 COND_SIGNAL(&PL_eval_cond);
2850 MUTEX_UNLOCK(&PL_eval_mutex);
2851 #endif /* USE_5005THREADS */
2853 RETURNOP(PL_eval_start);
2857 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2859 STRLEN namelen = strlen(name);
2862 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2863 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2864 char *pmc = SvPV_nolen(pmcsv);
2867 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2868 fp = PerlIO_open(name, mode);
2871 if (PerlLIO_stat(name, &pmstat) < 0 ||
2872 pmstat.st_mtime < pmcstat.st_mtime)
2874 fp = PerlIO_open(pmc, mode);
2877 fp = PerlIO_open(name, mode);
2880 SvREFCNT_dec(pmcsv);
2883 fp = PerlIO_open(name, mode);
2891 register PERL_CONTEXT *cx;
2895 char *tryname = Nullch;
2896 SV *namesv = Nullsv;
2898 I32 gimme = GIMME_V;
2899 PerlIO *tryrsfp = 0;
2901 int filter_has_file = 0;
2902 GV *filter_child_proc = 0;
2903 SV *filter_state = 0;
2910 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2911 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2912 UV rev = 0, ver = 0, sver = 0;
2914 U8 *s = (U8*)SvPVX(sv);
2915 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2917 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2920 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2923 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2926 if (PERL_REVISION < rev
2927 || (PERL_REVISION == rev
2928 && (PERL_VERSION < ver
2929 || (PERL_VERSION == ver
2930 && PERL_SUBVERSION < sver))))
2932 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2933 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2934 PERL_VERSION, PERL_SUBVERSION);
2936 if (ckWARN(WARN_PORTABLE))
2937 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2938 "v-string in use/require non-portable");
2941 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2942 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2943 + ((NV)PERL_SUBVERSION/(NV)1000000)
2944 + 0.00000099 < SvNV(sv))
2948 NV nver = (nrev - rev) * 1000;
2949 UV ver = (UV)(nver + 0.0009);
2950 NV nsver = (nver - ver) * 1000;
2951 UV sver = (UV)(nsver + 0.0009);
2953 /* help out with the "use 5.6" confusion */
2954 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2955 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2956 " (did you mean v%"UVuf".%03"UVuf"?)--"
2957 "this is only v%d.%d.%d, stopped",
2958 rev, ver, sver, rev, ver/100,
2959 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2962 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2963 "this is only v%d.%d.%d, stopped",
2964 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2971 name = SvPV(sv, len);
2972 if (!(name && len > 0 && *name))
2973 DIE(aTHX_ "Null filename used");
2974 TAINT_PROPER("require");
2975 if (PL_op->op_type == OP_REQUIRE &&
2976 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2977 *svp != &PL_sv_undef)
2980 /* prepare to compile file */
2982 if (path_is_absolute(name)) {
2984 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2986 #ifdef MACOS_TRADITIONAL
2990 MacPerl_CanonDir(name, newname, 1);
2991 if (path_is_absolute(newname)) {
2993 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2998 AV *ar = GvAVn(PL_incgv);
3002 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3005 namesv = NEWSV(806, 0);
3006 for (i = 0; i <= AvFILL(ar); i++) {
3007 SV *dirsv = *av_fetch(ar, i, TRUE);
3013 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3014 && !sv_isobject(loader))
3016 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3019 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3020 PTR2UV(SvRV(dirsv)), name);
3021 tryname = SvPVX(namesv);
3032 if (sv_isobject(loader))
3033 count = call_method("INC", G_ARRAY);
3035 count = call_sv(loader, G_ARRAY);
3045 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3049 if (SvTYPE(arg) == SVt_PVGV) {
3050 IO *io = GvIO((GV *)arg);
3055 tryrsfp = IoIFP(io);
3056 if (IoTYPE(io) == IoTYPE_PIPE) {
3057 /* reading from a child process doesn't
3058 nest -- when returning from reading
3059 the inner module, the outer one is
3060 unreadable (closed?) I've tried to
3061 save the gv to manage the lifespan of
3062 the pipe, but this didn't help. XXX */
3063 filter_child_proc = (GV *)arg;
3064 (void)SvREFCNT_inc(filter_child_proc);
3067 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3068 PerlIO_close(IoOFP(io));
3080 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3082 (void)SvREFCNT_inc(filter_sub);
3085 filter_state = SP[i];
3086 (void)SvREFCNT_inc(filter_state);
3090 tryrsfp = PerlIO_open("/dev/null",
3105 filter_has_file = 0;
3106 if (filter_child_proc) {
3107 SvREFCNT_dec(filter_child_proc);
3108 filter_child_proc = 0;
3111 SvREFCNT_dec(filter_state);
3115 SvREFCNT_dec(filter_sub);
3120 if (!path_is_absolute(name)
3121 #ifdef MACOS_TRADITIONAL
3122 /* We consider paths of the form :a:b ambiguous and interpret them first
3123 as global then as local
3125 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3128 char *dir = SvPVx(dirsv, n_a);
3129 #ifdef MACOS_TRADITIONAL
3133 MacPerl_CanonDir(name, buf2, 1);
3134 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3138 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3140 sv_setpv(namesv, unixdir);
3141 sv_catpv(namesv, unixname);
3143 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3146 TAINT_PROPER("require");
3147 tryname = SvPVX(namesv);
3148 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3150 if (tryname[0] == '.' && tryname[1] == '/')
3159 SAVECOPFILE_FREE(&PL_compiling);
3160 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3161 SvREFCNT_dec(namesv);
3163 if (PL_op->op_type == OP_REQUIRE) {
3164 char *msgstr = name;
3165 if (namesv) { /* did we lookup @INC? */
3166 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3167 SV *dirmsgsv = NEWSV(0, 0);
3168 AV *ar = GvAVn(PL_incgv);
3170 sv_catpvn(msg, " in @INC", 8);
3171 if (instr(SvPVX(msg), ".h "))
3172 sv_catpv(msg, " (change .h to .ph maybe?)");
3173 if (instr(SvPVX(msg), ".ph "))
3174 sv_catpv(msg, " (did you run h2ph?)");
3175 sv_catpv(msg, " (@INC contains:");
3176 for (i = 0; i <= AvFILL(ar); i++) {
3177 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3178 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3179 sv_catsv(msg, dirmsgsv);
3181 sv_catpvn(msg, ")", 1);
3182 SvREFCNT_dec(dirmsgsv);
3183 msgstr = SvPV_nolen(msg);
3185 DIE(aTHX_ "Can't locate %s", msgstr);
3191 SETERRNO(0, SS$_NORMAL);
3193 /* Assume success here to prevent recursive requirement. */
3195 /* Check whether a hook in @INC has already filled %INC */
3196 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3197 (void)hv_store(GvHVn(PL_incgv), name, len,
3198 (hook_sv ? SvREFCNT_inc(hook_sv)
3199 : newSVpv(CopFILE(&PL_compiling), 0)),
3205 lex_start(sv_2mortal(newSVpvn("",0)));
3206 SAVEGENERICSV(PL_rsfp_filters);
3207 PL_rsfp_filters = Nullav;
3212 SAVESPTR(PL_compiling.cop_warnings);
3213 if (PL_dowarn & G_WARN_ALL_ON)
3214 PL_compiling.cop_warnings = pWARN_ALL ;
3215 else if (PL_dowarn & G_WARN_ALL_OFF)
3216 PL_compiling.cop_warnings = pWARN_NONE ;
3217 else if (PL_taint_warn)
3218 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3220 PL_compiling.cop_warnings = pWARN_STD ;
3221 SAVESPTR(PL_compiling.cop_io);
3222 PL_compiling.cop_io = Nullsv;
3224 if (filter_sub || filter_child_proc) {
3225 SV *datasv = filter_add(run_user_filter, Nullsv);
3226 IoLINES(datasv) = filter_has_file;
3227 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3228 IoTOP_GV(datasv) = (GV *)filter_state;
3229 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3232 /* switch to eval mode */
3233 push_return(PL_op->op_next);
3234 PUSHBLOCK(cx, CXt_EVAL, SP);
3235 PUSHEVAL(cx, name, Nullgv);
3237 SAVECOPLINE(&PL_compiling);
3238 CopLINE_set(&PL_compiling, 0);
3241 #ifdef USE_5005THREADS
3242 MUTEX_LOCK(&PL_eval_mutex);
3243 if (PL_eval_owner && PL_eval_owner != thr)
3244 while (PL_eval_owner)
3245 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3246 PL_eval_owner = thr;
3247 MUTEX_UNLOCK(&PL_eval_mutex);
3248 #endif /* USE_5005THREADS */
3250 /* Store and reset encoding. */
3251 encoding = PL_encoding;
3252 PL_encoding = Nullsv;
3254 op = DOCATCH(doeval(gimme, NULL));
3256 /* Restore encoding. */
3257 PL_encoding = encoding;
3264 return pp_require();
3270 register PERL_CONTEXT *cx;
3272 I32 gimme = GIMME_V, was = PL_sub_generation;
3273 char tbuf[TYPE_DIGITS(long) + 12];
3274 char *tmpbuf = tbuf;
3279 if (!SvPV(sv,len) || !len)
3281 TAINT_PROPER("eval");
3287 /* switch to eval mode */
3289 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3290 SV *sv = sv_newmortal();
3291 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3292 (unsigned long)++PL_evalseq,
3293 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3297 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3298 SAVECOPFILE_FREE(&PL_compiling);
3299 CopFILE_set(&PL_compiling, tmpbuf+2);
3300 SAVECOPLINE(&PL_compiling);
3301 CopLINE_set(&PL_compiling, 1);
3302 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3303 deleting the eval's FILEGV from the stash before gv_check() runs
3304 (i.e. before run-time proper). To work around the coredump that
3305 ensues, we always turn GvMULTI_on for any globals that were
3306 introduced within evals. See force_ident(). GSAR 96-10-12 */
3307 safestr = savepv(tmpbuf);
3308 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3310 PL_hints = PL_op->op_targ;
3311 SAVESPTR(PL_compiling.cop_warnings);
3312 if (specialWARN(PL_curcop->cop_warnings))
3313 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3315 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3316 SAVEFREESV(PL_compiling.cop_warnings);
3318 SAVESPTR(PL_compiling.cop_io);
3319 if (specialCopIO(PL_curcop->cop_io))
3320 PL_compiling.cop_io = PL_curcop->cop_io;
3322 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3323 SAVEFREESV(PL_compiling.cop_io);
3326 push_return(PL_op->op_next);
3327 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3328 PUSHEVAL(cx, 0, Nullgv);
3330 /* prepare to compile string */
3332 if (PERLDB_LINE && PL_curstash != PL_debstash)
3333 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3335 #ifdef USE_5005THREADS
3336 MUTEX_LOCK(&PL_eval_mutex);
3337 if (PL_eval_owner && PL_eval_owner != thr)
3338 while (PL_eval_owner)
3339 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3340 PL_eval_owner = thr;
3341 MUTEX_UNLOCK(&PL_eval_mutex);
3342 #endif /* USE_5005THREADS */
3343 ret = doeval(gimme, NULL);
3344 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3345 && ret != PL_op->op_next) { /* Successive compilation. */
3346 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3348 return DOCATCH(ret);
3358 register PERL_CONTEXT *cx;
3360 U8 save_flags = PL_op -> op_flags;
3365 retop = pop_return();
3368 if (gimme == G_VOID)
3370 else if (gimme == G_SCALAR) {
3373 if (SvFLAGS(TOPs) & SVs_TEMP)
3376 *MARK = sv_mortalcopy(TOPs);
3380 *MARK = &PL_sv_undef;
3385 /* in case LEAVE wipes old return values */
3386 for (mark = newsp + 1; mark <= SP; mark++) {
3387 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3388 *mark = sv_mortalcopy(*mark);
3389 TAINT_NOT; /* Each item is independent */
3393 PL_curpm = newpm; /* Don't pop $1 et al till now */
3396 assert(CvDEPTH(PL_compcv) == 1);
3398 CvDEPTH(PL_compcv) = 0;
3401 if (optype == OP_REQUIRE &&
3402 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3404 /* Unassume the success we assumed earlier. */
3405 SV *nsv = cx->blk_eval.old_namesv;
3406 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3407 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3408 /* die_where() did LEAVE, or we won't be here */
3412 if (!(save_flags & OPf_SPECIAL))
3422 register PERL_CONTEXT *cx;
3423 I32 gimme = GIMME_V;
3428 push_return(cLOGOP->op_other->op_next);
3429 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3432 PL_in_eval = EVAL_INEVAL;
3435 return DOCATCH(PL_op->op_next);
3446 register PERL_CONTEXT *cx;
3451 retop = pop_return();
3454 if (gimme == G_VOID)
3456 else if (gimme == G_SCALAR) {
3459 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3462 *MARK = sv_mortalcopy(TOPs);
3466 *MARK = &PL_sv_undef;
3471 /* in case LEAVE wipes old return values */
3472 for (mark = newsp + 1; mark <= SP; mark++) {
3473 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3474 *mark = sv_mortalcopy(*mark);
3475 TAINT_NOT; /* Each item is independent */
3479 PL_curpm = newpm; /* Don't pop $1 et al till now */
3487 S_doparseform(pTHX_ SV *sv)
3490 register char *s = SvPV_force(sv, len);
3491 register char *send = s + len;
3492 register char *base = Nullch;
3493 register I32 skipspaces = 0;
3494 bool noblank = FALSE;
3495 bool repeat = FALSE;
3496 bool postspace = FALSE;
3504 Perl_croak(aTHX_ "Null picture in formline");
3506 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3511 *fpc++ = FF_LINEMARK;
3512 noblank = repeat = FALSE;
3530 case ' ': case '\t':
3541 *fpc++ = FF_LITERAL;
3549 *fpc++ = (U16)skipspaces;
3553 *fpc++ = FF_NEWLINE;
3557 arg = fpc - linepc + 1;
3564 *fpc++ = FF_LINEMARK;
3565 noblank = repeat = FALSE;
3574 ischop = s[-1] == '^';
3580 arg = (s - base) - 1;
3582 *fpc++ = FF_LITERAL;
3591 *fpc++ = FF_LINEGLOB;
3593 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3594 arg = ischop ? 512 : 0;
3604 arg |= 256 + (s - f);
3606 *fpc++ = s - base; /* fieldsize for FETCH */
3607 *fpc++ = FF_DECIMAL;
3610 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3611 arg = ischop ? 512 : 0;
3613 s++; /* skip the '0' first */
3622 arg |= 256 + (s - f);
3624 *fpc++ = s - base; /* fieldsize for FETCH */
3625 *fpc++ = FF_0DECIMAL;
3630 bool ismore = FALSE;
3633 while (*++s == '>') ;
3634 prespace = FF_SPACE;
3636 else if (*s == '|') {
3637 while (*++s == '|') ;
3638 prespace = FF_HALFSPACE;
3643 while (*++s == '<') ;
3646 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3650 *fpc++ = s - base; /* fieldsize for FETCH */
3652 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3655 *fpc++ = (U16)prespace;
3670 { /* need to jump to the next word */
3672 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3673 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3674 s = SvPVX(sv) + SvCUR(sv) + z;
3676 Copy(fops, s, arg, U16);
3678 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3683 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3685 SV *datasv = FILTER_DATA(idx);
3686 int filter_has_file = IoLINES(datasv);
3687 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3688 SV *filter_state = (SV *)IoTOP_GV(datasv);
3689 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3692 /* I was having segfault trouble under Linux 2.2.5 after a
3693 parse error occured. (Had to hack around it with a test
3694 for PL_error_count == 0.) Solaris doesn't segfault --
3695 not sure where the trouble is yet. XXX */
3697 if (filter_has_file) {
3698 len = FILTER_READ(idx+1, buf_sv, maxlen);
3701 if (filter_sub && len >= 0) {
3712 PUSHs(sv_2mortal(newSViv(maxlen)));
3714 PUSHs(filter_state);
3717 count = call_sv(filter_sub, G_SCALAR);
3733 IoLINES(datasv) = 0;
3734 if (filter_child_proc) {
3735 SvREFCNT_dec(filter_child_proc);
3736 IoFMT_GV(datasv) = Nullgv;
3739 SvREFCNT_dec(filter_state);
3740 IoTOP_GV(datasv) = Nullgv;
3743 SvREFCNT_dec(filter_sub);
3744 IoBOTTOM_GV(datasv) = Nullgv;
3746 filter_del(run_user_filter);
3752 /* perhaps someone can come up with a better name for
3753 this? it is not really "absolute", per se ... */
3755 S_path_is_absolute(pTHX_ char *name)
3757 if (PERL_FILE_IS_ABSOLUTE(name)
3758 #ifdef MACOS_TRADITIONAL
3761 || (*name == '.' && (name[1] == '/' ||
3762 (name[1] == '.' && name[2] == '/'))))