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 != 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 != 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 != 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 /* So is ccstack[dbcxix]. */
1455 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1456 PUSHs(sv_2mortal(sv));
1457 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1460 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1461 PUSHs(sv_2mortal(newSViv(0)));
1463 gimme = (I32)cx->blk_gimme;
1464 if (gimme == G_VOID)
1465 PUSHs(&PL_sv_undef);
1467 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1468 if (CxTYPE(cx) == CXt_EVAL) {
1470 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1471 PUSHs(cx->blk_eval.cur_text);
1475 else if (cx->blk_eval.old_namesv) {
1476 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1479 /* eval BLOCK (try blocks have old_namesv == 0) */
1481 PUSHs(&PL_sv_undef);
1482 PUSHs(&PL_sv_undef);
1486 PUSHs(&PL_sv_undef);
1487 PUSHs(&PL_sv_undef);
1489 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1490 && CopSTASH_eq(PL_curcop, PL_debstash))
1492 AV *ary = cx->blk_sub.argarray;
1493 int off = AvARRAY(ary) - AvALLOC(ary);
1497 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1500 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1503 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1504 av_extend(PL_dbargs, AvFILLp(ary) + off);
1505 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1506 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1508 /* XXX only hints propagated via op_private are currently
1509 * visible (others are not easily accessible, since they
1510 * use the global PL_hints) */
1511 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1512 HINT_PRIVATE_MASK)));
1515 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1517 if (old_warnings == pWARN_NONE ||
1518 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1519 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1520 else if (old_warnings == pWARN_ALL ||
1521 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1522 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1524 mask = newSVsv(old_warnings);
1525 PUSHs(sv_2mortal(mask));
1540 sv_reset(tmps, CopSTASH(PL_curcop));
1552 PL_curcop = (COP*)PL_op;
1553 TAINT_NOT; /* Each statement is presumed innocent */
1554 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1557 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1561 register PERL_CONTEXT *cx;
1562 I32 gimme = G_ARRAY;
1569 DIE(aTHX_ "No DB::DB routine defined");
1571 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1572 /* don't do recursive DB::DB call */
1584 push_return(PL_op->op_next);
1585 PUSHBLOCK(cx, CXt_SUB, SP);
1588 (void)SvREFCNT_inc(cv);
1589 SAVEVPTR(PL_curpad);
1590 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1591 RETURNOP(CvSTART(cv));
1605 register PERL_CONTEXT *cx;
1606 I32 gimme = GIMME_V;
1608 U32 cxtype = CXt_LOOP;
1616 #ifdef USE_5005THREADS
1617 if (PL_op->op_flags & OPf_SPECIAL) {
1618 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1619 SAVEGENERICSV(*svp);
1623 #endif /* USE_5005THREADS */
1624 if (PL_op->op_targ) {
1625 #ifndef USE_ITHREADS
1626 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1629 SAVEPADSV(PL_op->op_targ);
1630 iterdata = INT2PTR(void*, PL_op->op_targ);
1631 cxtype |= CXp_PADVAR;
1636 svp = &GvSV(gv); /* symbol table variable */
1637 SAVEGENERICSV(*svp);
1640 iterdata = (void*)gv;
1646 PUSHBLOCK(cx, cxtype, SP);
1648 PUSHLOOP(cx, iterdata, MARK);
1650 PUSHLOOP(cx, svp, MARK);
1652 if (PL_op->op_flags & OPf_STACKED) {
1653 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1654 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1656 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1657 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1658 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1659 looks_like_number((SV*)cx->blk_loop.iterary) &&
1660 *SvPVX(cx->blk_loop.iterary) != '0'))
1662 if (SvNV(sv) < IV_MIN ||
1663 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1664 DIE(aTHX_ "Range iterator outside integer range");
1665 cx->blk_loop.iterix = SvIV(sv);
1666 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1669 cx->blk_loop.iterlval = newSVsv(sv);
1673 cx->blk_loop.iterary = PL_curstack;
1674 AvFILLp(PL_curstack) = SP - PL_stack_base;
1675 cx->blk_loop.iterix = MARK - PL_stack_base;
1684 register PERL_CONTEXT *cx;
1685 I32 gimme = GIMME_V;
1691 PUSHBLOCK(cx, CXt_LOOP, SP);
1692 PUSHLOOP(cx, 0, SP);
1700 register PERL_CONTEXT *cx;
1708 newsp = PL_stack_base + cx->blk_loop.resetsp;
1711 if (gimme == G_VOID)
1713 else if (gimme == G_SCALAR) {
1715 *++newsp = sv_mortalcopy(*SP);
1717 *++newsp = &PL_sv_undef;
1721 *++newsp = sv_mortalcopy(*++mark);
1722 TAINT_NOT; /* Each item is independent */
1728 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1729 PL_curpm = newpm; /* ... and pop $1 et al */
1741 register PERL_CONTEXT *cx;
1742 bool popsub2 = FALSE;
1743 bool clear_errsv = FALSE;
1750 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1751 if (cxstack_ix == PL_sortcxix
1752 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1754 if (cxstack_ix > PL_sortcxix)
1755 dounwind(PL_sortcxix);
1756 AvARRAY(PL_curstack)[1] = *SP;
1757 PL_stack_sp = PL_stack_base + 1;
1762 cxix = dopoptosub(cxstack_ix);
1764 DIE(aTHX_ "Can't return outside a subroutine");
1765 if (cxix < cxstack_ix)
1769 switch (CxTYPE(cx)) {
1774 if (!(PL_in_eval & EVAL_KEEPERR))
1780 if (optype == OP_REQUIRE &&
1781 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1783 /* Unassume the success we assumed earlier. */
1784 SV *nsv = cx->blk_eval.old_namesv;
1785 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1786 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1793 DIE(aTHX_ "panic: return");
1797 if (gimme == G_SCALAR) {
1800 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1802 *++newsp = SvREFCNT_inc(*SP);
1807 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1809 *++newsp = sv_mortalcopy(sv);
1814 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1817 *++newsp = sv_mortalcopy(*SP);
1820 *++newsp = &PL_sv_undef;
1822 else if (gimme == G_ARRAY) {
1823 while (++MARK <= SP) {
1824 *++newsp = (popsub2 && SvTEMP(*MARK))
1825 ? *MARK : sv_mortalcopy(*MARK);
1826 TAINT_NOT; /* Each item is independent */
1829 PL_stack_sp = newsp;
1831 /* Stack values are safe: */
1833 POPSUB(cx,sv); /* release CV and @_ ... */
1837 PL_curpm = newpm; /* ... and pop $1 et al */
1843 return pop_return();
1850 register PERL_CONTEXT *cx;
1860 if (PL_op->op_flags & OPf_SPECIAL) {
1861 cxix = dopoptoloop(cxstack_ix);
1863 DIE(aTHX_ "Can't \"last\" outside a loop block");
1866 cxix = dopoptolabel(cPVOP->op_pv);
1868 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1870 if (cxix < cxstack_ix)
1875 switch (CxTYPE(cx)) {
1878 newsp = PL_stack_base + cx->blk_loop.resetsp;
1879 nextop = cx->blk_loop.last_op->op_next;
1883 nextop = pop_return();
1887 nextop = pop_return();
1891 nextop = pop_return();
1894 DIE(aTHX_ "panic: last");
1898 if (gimme == G_SCALAR) {
1900 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1901 ? *SP : sv_mortalcopy(*SP);
1903 *++newsp = &PL_sv_undef;
1905 else if (gimme == G_ARRAY) {
1906 while (++MARK <= SP) {
1907 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1908 ? *MARK : sv_mortalcopy(*MARK);
1909 TAINT_NOT; /* Each item is independent */
1915 /* Stack values are safe: */
1918 POPLOOP(cx); /* release loop vars ... */
1922 POPSUB(cx,sv); /* release CV and @_ ... */
1925 PL_curpm = newpm; /* ... and pop $1 et al */
1935 register PERL_CONTEXT *cx;
1938 if (PL_op->op_flags & OPf_SPECIAL) {
1939 cxix = dopoptoloop(cxstack_ix);
1941 DIE(aTHX_ "Can't \"next\" outside a loop block");
1944 cxix = dopoptolabel(cPVOP->op_pv);
1946 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1948 if (cxix < cxstack_ix)
1951 /* clear off anything above the scope we're re-entering, but
1952 * save the rest until after a possible continue block */
1953 inner = PL_scopestack_ix;
1955 if (PL_scopestack_ix < inner)
1956 leave_scope(PL_scopestack[PL_scopestack_ix]);
1957 return cx->blk_loop.next_op;
1963 register PERL_CONTEXT *cx;
1966 if (PL_op->op_flags & OPf_SPECIAL) {
1967 cxix = dopoptoloop(cxstack_ix);
1969 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1972 cxix = dopoptolabel(cPVOP->op_pv);
1974 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1976 if (cxix < cxstack_ix)
1980 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1981 LEAVE_SCOPE(oldsave);
1982 return cx->blk_loop.redo_op;
1986 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1990 static char too_deep[] = "Target of goto is too deeply nested";
1993 Perl_croak(aTHX_ too_deep);
1994 if (o->op_type == OP_LEAVE ||
1995 o->op_type == OP_SCOPE ||
1996 o->op_type == OP_LEAVELOOP ||
1997 o->op_type == OP_LEAVETRY)
1999 *ops++ = cUNOPo->op_first;
2001 Perl_croak(aTHX_ too_deep);
2004 if (o->op_flags & OPf_KIDS) {
2005 /* First try all the kids at this level, since that's likeliest. */
2006 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2007 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2008 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2011 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2012 if (kid == PL_lastgotoprobe)
2014 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2016 (ops[-1]->op_type != OP_NEXTSTATE &&
2017 ops[-1]->op_type != OP_DBSTATE)))
2019 if ((o = dofindlabel(kid, label, ops, oplimit)))
2038 register PERL_CONTEXT *cx;
2039 #define GOTO_DEPTH 64
2040 OP *enterops[GOTO_DEPTH];
2042 int do_dump = (PL_op->op_type == OP_DUMP);
2043 static char must_have_label[] = "goto must have label";
2046 if (PL_op->op_flags & OPf_STACKED) {
2050 /* This egregious kludge implements goto &subroutine */
2051 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2053 register PERL_CONTEXT *cx;
2054 CV* cv = (CV*)SvRV(sv);
2060 if (!CvROOT(cv) && !CvXSUB(cv)) {
2065 /* autoloaded stub? */
2066 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2068 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2069 GvNAMELEN(gv), FALSE);
2070 if (autogv && (cv = GvCV(autogv)))
2072 tmpstr = sv_newmortal();
2073 gv_efullname3(tmpstr, gv, Nullch);
2074 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2076 DIE(aTHX_ "Goto undefined subroutine");
2079 /* First do some returnish stuff. */
2080 cxix = dopoptosub(cxstack_ix);
2082 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2083 if (cxix < cxstack_ix)
2087 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2089 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2090 /* put @_ back onto stack */
2091 AV* av = cx->blk_sub.argarray;
2093 items = AvFILLp(av) + 1;
2095 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2096 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2097 PL_stack_sp += items;
2098 #ifndef USE_5005THREADS
2099 SvREFCNT_dec(GvAV(PL_defgv));
2100 GvAV(PL_defgv) = cx->blk_sub.savearray;
2101 #endif /* USE_5005THREADS */
2102 /* abandon @_ if it got reified */
2104 (void)sv_2mortal((SV*)av); /* delay until return */
2106 av_extend(av, items-1);
2107 AvFLAGS(av) = AVf_REIFY;
2108 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2111 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2113 #ifdef USE_5005THREADS
2114 av = (AV*)PL_curpad[0];
2116 av = GvAV(PL_defgv);
2118 items = AvFILLp(av) + 1;
2120 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2121 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2122 PL_stack_sp += items;
2124 if (CxTYPE(cx) == CXt_SUB &&
2125 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2126 SvREFCNT_dec(cx->blk_sub.cv);
2127 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2128 LEAVE_SCOPE(oldsave);
2130 /* Now do some callish stuff. */
2133 #ifdef PERL_XSUB_OLDSTYLE
2134 if (CvOLDSTYLE(cv)) {
2135 I32 (*fp3)(int,int,int);
2140 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2141 items = (*fp3)(CvXSUBANY(cv).any_i32,
2142 mark - PL_stack_base + 1,
2144 SP = PL_stack_base + items;
2147 #endif /* PERL_XSUB_OLDSTYLE */
2152 PL_stack_sp--; /* There is no cv arg. */
2153 /* Push a mark for the start of arglist */
2155 (void)(*CvXSUB(cv))(aTHX_ cv);
2156 /* Pop the current context like a decent sub should */
2157 POPBLOCK(cx, PL_curpm);
2158 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2161 return pop_return();
2164 AV* padlist = CvPADLIST(cv);
2165 SV** svp = AvARRAY(padlist);
2166 if (CxTYPE(cx) == CXt_EVAL) {
2167 PL_in_eval = cx->blk_eval.old_in_eval;
2168 PL_eval_root = cx->blk_eval.old_eval_root;
2169 cx->cx_type = CXt_SUB;
2170 cx->blk_sub.hasargs = 0;
2172 cx->blk_sub.cv = cv;
2173 cx->blk_sub.olddepth = CvDEPTH(cv);
2175 if (CvDEPTH(cv) < 2)
2176 (void)SvREFCNT_inc(cv);
2177 else { /* save temporaries on recursion? */
2178 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2179 sub_crush_depth(cv);
2180 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2181 AV *newpad = newAV();
2182 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2183 I32 ix = AvFILLp((AV*)svp[1]);
2184 I32 names_fill = AvFILLp((AV*)svp[0]);
2185 svp = AvARRAY(svp[0]);
2186 for ( ;ix > 0; ix--) {
2187 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2188 char *name = SvPVX(svp[ix]);
2189 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2192 /* outer lexical or anon code */
2193 av_store(newpad, ix,
2194 SvREFCNT_inc(oldpad[ix]) );
2196 else { /* our own lexical */
2198 av_store(newpad, ix, sv = (SV*)newAV());
2199 else if (*name == '%')
2200 av_store(newpad, ix, sv = (SV*)newHV());
2202 av_store(newpad, ix, sv = NEWSV(0,0));
2206 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2207 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2210 av_store(newpad, ix, sv = NEWSV(0,0));
2214 if (cx->blk_sub.hasargs) {
2217 av_store(newpad, 0, (SV*)av);
2218 AvFLAGS(av) = AVf_REIFY;
2220 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2221 AvFILLp(padlist) = CvDEPTH(cv);
2222 svp = AvARRAY(padlist);
2225 #ifdef USE_5005THREADS
2226 if (!cx->blk_sub.hasargs) {
2227 AV* av = (AV*)PL_curpad[0];
2229 items = AvFILLp(av) + 1;
2231 /* Mark is at the end of the stack. */
2233 Copy(AvARRAY(av), SP + 1, items, SV*);
2238 #endif /* USE_5005THREADS */
2239 SAVEVPTR(PL_curpad);
2240 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2241 #ifndef USE_5005THREADS
2242 if (cx->blk_sub.hasargs)
2243 #endif /* USE_5005THREADS */
2245 AV* av = (AV*)PL_curpad[0];
2248 #ifndef USE_5005THREADS
2249 cx->blk_sub.savearray = GvAV(PL_defgv);
2250 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2251 #endif /* USE_5005THREADS */
2252 cx->blk_sub.oldcurpad = PL_curpad;
2253 cx->blk_sub.argarray = av;
2256 if (items >= AvMAX(av) + 1) {
2258 if (AvARRAY(av) != ary) {
2259 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2260 SvPVX(av) = (char*)ary;
2262 if (items >= AvMAX(av) + 1) {
2263 AvMAX(av) = items - 1;
2264 Renew(ary,items+1,SV*);
2266 SvPVX(av) = (char*)ary;
2269 Copy(mark,AvARRAY(av),items,SV*);
2270 AvFILLp(av) = items - 1;
2271 assert(!AvREAL(av));
2278 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2280 * We do not care about using sv to call CV;
2281 * it's for informational purposes only.
2283 SV *sv = GvSV(PL_DBsub);
2286 if (PERLDB_SUB_NN) {
2287 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2290 gv_efullname3(sv, CvGV(cv), Nullch);
2293 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2294 PUSHMARK( PL_stack_sp );
2295 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2299 RETURNOP(CvSTART(cv));
2303 label = SvPV(sv,n_a);
2304 if (!(do_dump || *label))
2305 DIE(aTHX_ must_have_label);
2308 else if (PL_op->op_flags & OPf_SPECIAL) {
2310 DIE(aTHX_ must_have_label);
2313 label = cPVOP->op_pv;
2315 if (label && *label) {
2317 bool leaving_eval = FALSE;
2318 PERL_CONTEXT *last_eval_cx = 0;
2322 PL_lastgotoprobe = 0;
2324 for (ix = cxstack_ix; ix >= 0; ix--) {
2326 switch (CxTYPE(cx)) {
2328 leaving_eval = TRUE;
2329 if (CxREALEVAL(cx)) {
2330 gotoprobe = (last_eval_cx ?
2331 last_eval_cx->blk_eval.old_eval_root :
2336 /* else fall through */
2338 gotoprobe = cx->blk_oldcop->op_sibling;
2344 gotoprobe = cx->blk_oldcop->op_sibling;
2346 gotoprobe = PL_main_root;
2349 if (CvDEPTH(cx->blk_sub.cv)) {
2350 gotoprobe = CvROOT(cx->blk_sub.cv);
2356 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2359 DIE(aTHX_ "panic: goto");
2360 gotoprobe = PL_main_root;
2364 retop = dofindlabel(gotoprobe, label,
2365 enterops, enterops + GOTO_DEPTH);
2369 PL_lastgotoprobe = gotoprobe;
2372 DIE(aTHX_ "Can't find label %s", label);
2374 /* if we're leaving an eval, check before we pop any frames
2375 that we're not going to punt, otherwise the error
2378 if (leaving_eval && *enterops && enterops[1]) {
2380 for (i = 1; enterops[i]; i++)
2381 if (enterops[i]->op_type == OP_ENTERITER)
2382 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2385 /* pop unwanted frames */
2387 if (ix < cxstack_ix) {
2394 oldsave = PL_scopestack[PL_scopestack_ix];
2395 LEAVE_SCOPE(oldsave);
2398 /* push wanted frames */
2400 if (*enterops && enterops[1]) {
2402 for (ix = 1; enterops[ix]; ix++) {
2403 PL_op = enterops[ix];
2404 /* Eventually we may want to stack the needed arguments
2405 * for each op. For now, we punt on the hard ones. */
2406 if (PL_op->op_type == OP_ENTERITER)
2407 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2408 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2416 if (!retop) retop = PL_main_start;
2418 PL_restartop = retop;
2419 PL_do_undump = TRUE;
2423 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2424 PL_do_undump = FALSE;
2440 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2442 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2445 PL_exit_flags |= PERL_EXIT_EXPECTED;
2447 PUSHs(&PL_sv_undef);
2455 NV value = SvNVx(GvSV(cCOP->cop_gv));
2456 register I32 match = I_32(value);
2459 if (((NV)match) > value)
2460 --match; /* was fractional--truncate other way */
2462 match -= cCOP->uop.scop.scop_offset;
2465 else if (match > cCOP->uop.scop.scop_max)
2466 match = cCOP->uop.scop.scop_max;
2467 PL_op = cCOP->uop.scop.scop_next[match];
2477 PL_op = PL_op->op_next; /* can't assume anything */
2480 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2481 match -= cCOP->uop.scop.scop_offset;
2484 else if (match > cCOP->uop.scop.scop_max)
2485 match = cCOP->uop.scop.scop_max;
2486 PL_op = cCOP->uop.scop.scop_next[match];
2495 S_save_lines(pTHX_ AV *array, SV *sv)
2497 register char *s = SvPVX(sv);
2498 register char *send = SvPVX(sv) + SvCUR(sv);
2500 register I32 line = 1;
2502 while (s && s < send) {
2503 SV *tmpstr = NEWSV(85,0);
2505 sv_upgrade(tmpstr, SVt_PVMG);
2506 t = strchr(s, '\n');
2512 sv_setpvn(tmpstr, s, t - s);
2513 av_store(array, line++, tmpstr);
2518 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2520 S_docatch_body(pTHX_ va_list args)
2522 return docatch_body();
2527 S_docatch_body(pTHX)
2534 S_docatch(pTHX_ OP *o)
2539 volatile PERL_SI *cursi = PL_curstackinfo;
2543 assert(CATCH_GET == TRUE);
2547 /* Normally, the leavetry at the end of this block of ops will
2548 * pop an op off the return stack and continue there. By setting
2549 * the op to Nullop, we force an exit from the inner runops()
2552 retop = pop_return();
2553 push_return(Nullop);
2555 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2557 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2563 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2569 /* die caught by an inner eval - continue inner loop */
2570 if (PL_restartop && cursi == PL_curstackinfo) {
2571 PL_op = PL_restartop;
2575 /* a die in this eval - continue in outer loop */
2591 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2592 /* sv Text to convert to OP tree. */
2593 /* startop op_free() this to undo. */
2594 /* code Short string id of the caller. */
2596 dSP; /* Make POPBLOCK work. */
2599 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2603 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2604 char *tmpbuf = tbuf;
2610 /* switch to eval mode */
2612 if (PL_curcop == &PL_compiling) {
2613 SAVECOPSTASH_FREE(&PL_compiling);
2614 CopSTASH_set(&PL_compiling, PL_curstash);
2616 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2617 SV *sv = sv_newmortal();
2618 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2619 code, (unsigned long)++PL_evalseq,
2620 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2624 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2625 SAVECOPFILE_FREE(&PL_compiling);
2626 CopFILE_set(&PL_compiling, tmpbuf+2);
2627 SAVECOPLINE(&PL_compiling);
2628 CopLINE_set(&PL_compiling, 1);
2629 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2630 deleting the eval's FILEGV from the stash before gv_check() runs
2631 (i.e. before run-time proper). To work around the coredump that
2632 ensues, we always turn GvMULTI_on for any globals that were
2633 introduced within evals. See force_ident(). GSAR 96-10-12 */
2634 safestr = savepv(tmpbuf);
2635 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2637 #ifdef OP_IN_REGISTER
2642 PL_hints &= HINT_UTF8;
2645 PL_op->op_type = OP_ENTEREVAL;
2646 PL_op->op_flags = 0; /* Avoid uninit warning. */
2647 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2648 PUSHEVAL(cx, 0, Nullgv);
2649 rop = doeval(G_SCALAR, startop);
2650 POPBLOCK(cx,PL_curpm);
2653 (*startop)->op_type = OP_NULL;
2654 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2656 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2658 if (PL_curcop == &PL_compiling)
2659 PL_compiling.op_private = PL_hints;
2660 #ifdef OP_IN_REGISTER
2666 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2668 S_doeval(pTHX_ int gimme, OP** startop)
2676 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2677 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2682 /* set up a scratch pad */
2685 SAVEVPTR(PL_curpad);
2686 SAVESPTR(PL_comppad);
2687 SAVESPTR(PL_comppad_name);
2688 SAVEI32(PL_comppad_name_fill);
2689 SAVEI32(PL_min_intro_pending);
2690 SAVEI32(PL_max_intro_pending);
2693 for (i = cxstack_ix - 1; i >= 0; i--) {
2694 PERL_CONTEXT *cx = &cxstack[i];
2695 if (CxTYPE(cx) == CXt_EVAL)
2697 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2698 caller = cx->blk_sub.cv;
2703 SAVESPTR(PL_compcv);
2704 PL_compcv = (CV*)NEWSV(1104,0);
2705 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2706 CvEVAL_on(PL_compcv);
2707 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2708 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2710 #ifdef USE_5005THREADS
2711 CvOWNER(PL_compcv) = 0;
2712 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2713 MUTEX_INIT(CvMUTEXP(PL_compcv));
2714 #endif /* USE_5005THREADS */
2716 PL_comppad = newAV();
2717 av_push(PL_comppad, Nullsv);
2718 PL_curpad = AvARRAY(PL_comppad);
2719 PL_comppad_name = newAV();
2720 PL_comppad_name_fill = 0;
2721 PL_min_intro_pending = 0;
2723 #ifdef USE_5005THREADS
2724 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2725 PL_curpad[0] = (SV*)newAV();
2726 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2727 #endif /* USE_5005THREADS */
2729 comppadlist = newAV();
2730 AvREAL_off(comppadlist);
2731 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2732 av_store(comppadlist, 1, (SV*)PL_comppad);
2733 CvPADLIST(PL_compcv) = comppadlist;
2736 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2738 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2741 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2743 /* make sure we compile in the right package */
2745 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2746 SAVESPTR(PL_curstash);
2747 PL_curstash = CopSTASH(PL_curcop);
2749 SAVESPTR(PL_beginav);
2750 PL_beginav = newAV();
2751 SAVEFREESV(PL_beginav);
2752 SAVEI32(PL_error_count);
2754 /* try to compile it */
2756 PL_eval_root = Nullop;
2758 PL_curcop = &PL_compiling;
2759 PL_curcop->cop_arybase = 0;
2760 if (saveop && saveop->op_flags & OPf_SPECIAL)
2761 PL_in_eval |= EVAL_KEEPERR;
2764 if (yyparse() || PL_error_count || !PL_eval_root) {
2768 I32 optype = 0; /* Might be reset by POPEVAL. */
2773 op_free(PL_eval_root);
2774 PL_eval_root = Nullop;
2776 SP = PL_stack_base + POPMARK; /* pop original mark */
2778 POPBLOCK(cx,PL_curpm);
2784 if (optype == OP_REQUIRE) {
2785 char* msg = SvPVx(ERRSV, n_a);
2786 DIE(aTHX_ "%sCompilation failed in require",
2787 *msg ? msg : "Unknown error\n");
2790 char* msg = SvPVx(ERRSV, n_a);
2792 POPBLOCK(cx,PL_curpm);
2794 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2795 (*msg ? msg : "Unknown error\n"));
2797 #ifdef USE_5005THREADS
2798 MUTEX_LOCK(&PL_eval_mutex);
2800 COND_SIGNAL(&PL_eval_cond);
2801 MUTEX_UNLOCK(&PL_eval_mutex);
2802 #endif /* USE_5005THREADS */
2805 CopLINE_set(&PL_compiling, 0);
2807 *startop = PL_eval_root;
2808 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2809 CvOUTSIDE(PL_compcv) = Nullcv;
2811 SAVEFREEOP(PL_eval_root);
2813 scalarvoid(PL_eval_root);
2814 else if (gimme & G_ARRAY)
2817 scalar(PL_eval_root);
2819 DEBUG_x(dump_eval());
2821 /* Register with debugger: */
2822 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2823 CV *cv = get_cv("DB::postponed", FALSE);
2827 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2829 call_sv((SV*)cv, G_DISCARD);
2833 /* compiled okay, so do it */
2835 CvDEPTH(PL_compcv) = 1;
2836 SP = PL_stack_base + POPMARK; /* pop original mark */
2837 PL_op = saveop; /* The caller may need it. */
2838 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2839 #ifdef USE_5005THREADS
2840 MUTEX_LOCK(&PL_eval_mutex);
2842 COND_SIGNAL(&PL_eval_cond);
2843 MUTEX_UNLOCK(&PL_eval_mutex);
2844 #endif /* USE_5005THREADS */
2846 RETURNOP(PL_eval_start);
2850 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2852 STRLEN namelen = strlen(name);
2855 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2856 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2857 char *pmc = SvPV_nolen(pmcsv);
2860 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2861 fp = PerlIO_open(name, mode);
2864 if (PerlLIO_stat(name, &pmstat) < 0 ||
2865 pmstat.st_mtime < pmcstat.st_mtime)
2867 fp = PerlIO_open(pmc, mode);
2870 fp = PerlIO_open(name, mode);
2873 SvREFCNT_dec(pmcsv);
2876 fp = PerlIO_open(name, mode);
2884 register PERL_CONTEXT *cx;
2888 char *tryname = Nullch;
2889 SV *namesv = Nullsv;
2891 I32 gimme = GIMME_V;
2892 PerlIO *tryrsfp = 0;
2894 int filter_has_file = 0;
2895 GV *filter_child_proc = 0;
2896 SV *filter_state = 0;
2903 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2904 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2905 UV rev = 0, ver = 0, sver = 0;
2907 U8 *s = (U8*)SvPVX(sv);
2908 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2910 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2913 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2916 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2919 if (PERL_REVISION < rev
2920 || (PERL_REVISION == rev
2921 && (PERL_VERSION < ver
2922 || (PERL_VERSION == ver
2923 && PERL_SUBVERSION < sver))))
2925 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2926 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2927 PERL_VERSION, PERL_SUBVERSION);
2929 if (ckWARN(WARN_PORTABLE))
2930 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2931 "v-string in use/require non-portable");
2934 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2935 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2936 + ((NV)PERL_SUBVERSION/(NV)1000000)
2937 + 0.00000099 < SvNV(sv))
2941 NV nver = (nrev - rev) * 1000;
2942 UV ver = (UV)(nver + 0.0009);
2943 NV nsver = (nver - ver) * 1000;
2944 UV sver = (UV)(nsver + 0.0009);
2946 /* help out with the "use 5.6" confusion */
2947 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2948 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2949 "this is only v%d.%d.%d, stopped"
2950 " (did you mean v%"UVuf".%03"UVuf"?)",
2951 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2952 PERL_SUBVERSION, rev, ver/100);
2955 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2956 "this is only v%d.%d.%d, stopped",
2957 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2964 name = SvPV(sv, len);
2965 if (!(name && len > 0 && *name))
2966 DIE(aTHX_ "Null filename used");
2967 TAINT_PROPER("require");
2968 if (PL_op->op_type == OP_REQUIRE &&
2969 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2970 *svp != &PL_sv_undef)
2973 /* prepare to compile file */
2975 if (path_is_absolute(name)) {
2977 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2980 AV *ar = GvAVn(PL_incgv);
2984 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2987 namesv = NEWSV(806, 0);
2988 for (i = 0; i <= AvFILL(ar); i++) {
2989 SV *dirsv = *av_fetch(ar, i, TRUE);
2995 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2996 && !sv_isobject(loader))
2998 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3001 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3002 PTR2UV(SvRV(dirsv)), name);
3003 tryname = SvPVX(namesv);
3014 if (sv_isobject(loader))
3015 count = call_method("INC", G_ARRAY);
3017 count = call_sv(loader, G_ARRAY);
3027 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3031 if (SvTYPE(arg) == SVt_PVGV) {
3032 IO *io = GvIO((GV *)arg);
3037 tryrsfp = IoIFP(io);
3038 if (IoTYPE(io) == IoTYPE_PIPE) {
3039 /* reading from a child process doesn't
3040 nest -- when returning from reading
3041 the inner module, the outer one is
3042 unreadable (closed?) I've tried to
3043 save the gv to manage the lifespan of
3044 the pipe, but this didn't help. XXX */
3045 filter_child_proc = (GV *)arg;
3046 (void)SvREFCNT_inc(filter_child_proc);
3049 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3050 PerlIO_close(IoOFP(io));
3062 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3064 (void)SvREFCNT_inc(filter_sub);
3067 filter_state = SP[i];
3068 (void)SvREFCNT_inc(filter_state);
3072 tryrsfp = PerlIO_open("/dev/null",
3087 filter_has_file = 0;
3088 if (filter_child_proc) {
3089 SvREFCNT_dec(filter_child_proc);
3090 filter_child_proc = 0;
3093 SvREFCNT_dec(filter_state);
3097 SvREFCNT_dec(filter_sub);
3102 if (!path_is_absolute(name)
3103 #ifdef MACOS_TRADITIONAL
3104 /* We consider paths of the form :a:b ambiguous and interpret them first
3105 as global then as local
3107 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3110 char *dir = SvPVx(dirsv, n_a);
3111 #ifdef MACOS_TRADITIONAL
3113 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3117 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3119 sv_setpv(namesv, unixdir);
3120 sv_catpv(namesv, unixname);
3122 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3125 TAINT_PROPER("require");
3126 tryname = SvPVX(namesv);
3127 #ifdef MACOS_TRADITIONAL
3129 /* Convert slashes in the name part, but not the directory part, to colons */
3131 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3135 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3137 if (tryname[0] == '.' && tryname[1] == '/')
3146 SAVECOPFILE_FREE(&PL_compiling);
3147 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3148 SvREFCNT_dec(namesv);
3150 if (PL_op->op_type == OP_REQUIRE) {
3151 char *msgstr = name;
3152 if (namesv) { /* did we lookup @INC? */
3153 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3154 SV *dirmsgsv = NEWSV(0, 0);
3155 AV *ar = GvAVn(PL_incgv);
3157 sv_catpvn(msg, " in @INC", 8);
3158 if (instr(SvPVX(msg), ".h "))
3159 sv_catpv(msg, " (change .h to .ph maybe?)");
3160 if (instr(SvPVX(msg), ".ph "))
3161 sv_catpv(msg, " (did you run h2ph?)");
3162 sv_catpv(msg, " (@INC contains:");
3163 for (i = 0; i <= AvFILL(ar); i++) {
3164 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3165 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3166 sv_catsv(msg, dirmsgsv);
3168 sv_catpvn(msg, ")", 1);
3169 SvREFCNT_dec(dirmsgsv);
3170 msgstr = SvPV_nolen(msg);
3172 DIE(aTHX_ "Can't locate %s", msgstr);
3178 SETERRNO(0, SS$_NORMAL);
3180 /* Assume success here to prevent recursive requirement. */
3182 /* Check whether a hook in @INC has already filled %INC */
3183 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3184 (void)hv_store(GvHVn(PL_incgv), name, len,
3185 (hook_sv ? SvREFCNT_inc(hook_sv)
3186 : newSVpv(CopFILE(&PL_compiling), 0)),
3192 lex_start(sv_2mortal(newSVpvn("",0)));
3193 SAVEGENERICSV(PL_rsfp_filters);
3194 PL_rsfp_filters = Nullav;
3199 SAVESPTR(PL_compiling.cop_warnings);
3200 if (PL_dowarn & G_WARN_ALL_ON)
3201 PL_compiling.cop_warnings = pWARN_ALL ;
3202 else if (PL_dowarn & G_WARN_ALL_OFF)
3203 PL_compiling.cop_warnings = pWARN_NONE ;
3204 else if (PL_taint_warn)
3205 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3207 PL_compiling.cop_warnings = pWARN_STD ;
3208 SAVESPTR(PL_compiling.cop_io);
3209 PL_compiling.cop_io = Nullsv;
3211 if (filter_sub || filter_child_proc) {
3212 SV *datasv = filter_add(run_user_filter, Nullsv);
3213 IoLINES(datasv) = filter_has_file;
3214 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3215 IoTOP_GV(datasv) = (GV *)filter_state;
3216 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3219 /* switch to eval mode */
3220 push_return(PL_op->op_next);
3221 PUSHBLOCK(cx, CXt_EVAL, SP);
3222 PUSHEVAL(cx, name, Nullgv);
3224 SAVECOPLINE(&PL_compiling);
3225 CopLINE_set(&PL_compiling, 0);
3228 #ifdef USE_5005THREADS
3229 MUTEX_LOCK(&PL_eval_mutex);
3230 if (PL_eval_owner && PL_eval_owner != thr)
3231 while (PL_eval_owner)
3232 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3233 PL_eval_owner = thr;
3234 MUTEX_UNLOCK(&PL_eval_mutex);
3235 #endif /* USE_5005THREADS */
3237 /* Store and reset encoding. */
3238 encoding = PL_encoding;
3239 PL_encoding = Nullsv;
3241 op = DOCATCH(doeval(gimme, NULL));
3243 /* Restore encoding. */
3244 PL_encoding = encoding;
3251 return pp_require();
3257 register PERL_CONTEXT *cx;
3259 I32 gimme = GIMME_V, was = PL_sub_generation;
3260 char tbuf[TYPE_DIGITS(long) + 12];
3261 char *tmpbuf = tbuf;
3266 if (!SvPV(sv,len) || !len)
3268 TAINT_PROPER("eval");
3274 /* switch to eval mode */
3276 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3277 SV *sv = sv_newmortal();
3278 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3279 (unsigned long)++PL_evalseq,
3280 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3284 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3285 SAVECOPFILE_FREE(&PL_compiling);
3286 CopFILE_set(&PL_compiling, tmpbuf+2);
3287 SAVECOPLINE(&PL_compiling);
3288 CopLINE_set(&PL_compiling, 1);
3289 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3290 deleting the eval's FILEGV from the stash before gv_check() runs
3291 (i.e. before run-time proper). To work around the coredump that
3292 ensues, we always turn GvMULTI_on for any globals that were
3293 introduced within evals. See force_ident(). GSAR 96-10-12 */
3294 safestr = savepv(tmpbuf);
3295 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3297 PL_hints = PL_op->op_targ;
3298 SAVESPTR(PL_compiling.cop_warnings);
3299 if (specialWARN(PL_curcop->cop_warnings))
3300 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3302 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3303 SAVEFREESV(PL_compiling.cop_warnings);
3305 SAVESPTR(PL_compiling.cop_io);
3306 if (specialCopIO(PL_curcop->cop_io))
3307 PL_compiling.cop_io = PL_curcop->cop_io;
3309 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3310 SAVEFREESV(PL_compiling.cop_io);
3313 push_return(PL_op->op_next);
3314 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3315 PUSHEVAL(cx, 0, Nullgv);
3317 /* prepare to compile string */
3319 if (PERLDB_LINE && PL_curstash != PL_debstash)
3320 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3322 #ifdef USE_5005THREADS
3323 MUTEX_LOCK(&PL_eval_mutex);
3324 if (PL_eval_owner && PL_eval_owner != thr)
3325 while (PL_eval_owner)
3326 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3327 PL_eval_owner = thr;
3328 MUTEX_UNLOCK(&PL_eval_mutex);
3329 #endif /* USE_5005THREADS */
3330 ret = doeval(gimme, NULL);
3331 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3332 && ret != PL_op->op_next) { /* Successive compilation. */
3333 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3335 return DOCATCH(ret);
3345 register PERL_CONTEXT *cx;
3347 U8 save_flags = PL_op -> op_flags;
3352 retop = pop_return();
3355 if (gimme == G_VOID)
3357 else if (gimme == G_SCALAR) {
3360 if (SvFLAGS(TOPs) & SVs_TEMP)
3363 *MARK = sv_mortalcopy(TOPs);
3367 *MARK = &PL_sv_undef;
3372 /* in case LEAVE wipes old return values */
3373 for (mark = newsp + 1; mark <= SP; mark++) {
3374 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3375 *mark = sv_mortalcopy(*mark);
3376 TAINT_NOT; /* Each item is independent */
3380 PL_curpm = newpm; /* Don't pop $1 et al till now */
3383 assert(CvDEPTH(PL_compcv) == 1);
3385 CvDEPTH(PL_compcv) = 0;
3388 if (optype == OP_REQUIRE &&
3389 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3391 /* Unassume the success we assumed earlier. */
3392 SV *nsv = cx->blk_eval.old_namesv;
3393 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3394 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3395 /* die_where() did LEAVE, or we won't be here */
3399 if (!(save_flags & OPf_SPECIAL))
3409 register PERL_CONTEXT *cx;
3410 I32 gimme = GIMME_V;
3415 push_return(cLOGOP->op_other->op_next);
3416 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3419 PL_in_eval = EVAL_INEVAL;
3422 return DOCATCH(PL_op->op_next);
3433 register PERL_CONTEXT *cx;
3438 retop = pop_return();
3441 if (gimme == G_VOID)
3443 else if (gimme == G_SCALAR) {
3446 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3449 *MARK = sv_mortalcopy(TOPs);
3453 *MARK = &PL_sv_undef;
3458 /* in case LEAVE wipes old return values */
3459 for (mark = newsp + 1; mark <= SP; mark++) {
3460 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3461 *mark = sv_mortalcopy(*mark);
3462 TAINT_NOT; /* Each item is independent */
3466 PL_curpm = newpm; /* Don't pop $1 et al till now */
3474 S_doparseform(pTHX_ SV *sv)
3477 register char *s = SvPV_force(sv, len);
3478 register char *send = s + len;
3479 register char *base = Nullch;
3480 register I32 skipspaces = 0;
3481 bool noblank = FALSE;
3482 bool repeat = FALSE;
3483 bool postspace = FALSE;
3491 Perl_croak(aTHX_ "Null picture in formline");
3493 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3498 *fpc++ = FF_LINEMARK;
3499 noblank = repeat = FALSE;
3517 case ' ': case '\t':
3528 *fpc++ = FF_LITERAL;
3536 *fpc++ = skipspaces;
3540 *fpc++ = FF_NEWLINE;
3544 arg = fpc - linepc + 1;
3551 *fpc++ = FF_LINEMARK;
3552 noblank = repeat = FALSE;
3561 ischop = s[-1] == '^';
3567 arg = (s - base) - 1;
3569 *fpc++ = FF_LITERAL;
3578 *fpc++ = FF_LINEGLOB;
3580 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3581 arg = ischop ? 512 : 0;
3591 arg |= 256 + (s - f);
3593 *fpc++ = s - base; /* fieldsize for FETCH */
3594 *fpc++ = FF_DECIMAL;
3597 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3598 arg = ischop ? 512 : 0;
3600 s++; /* skip the '0' first */
3609 arg |= 256 + (s - f);
3611 *fpc++ = s - base; /* fieldsize for FETCH */
3612 *fpc++ = FF_0DECIMAL;
3617 bool ismore = FALSE;
3620 while (*++s == '>') ;
3621 prespace = FF_SPACE;
3623 else if (*s == '|') {
3624 while (*++s == '|') ;
3625 prespace = FF_HALFSPACE;
3630 while (*++s == '<') ;
3633 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3637 *fpc++ = s - base; /* fieldsize for FETCH */
3639 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3657 { /* need to jump to the next word */
3659 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3660 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3661 s = SvPVX(sv) + SvCUR(sv) + z;
3663 Copy(fops, s, arg, U16);
3665 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3670 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3672 SV *datasv = FILTER_DATA(idx);
3673 int filter_has_file = IoLINES(datasv);
3674 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3675 SV *filter_state = (SV *)IoTOP_GV(datasv);
3676 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3679 /* I was having segfault trouble under Linux 2.2.5 after a
3680 parse error occured. (Had to hack around it with a test
3681 for PL_error_count == 0.) Solaris doesn't segfault --
3682 not sure where the trouble is yet. XXX */
3684 if (filter_has_file) {
3685 len = FILTER_READ(idx+1, buf_sv, maxlen);
3688 if (filter_sub && len >= 0) {
3699 PUSHs(sv_2mortal(newSViv(maxlen)));
3701 PUSHs(filter_state);
3704 count = call_sv(filter_sub, G_SCALAR);
3720 IoLINES(datasv) = 0;
3721 if (filter_child_proc) {
3722 SvREFCNT_dec(filter_child_proc);
3723 IoFMT_GV(datasv) = Nullgv;
3726 SvREFCNT_dec(filter_state);
3727 IoTOP_GV(datasv) = Nullgv;
3730 SvREFCNT_dec(filter_sub);
3731 IoBOTTOM_GV(datasv) = Nullgv;
3733 filter_del(run_user_filter);
3739 /* perhaps someone can come up with a better name for
3740 this? it is not really "absolute", per se ... */
3742 S_path_is_absolute(pTHX_ char *name)
3744 if (PERL_FILE_IS_ABSOLUTE(name)
3745 #ifdef MACOS_TRADITIONAL
3746 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3748 || (*name == '.' && (name[1] == '/' ||
3749 (name[1] == '.' && name[2] == '/'))))