3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
161 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
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);
186 Safefree(SvPVX(targ));
187 SvPVX(targ) = SvPVX(dstr);
188 SvCUR_set(targ, SvCUR(dstr));
189 SvLEN_set(targ, SvLEN(dstr));
195 TAINT_IF(cx->sb_rxtainted & 1);
196 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
198 (void)SvPOK_only_UTF8(targ);
199 TAINT_IF(cx->sb_rxtainted);
203 LEAVE_SCOPE(cx->sb_oldsave);
205 RETURNOP(pm->op_next);
207 cx->sb_iters = saviters;
209 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
212 cx->sb_orig = orig = rx->subbeg;
214 cx->sb_strend = s + (cx->sb_strend - m);
216 cx->sb_m = m = rx->startp[0] + orig;
218 sv_catpvn(dstr, s, m-s);
219 cx->sb_s = rx->endp[0] + orig;
220 { /* Update the pos() information. */
221 SV *sv = cx->sb_targ;
224 if (SvTYPE(sv) < SVt_PVMG)
225 (void)SvUPGRADE(sv, SVt_PVMG);
226 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
227 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
228 mg = mg_find(sv, PERL_MAGIC_regex_global);
235 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
236 rxres_save(&cx->sb_rxres, rx);
237 RETURNOP(pm->op_pmreplstart);
241 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
246 if (!p || p[1] < rx->nparens) {
247 i = 6 + rx->nparens * 2;
255 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
256 RX_MATCH_COPIED_off(rx);
260 *p++ = PTR2UV(rx->subbeg);
261 *p++ = (UV)rx->sublen;
262 for (i = 0; i <= rx->nparens; ++i) {
263 *p++ = (UV)rx->startp[i];
264 *p++ = (UV)rx->endp[i];
269 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
274 if (RX_MATCH_COPIED(rx))
275 Safefree(rx->subbeg);
276 RX_MATCH_COPIED_set(rx, *p);
281 rx->subbeg = INT2PTR(char*,*p++);
282 rx->sublen = (I32)(*p++);
283 for (i = 0; i <= rx->nparens; ++i) {
284 rx->startp[i] = (I32)(*p++);
285 rx->endp[i] = (I32)(*p++);
290 Perl_rxres_free(pTHX_ void **rsp)
295 Safefree(INT2PTR(char*,*p));
303 dSP; dMARK; dORIGMARK;
304 register SV *tmpForm = *++MARK;
311 register SV *sv = Nullsv;
316 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
317 char *chophere = Nullch;
318 char *linemark = Nullch;
320 bool gotsome = FALSE;
322 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
323 bool item_is_utf = FALSE;
325 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
326 if (SvREADONLY(tmpForm)) {
327 SvREADONLY_off(tmpForm);
328 doparseform(tmpForm);
329 SvREADONLY_on(tmpForm);
332 doparseform(tmpForm);
335 SvPV_force(PL_formtarget, len);
336 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
338 f = SvPV(tmpForm, len);
339 /* need to jump to the next word */
340 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
349 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
350 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
351 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
352 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
353 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
355 case FF_CHECKNL: name = "CHECKNL"; break;
356 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
357 case FF_SPACE: name = "SPACE"; break;
358 case FF_HALFSPACE: name = "HALFSPACE"; break;
359 case FF_ITEM: name = "ITEM"; break;
360 case FF_CHOP: name = "CHOP"; break;
361 case FF_LINEGLOB: name = "LINEGLOB"; break;
362 case FF_NEWLINE: name = "NEWLINE"; break;
363 case FF_MORE: name = "MORE"; break;
364 case FF_LINEMARK: name = "LINEMARK"; break;
365 case FF_END: name = "END"; break;
366 case FF_0DECIMAL: name = "0DECIMAL"; break;
369 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
371 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
399 if (ckWARN(WARN_SYNTAX))
400 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
405 item = s = SvPV(sv, len);
408 itemsize = sv_len_utf8(sv);
409 if (itemsize != (I32)len) {
411 if (itemsize > fieldsize) {
412 itemsize = fieldsize;
413 itembytes = itemsize;
414 sv_pos_u2b(sv, &itembytes, 0);
418 send = chophere = s + itembytes;
428 sv_pos_b2u(sv, &itemsize);
433 if (itemsize > fieldsize)
434 itemsize = fieldsize;
435 send = chophere = s + itemsize;
447 item = s = SvPV(sv, len);
450 itemsize = sv_len_utf8(sv);
451 if (itemsize != (I32)len) {
453 if (itemsize <= fieldsize) {
454 send = chophere = s + itemsize;
465 itemsize = fieldsize;
466 itembytes = itemsize;
467 sv_pos_u2b(sv, &itembytes, 0);
468 send = chophere = s + itembytes;
469 while (s < send || (s == send && isSPACE(*s))) {
479 if (strchr(PL_chopset, *s))
484 itemsize = chophere - item;
485 sv_pos_b2u(sv, &itemsize);
492 if (itemsize <= fieldsize) {
493 send = chophere = s + itemsize;
504 itemsize = fieldsize;
505 send = chophere = s + itemsize;
506 while (s < send || (s == send && isSPACE(*s))) {
516 if (strchr(PL_chopset, *s))
521 itemsize = chophere - item;
526 arg = fieldsize - itemsize;
535 arg = fieldsize - itemsize;
549 if (UTF8_IS_CONTINUED(*s)) {
550 STRLEN skip = UTF8SKIP(s);
567 if ( !((*t++ = *s++) & ~31) )
575 int ch = *t++ = *s++;
578 if ( !((*t++ = *s++) & ~31) )
587 while (*s && isSPACE(*s))
594 item = s = SvPV(sv, len);
596 item_is_utf = FALSE; /* XXX is this correct? */
608 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
609 sv_catpvn(PL_formtarget, item, itemsize);
610 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
611 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
616 /* If the field is marked with ^ and the value is undefined,
619 if ((arg & 512) && !SvOK(sv)) {
627 /* Formats aren't yet marked for locales, so assume "yes". */
629 STORE_NUMERIC_STANDARD_SET_LOCAL();
630 #if defined(USE_LONG_DOUBLE)
632 sprintf(t, "%#*.*" PERL_PRIfldbl,
633 (int) fieldsize, (int) arg & 255, value);
635 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
640 (int) fieldsize, (int) arg & 255, value);
643 (int) fieldsize, value);
646 RESTORE_NUMERIC_STANDARD();
652 /* If the field is marked with ^ and the value is undefined,
655 if ((arg & 512) && !SvOK(sv)) {
663 /* Formats aren't yet marked for locales, so assume "yes". */
665 STORE_NUMERIC_STANDARD_SET_LOCAL();
666 #if defined(USE_LONG_DOUBLE)
668 sprintf(t, "%#0*.*" PERL_PRIfldbl,
669 (int) fieldsize, (int) arg & 255, value);
670 /* is this legal? I don't have long doubles */
672 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
676 sprintf(t, "%#0*.*f",
677 (int) fieldsize, (int) arg & 255, value);
680 (int) fieldsize, value);
683 RESTORE_NUMERIC_STANDARD();
690 while (t-- > linemark && *t == ' ') ;
698 if (arg) { /* repeat until fields exhausted? */
700 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
701 lines += FmLINES(PL_formtarget);
704 if (strnEQ(linemark, linemark - arg, arg))
705 DIE(aTHX_ "Runaway format");
707 FmLINES(PL_formtarget) = lines;
709 RETURNOP(cLISTOP->op_first);
722 while (*s && isSPACE(*s) && s < send)
726 arg = fieldsize - itemsize;
733 if (strnEQ(s," ",3)) {
734 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
745 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
746 FmLINES(PL_formtarget) += lines;
758 if (PL_stack_base + *PL_markstack_ptr == SP) {
760 if (GIMME_V == G_SCALAR)
761 XPUSHs(sv_2mortal(newSViv(0)));
762 RETURNOP(PL_op->op_next->op_next);
764 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
765 pp_pushmark(); /* push dst */
766 pp_pushmark(); /* push src */
767 ENTER; /* enter outer scope */
770 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
772 ENTER; /* enter inner scope */
775 src = PL_stack_base[*PL_markstack_ptr];
780 if (PL_op->op_type == OP_MAPSTART)
781 pp_pushmark(); /* push top */
782 return ((LOGOP*)PL_op->op_next)->op_other;
787 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
793 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
799 /* first, move source pointer to the next item in the source list */
800 ++PL_markstack_ptr[-1];
802 /* if there are new items, push them into the destination list */
804 /* might need to make room back there first */
805 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
806 /* XXX this implementation is very pessimal because the stack
807 * is repeatedly extended for every set of items. Is possible
808 * to do this without any stack extension or copying at all
809 * by maintaining a separate list over which the map iterates
810 * (like foreach does). --gsar */
812 /* everything in the stack after the destination list moves
813 * towards the end the stack by the amount of room needed */
814 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
816 /* items to shift up (accounting for the moved source pointer) */
817 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
819 /* This optimization is by Ben Tilly and it does
820 * things differently from what Sarathy (gsar)
821 * is describing. The downside of this optimization is
822 * that leaves "holes" (uninitialized and hopefully unused areas)
823 * to the Perl stack, but on the other hand this
824 * shouldn't be a problem. If Sarathy's idea gets
825 * implemented, this optimization should become
826 * irrelevant. --jhi */
828 shift = count; /* Avoid shifting too often --Ben Tilly */
833 PL_markstack_ptr[-1] += shift;
834 *PL_markstack_ptr += shift;
838 /* copy the new items down to the destination list */
839 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
841 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
843 LEAVE; /* exit inner scope */
846 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
849 (void)POPMARK; /* pop top */
850 LEAVE; /* exit outer scope */
851 (void)POPMARK; /* pop src */
852 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
853 (void)POPMARK; /* pop dst */
854 SP = PL_stack_base + POPMARK; /* pop original mark */
855 if (gimme == G_SCALAR) {
859 else if (gimme == G_ARRAY)
866 ENTER; /* enter inner scope */
869 /* set $_ to the new source item */
870 src = PL_stack_base[PL_markstack_ptr[-1]];
874 RETURNOP(cLOGOP->op_other);
882 if (GIMME == G_ARRAY)
884 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
885 return cLOGOP->op_other;
894 if (GIMME == G_ARRAY) {
895 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
899 SV *targ = PAD_SV(PL_op->op_targ);
902 if (PL_op->op_private & OPpFLIP_LINENUM) {
903 if (GvIO(PL_last_in_gv)) {
904 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
907 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
908 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
914 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
915 if (PL_op->op_flags & OPf_SPECIAL) {
923 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
936 if (GIMME == G_ARRAY) {
942 if (SvGMAGICAL(left))
944 if (SvGMAGICAL(right))
947 /* This code tries to decide if "$left .. $right" should use the
948 magical string increment, or if the range is numeric (we make
949 an exception for .."0" [#18165]). AMS 20021031. */
951 if (SvNIOKp(left) || !SvPOKp(left) ||
952 SvNIOKp(right) || !SvPOKp(right) ||
953 (looks_like_number(left) && *SvPVX(left) != '0' &&
954 looks_like_number(right)))
956 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
957 DIE(aTHX_ "Range iterator outside integer range");
968 sv = sv_2mortal(newSViv(i++));
973 SV *final = sv_mortalcopy(right);
975 char *tmps = SvPV(final, len);
977 sv = sv_mortalcopy(left);
979 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
981 if (strEQ(SvPVX(sv),tmps))
983 sv = sv_2mortal(newSVsv(sv));
990 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
994 if (PL_op->op_private & OPpFLIP_LINENUM) {
995 if (GvIO(PL_last_in_gv)) {
996 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
999 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1000 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1008 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1009 sv_catpv(targ, "E0");
1019 static char *context_name[] = {
1030 S_dopoptolabel(pTHX_ char *label)
1033 register PERL_CONTEXT *cx;
1035 for (i = cxstack_ix; i >= 0; i--) {
1037 switch (CxTYPE(cx)) {
1043 if (ckWARN(WARN_EXITING))
1044 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1045 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1046 if (CxTYPE(cx) == CXt_NULL)
1050 if (!cx->blk_loop.label ||
1051 strNE(label, cx->blk_loop.label) ) {
1052 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1053 (long)i, cx->blk_loop.label));
1056 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1064 Perl_dowantarray(pTHX)
1066 I32 gimme = block_gimme();
1067 return (gimme == G_VOID) ? G_SCALAR : gimme;
1071 Perl_block_gimme(pTHX)
1075 cxix = dopoptosub(cxstack_ix);
1079 switch (cxstack[cxix].blk_gimme) {
1087 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1094 Perl_is_lvalue_sub(pTHX)
1098 cxix = dopoptosub(cxstack_ix);
1099 assert(cxix >= 0); /* We should only be called from inside subs */
1101 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1102 return cxstack[cxix].blk_sub.lval;
1108 S_dopoptosub(pTHX_ I32 startingblock)
1110 return dopoptosub_at(cxstack, startingblock);
1114 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1117 register PERL_CONTEXT *cx;
1118 for (i = startingblock; i >= 0; i--) {
1120 switch (CxTYPE(cx)) {
1126 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1134 S_dopoptoeval(pTHX_ I32 startingblock)
1137 register PERL_CONTEXT *cx;
1138 for (i = startingblock; i >= 0; i--) {
1140 switch (CxTYPE(cx)) {
1144 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1152 S_dopoptoloop(pTHX_ I32 startingblock)
1155 register PERL_CONTEXT *cx;
1156 for (i = startingblock; i >= 0; i--) {
1158 switch (CxTYPE(cx)) {
1164 if (ckWARN(WARN_EXITING))
1165 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1166 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1167 if ((CxTYPE(cx)) == CXt_NULL)
1171 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1179 Perl_dounwind(pTHX_ I32 cxix)
1181 register PERL_CONTEXT *cx;
1184 while (cxstack_ix > cxix) {
1186 cx = &cxstack[cxstack_ix];
1187 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1188 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1189 /* Note: we don't need to restore the base context info till the end. */
1190 switch (CxTYPE(cx)) {
1193 continue; /* not break */
1215 Perl_qerror(pTHX_ SV *err)
1218 sv_catsv(ERRSV, err);
1220 sv_catsv(PL_errors, err);
1222 Perl_warn(aTHX_ "%"SVf, err);
1227 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1235 register PERL_CONTEXT *cx;
1240 if (PL_in_eval & EVAL_KEEPERR) {
1241 static char prefix[] = "\t(in cleanup) ";
1246 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1249 if (*e != *message || strNE(e,message))
1253 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1254 sv_catpvn(err, prefix, sizeof(prefix)-1);
1255 sv_catpvn(err, message, msglen);
1256 if (ckWARN(WARN_MISC)) {
1257 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1258 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1263 sv_setpvn(ERRSV, message, msglen);
1267 message = SvPVx(ERRSV, msglen);
1269 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1270 && PL_curstackinfo->si_prev)
1279 if (cxix < cxstack_ix)
1282 POPBLOCK(cx,PL_curpm);
1283 if (CxTYPE(cx) != CXt_EVAL) {
1284 PerlIO_write(Perl_error_log, "panic: die ", 11);
1285 PerlIO_write(Perl_error_log, message, msglen);
1290 if (gimme == G_SCALAR)
1291 *++newsp = &PL_sv_undef;
1292 PL_stack_sp = newsp;
1296 /* LEAVE could clobber PL_curcop (see save_re_context())
1297 * XXX it might be better to find a way to avoid messing with
1298 * PL_curcop in save_re_context() instead, but this is a more
1299 * minimal fix --GSAR */
1300 PL_curcop = cx->blk_oldcop;
1302 if (optype == OP_REQUIRE) {
1303 char* msg = SvPVx(ERRSV, n_a);
1304 DIE(aTHX_ "%sCompilation failed in require",
1305 *msg ? msg : "Unknown error\n");
1307 return pop_return();
1311 message = SvPVx(ERRSV, msglen);
1313 /* if STDERR is tied, print to it instead */
1314 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1315 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1318 XPUSHs(SvTIED_obj((SV*)io, mg));
1319 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1321 call_method("PRINT", G_SCALAR);
1326 /* SFIO can really mess with your errno */
1329 PerlIO *serr = Perl_error_log;
1331 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1332 (void)PerlIO_flush(serr);
1345 if (SvTRUE(left) != SvTRUE(right))
1357 RETURNOP(cLOGOP->op_other);
1366 RETURNOP(cLOGOP->op_other);
1375 if (!sv || !SvANY(sv)) {
1376 RETURNOP(cLOGOP->op_other);
1379 switch (SvTYPE(sv)) {
1381 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1385 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1389 if (CvROOT(sv) || CvXSUB(sv))
1399 RETURNOP(cLOGOP->op_other);
1405 register I32 cxix = dopoptosub(cxstack_ix);
1406 register PERL_CONTEXT *cx;
1407 register PERL_CONTEXT *ccstack = cxstack;
1408 PERL_SI *top_si = PL_curstackinfo;
1419 /* we may be in a higher stacklevel, so dig down deeper */
1420 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1421 top_si = top_si->si_prev;
1422 ccstack = top_si->si_cxstack;
1423 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1426 if (GIMME != G_ARRAY) {
1432 if (PL_DBsub && cxix >= 0 &&
1433 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1437 cxix = dopoptosub_at(ccstack, cxix - 1);
1440 cx = &ccstack[cxix];
1441 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1442 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1443 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1444 field below is defined for any cx. */
1445 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1446 cx = &ccstack[dbcxix];
1449 stashname = CopSTASHPV(cx->blk_oldcop);
1450 if (GIMME != G_ARRAY) {
1453 PUSHs(&PL_sv_undef);
1456 sv_setpv(TARG, stashname);
1465 PUSHs(&PL_sv_undef);
1467 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1468 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1469 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1472 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1473 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1474 /* So is ccstack[dbcxix]. */
1477 gv_efullname3(sv, cvgv, Nullch);
1478 PUSHs(sv_2mortal(sv));
1479 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1482 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1483 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1487 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1488 PUSHs(sv_2mortal(newSViv(0)));
1490 gimme = (I32)cx->blk_gimme;
1491 if (gimme == G_VOID)
1492 PUSHs(&PL_sv_undef);
1494 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1495 if (CxTYPE(cx) == CXt_EVAL) {
1497 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1498 PUSHs(cx->blk_eval.cur_text);
1502 else if (cx->blk_eval.old_namesv) {
1503 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1506 /* eval BLOCK (try blocks have old_namesv == 0) */
1508 PUSHs(&PL_sv_undef);
1509 PUSHs(&PL_sv_undef);
1513 PUSHs(&PL_sv_undef);
1514 PUSHs(&PL_sv_undef);
1516 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1517 && CopSTASH_eq(PL_curcop, PL_debstash))
1519 AV *ary = cx->blk_sub.argarray;
1520 int off = AvARRAY(ary) - AvALLOC(ary);
1524 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1527 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1530 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1531 av_extend(PL_dbargs, AvFILLp(ary) + off);
1532 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1533 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1535 /* XXX only hints propagated via op_private are currently
1536 * visible (others are not easily accessible, since they
1537 * use the global PL_hints) */
1538 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1539 HINT_PRIVATE_MASK)));
1542 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1544 if (old_warnings == pWARN_NONE ||
1545 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1546 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1547 else if (old_warnings == pWARN_ALL ||
1548 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1549 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1551 mask = newSVsv(old_warnings);
1552 PUSHs(sv_2mortal(mask));
1567 sv_reset(tmps, CopSTASH(PL_curcop));
1577 /* like pp_nextstate, but used instead when the debugger is active */
1581 PL_curcop = (COP*)PL_op;
1582 TAINT_NOT; /* Each statement is presumed innocent */
1583 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1586 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1587 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1591 register PERL_CONTEXT *cx;
1592 I32 gimme = G_ARRAY;
1599 DIE(aTHX_ "No DB::DB routine defined");
1601 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1602 /* don't do recursive DB::DB call */
1614 push_return(PL_op->op_next);
1615 PUSHBLOCK(cx, CXt_SUB, SP);
1618 (void)SvREFCNT_inc(cv);
1619 PAD_SET_CUR(CvPADLIST(cv),1);
1620 RETURNOP(CvSTART(cv));
1634 register PERL_CONTEXT *cx;
1635 I32 gimme = GIMME_V;
1637 U32 cxtype = CXt_LOOP;
1645 if (PL_op->op_targ) {
1646 #ifndef USE_ITHREADS
1647 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1650 SAVEPADSV(PL_op->op_targ);
1651 iterdata = INT2PTR(void*, PL_op->op_targ);
1652 cxtype |= CXp_PADVAR;
1657 svp = &GvSV(gv); /* symbol table variable */
1658 SAVEGENERICSV(*svp);
1661 iterdata = (void*)gv;
1667 PUSHBLOCK(cx, cxtype, SP);
1669 PUSHLOOP(cx, iterdata, MARK);
1671 PUSHLOOP(cx, svp, MARK);
1673 if (PL_op->op_flags & OPf_STACKED) {
1674 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1675 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1677 /* See comment in pp_flop() */
1678 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1679 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1680 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1681 looks_like_number((SV*)cx->blk_loop.iterary)))
1683 if (SvNV(sv) < IV_MIN ||
1684 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1685 DIE(aTHX_ "Range iterator outside integer range");
1686 cx->blk_loop.iterix = SvIV(sv);
1687 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1690 cx->blk_loop.iterlval = newSVsv(sv);
1694 cx->blk_loop.iterary = PL_curstack;
1695 AvFILLp(PL_curstack) = SP - PL_stack_base;
1696 cx->blk_loop.iterix = MARK - PL_stack_base;
1705 register PERL_CONTEXT *cx;
1706 I32 gimme = GIMME_V;
1712 PUSHBLOCK(cx, CXt_LOOP, SP);
1713 PUSHLOOP(cx, 0, SP);
1721 register PERL_CONTEXT *cx;
1729 newsp = PL_stack_base + cx->blk_loop.resetsp;
1732 if (gimme == G_VOID)
1734 else if (gimme == G_SCALAR) {
1736 *++newsp = sv_mortalcopy(*SP);
1738 *++newsp = &PL_sv_undef;
1742 *++newsp = sv_mortalcopy(*++mark);
1743 TAINT_NOT; /* Each item is independent */
1749 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1750 PL_curpm = newpm; /* ... and pop $1 et al */
1762 register PERL_CONTEXT *cx;
1763 bool popsub2 = FALSE;
1764 bool clear_errsv = FALSE;
1771 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1772 if (cxstack_ix == PL_sortcxix
1773 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1775 if (cxstack_ix > PL_sortcxix)
1776 dounwind(PL_sortcxix);
1777 AvARRAY(PL_curstack)[1] = *SP;
1778 PL_stack_sp = PL_stack_base + 1;
1783 cxix = dopoptosub(cxstack_ix);
1785 DIE(aTHX_ "Can't return outside a subroutine");
1786 if (cxix < cxstack_ix)
1790 switch (CxTYPE(cx)) {
1795 if (!(PL_in_eval & EVAL_KEEPERR))
1801 if (optype == OP_REQUIRE &&
1802 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1804 /* Unassume the success we assumed earlier. */
1805 SV *nsv = cx->blk_eval.old_namesv;
1806 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1807 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1814 DIE(aTHX_ "panic: return");
1818 if (gimme == G_SCALAR) {
1821 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1823 *++newsp = SvREFCNT_inc(*SP);
1828 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1830 *++newsp = sv_mortalcopy(sv);
1835 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1838 *++newsp = sv_mortalcopy(*SP);
1841 *++newsp = &PL_sv_undef;
1843 else if (gimme == G_ARRAY) {
1844 while (++MARK <= SP) {
1845 *++newsp = (popsub2 && SvTEMP(*MARK))
1846 ? *MARK : sv_mortalcopy(*MARK);
1847 TAINT_NOT; /* Each item is independent */
1850 PL_stack_sp = newsp;
1852 /* Stack values are safe: */
1854 POPSUB(cx,sv); /* release CV and @_ ... */
1858 PL_curpm = newpm; /* ... and pop $1 et al */
1864 return pop_return();
1871 register PERL_CONTEXT *cx;
1881 if (PL_op->op_flags & OPf_SPECIAL) {
1882 cxix = dopoptoloop(cxstack_ix);
1884 DIE(aTHX_ "Can't \"last\" outside a loop block");
1887 cxix = dopoptolabel(cPVOP->op_pv);
1889 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1891 if (cxix < cxstack_ix)
1896 switch (CxTYPE(cx)) {
1899 newsp = PL_stack_base + cx->blk_loop.resetsp;
1900 nextop = cx->blk_loop.last_op->op_next;
1904 nextop = pop_return();
1908 nextop = pop_return();
1912 nextop = pop_return();
1915 DIE(aTHX_ "panic: last");
1919 if (gimme == G_SCALAR) {
1921 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1922 ? *SP : sv_mortalcopy(*SP);
1924 *++newsp = &PL_sv_undef;
1926 else if (gimme == G_ARRAY) {
1927 while (++MARK <= SP) {
1928 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1929 ? *MARK : sv_mortalcopy(*MARK);
1930 TAINT_NOT; /* Each item is independent */
1936 /* Stack values are safe: */
1939 POPLOOP(cx); /* release loop vars ... */
1943 POPSUB(cx,sv); /* release CV and @_ ... */
1946 PL_curpm = newpm; /* ... and pop $1 et al */
1956 register PERL_CONTEXT *cx;
1959 if (PL_op->op_flags & OPf_SPECIAL) {
1960 cxix = dopoptoloop(cxstack_ix);
1962 DIE(aTHX_ "Can't \"next\" outside a loop block");
1965 cxix = dopoptolabel(cPVOP->op_pv);
1967 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1969 if (cxix < cxstack_ix)
1972 /* clear off anything above the scope we're re-entering, but
1973 * save the rest until after a possible continue block */
1974 inner = PL_scopestack_ix;
1976 if (PL_scopestack_ix < inner)
1977 leave_scope(PL_scopestack[PL_scopestack_ix]);
1978 return cx->blk_loop.next_op;
1984 register PERL_CONTEXT *cx;
1987 if (PL_op->op_flags & OPf_SPECIAL) {
1988 cxix = dopoptoloop(cxstack_ix);
1990 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1993 cxix = dopoptolabel(cPVOP->op_pv);
1995 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1997 if (cxix < cxstack_ix)
2001 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2002 LEAVE_SCOPE(oldsave);
2003 return cx->blk_loop.redo_op;
2007 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2011 static char too_deep[] = "Target of goto is too deeply nested";
2014 Perl_croak(aTHX_ too_deep);
2015 if (o->op_type == OP_LEAVE ||
2016 o->op_type == OP_SCOPE ||
2017 o->op_type == OP_LEAVELOOP ||
2018 o->op_type == OP_LEAVESUB ||
2019 o->op_type == OP_LEAVETRY)
2021 *ops++ = cUNOPo->op_first;
2023 Perl_croak(aTHX_ too_deep);
2026 if (o->op_flags & OPf_KIDS) {
2027 /* First try all the kids at this level, since that's likeliest. */
2028 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2029 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2030 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2033 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2034 if (kid == PL_lastgotoprobe)
2036 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2039 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2040 ops[-1]->op_type == OP_DBSTATE)
2045 if ((o = dofindlabel(kid, label, ops, oplimit)))
2064 register PERL_CONTEXT *cx;
2065 #define GOTO_DEPTH 64
2066 OP *enterops[GOTO_DEPTH];
2068 int do_dump = (PL_op->op_type == OP_DUMP);
2069 static char must_have_label[] = "goto must have label";
2072 if (PL_op->op_flags & OPf_STACKED) {
2076 /* This egregious kludge implements goto &subroutine */
2077 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2079 register PERL_CONTEXT *cx;
2080 CV* cv = (CV*)SvRV(sv);
2086 if (!CvROOT(cv) && !CvXSUB(cv)) {
2091 /* autoloaded stub? */
2092 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2094 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2095 GvNAMELEN(gv), FALSE);
2096 if (autogv && (cv = GvCV(autogv)))
2098 tmpstr = sv_newmortal();
2099 gv_efullname3(tmpstr, gv, Nullch);
2100 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2102 DIE(aTHX_ "Goto undefined subroutine");
2105 /* First do some returnish stuff. */
2107 cxix = dopoptosub(cxstack_ix);
2109 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2110 if (cxix < cxstack_ix)
2114 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2116 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2117 /* put @_ back onto stack */
2118 AV* av = cx->blk_sub.argarray;
2120 items = AvFILLp(av) + 1;
2122 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2123 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2124 PL_stack_sp += items;
2125 SvREFCNT_dec(GvAV(PL_defgv));
2126 GvAV(PL_defgv) = cx->blk_sub.savearray;
2127 /* abandon @_ if it got reified */
2129 (void)sv_2mortal((SV*)av); /* delay until return */
2131 av_extend(av, items-1);
2132 AvFLAGS(av) = AVf_REIFY;
2133 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2136 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2138 av = GvAV(PL_defgv);
2139 items = AvFILLp(av) + 1;
2141 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2142 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2143 PL_stack_sp += items;
2145 if (CxTYPE(cx) == CXt_SUB &&
2146 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2147 SvREFCNT_dec(cx->blk_sub.cv);
2148 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2149 LEAVE_SCOPE(oldsave);
2151 /* Now do some callish stuff. */
2154 #ifdef PERL_XSUB_OLDSTYLE
2155 if (CvOLDSTYLE(cv)) {
2156 I32 (*fp3)(int,int,int);
2161 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2162 items = (*fp3)(CvXSUBANY(cv).any_i32,
2163 mark - PL_stack_base + 1,
2165 SP = PL_stack_base + items;
2168 #endif /* PERL_XSUB_OLDSTYLE */
2173 PL_stack_sp--; /* There is no cv arg. */
2174 /* Push a mark for the start of arglist */
2176 (void)(*CvXSUB(cv))(aTHX_ cv);
2177 /* Pop the current context like a decent sub should */
2178 POPBLOCK(cx, PL_curpm);
2179 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2182 return pop_return();
2185 AV* padlist = CvPADLIST(cv);
2186 if (CxTYPE(cx) == CXt_EVAL) {
2187 PL_in_eval = cx->blk_eval.old_in_eval;
2188 PL_eval_root = cx->blk_eval.old_eval_root;
2189 cx->cx_type = CXt_SUB;
2190 cx->blk_sub.hasargs = 0;
2192 cx->blk_sub.cv = cv;
2193 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2196 if (CvDEPTH(cv) < 2)
2197 (void)SvREFCNT_inc(cv);
2199 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2200 sub_crush_depth(cv);
2201 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2203 PAD_SET_CUR(padlist, CvDEPTH(cv));
2204 if (cx->blk_sub.hasargs)
2206 AV* av = (AV*)PAD_SVl(0);
2209 cx->blk_sub.savearray = GvAV(PL_defgv);
2210 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2211 CX_CURPAD_SAVE(cx->blk_sub);
2212 cx->blk_sub.argarray = av;
2215 if (items >= AvMAX(av) + 1) {
2217 if (AvARRAY(av) != ary) {
2218 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2219 SvPVX(av) = (char*)ary;
2221 if (items >= AvMAX(av) + 1) {
2222 AvMAX(av) = items - 1;
2223 Renew(ary,items+1,SV*);
2225 SvPVX(av) = (char*)ary;
2228 Copy(mark,AvARRAY(av),items,SV*);
2229 AvFILLp(av) = items - 1;
2230 assert(!AvREAL(av));
2237 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2239 * We do not care about using sv to call CV;
2240 * it's for informational purposes only.
2242 SV *sv = GvSV(PL_DBsub);
2245 if (PERLDB_SUB_NN) {
2246 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2249 gv_efullname3(sv, CvGV(cv), Nullch);
2252 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2253 PUSHMARK( PL_stack_sp );
2254 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2258 RETURNOP(CvSTART(cv));
2262 label = SvPV(sv,n_a);
2263 if (!(do_dump || *label))
2264 DIE(aTHX_ must_have_label);
2267 else if (PL_op->op_flags & OPf_SPECIAL) {
2269 DIE(aTHX_ must_have_label);
2272 label = cPVOP->op_pv;
2274 if (label && *label) {
2276 bool leaving_eval = FALSE;
2277 bool in_block = FALSE;
2278 PERL_CONTEXT *last_eval_cx = 0;
2282 PL_lastgotoprobe = 0;
2284 for (ix = cxstack_ix; ix >= 0; ix--) {
2286 switch (CxTYPE(cx)) {
2288 leaving_eval = TRUE;
2289 if (CxREALEVAL(cx)) {
2290 gotoprobe = (last_eval_cx ?
2291 last_eval_cx->blk_eval.old_eval_root :
2296 /* else fall through */
2298 gotoprobe = cx->blk_oldcop->op_sibling;
2304 gotoprobe = cx->blk_oldcop->op_sibling;
2307 gotoprobe = PL_main_root;
2310 if (CvDEPTH(cx->blk_sub.cv)) {
2311 gotoprobe = CvROOT(cx->blk_sub.cv);
2317 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2320 DIE(aTHX_ "panic: goto");
2321 gotoprobe = PL_main_root;
2325 retop = dofindlabel(gotoprobe, label,
2326 enterops, enterops + GOTO_DEPTH);
2330 PL_lastgotoprobe = gotoprobe;
2333 DIE(aTHX_ "Can't find label %s", label);
2335 /* if we're leaving an eval, check before we pop any frames
2336 that we're not going to punt, otherwise the error
2339 if (leaving_eval && *enterops && enterops[1]) {
2341 for (i = 1; enterops[i]; i++)
2342 if (enterops[i]->op_type == OP_ENTERITER)
2343 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2346 /* pop unwanted frames */
2348 if (ix < cxstack_ix) {
2355 oldsave = PL_scopestack[PL_scopestack_ix];
2356 LEAVE_SCOPE(oldsave);
2359 /* push wanted frames */
2361 if (*enterops && enterops[1]) {
2363 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2364 for (; enterops[ix]; ix++) {
2365 PL_op = enterops[ix];
2366 /* Eventually we may want to stack the needed arguments
2367 * for each op. For now, we punt on the hard ones. */
2368 if (PL_op->op_type == OP_ENTERITER)
2369 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2370 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2378 if (!retop) retop = PL_main_start;
2380 PL_restartop = retop;
2381 PL_do_undump = TRUE;
2385 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2386 PL_do_undump = FALSE;
2402 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2404 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2407 PL_exit_flags |= PERL_EXIT_EXPECTED;
2409 PUSHs(&PL_sv_undef);
2417 NV value = SvNVx(GvSV(cCOP->cop_gv));
2418 register I32 match = I_32(value);
2421 if (((NV)match) > value)
2422 --match; /* was fractional--truncate other way */
2424 match -= cCOP->uop.scop.scop_offset;
2427 else if (match > cCOP->uop.scop.scop_max)
2428 match = cCOP->uop.scop.scop_max;
2429 PL_op = cCOP->uop.scop.scop_next[match];
2439 PL_op = PL_op->op_next; /* can't assume anything */
2442 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2443 match -= cCOP->uop.scop.scop_offset;
2446 else if (match > cCOP->uop.scop.scop_max)
2447 match = cCOP->uop.scop.scop_max;
2448 PL_op = cCOP->uop.scop.scop_next[match];
2457 S_save_lines(pTHX_ AV *array, SV *sv)
2459 register char *s = SvPVX(sv);
2460 register char *send = SvPVX(sv) + SvCUR(sv);
2462 register I32 line = 1;
2464 while (s && s < send) {
2465 SV *tmpstr = NEWSV(85,0);
2467 sv_upgrade(tmpstr, SVt_PVMG);
2468 t = strchr(s, '\n');
2474 sv_setpvn(tmpstr, s, t - s);
2475 av_store(array, line++, tmpstr);
2480 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2482 S_docatch_body(pTHX_ va_list args)
2484 return docatch_body();
2489 S_docatch_body(pTHX)
2496 S_docatch(pTHX_ OP *o)
2501 volatile PERL_SI *cursi = PL_curstackinfo;
2505 assert(CATCH_GET == TRUE);
2509 /* Normally, the leavetry at the end of this block of ops will
2510 * pop an op off the return stack and continue there. By setting
2511 * the op to Nullop, we force an exit from the inner runops()
2514 retop = pop_return();
2515 push_return(Nullop);
2517 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2519 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2525 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2531 /* die caught by an inner eval - continue inner loop */
2532 if (PL_restartop && cursi == PL_curstackinfo) {
2533 PL_op = PL_restartop;
2537 /* a die in this eval - continue in outer loop */
2553 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2554 /* sv Text to convert to OP tree. */
2555 /* startop op_free() this to undo. */
2556 /* code Short string id of the caller. */
2558 dSP; /* Make POPBLOCK work. */
2561 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2565 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2566 char *tmpbuf = tbuf;
2569 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2574 /* switch to eval mode */
2576 if (PL_curcop == &PL_compiling) {
2577 SAVECOPSTASH_FREE(&PL_compiling);
2578 CopSTASH_set(&PL_compiling, PL_curstash);
2580 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2581 SV *sv = sv_newmortal();
2582 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2583 code, (unsigned long)++PL_evalseq,
2584 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2588 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2589 SAVECOPFILE_FREE(&PL_compiling);
2590 CopFILE_set(&PL_compiling, tmpbuf+2);
2591 SAVECOPLINE(&PL_compiling);
2592 CopLINE_set(&PL_compiling, 1);
2593 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2594 deleting the eval's FILEGV from the stash before gv_check() runs
2595 (i.e. before run-time proper). To work around the coredump that
2596 ensues, we always turn GvMULTI_on for any globals that were
2597 introduced within evals. See force_ident(). GSAR 96-10-12 */
2598 safestr = savepv(tmpbuf);
2599 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2601 #ifdef OP_IN_REGISTER
2606 PL_hints &= HINT_UTF8;
2608 /* we get here either during compilation, or via pp_regcomp at runtime */
2609 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2611 runcv = find_runcv(NULL);
2614 PL_op->op_type = OP_ENTEREVAL;
2615 PL_op->op_flags = 0; /* Avoid uninit warning. */
2616 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2617 PUSHEVAL(cx, 0, Nullgv);
2620 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2622 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2623 POPBLOCK(cx,PL_curpm);
2626 (*startop)->op_type = OP_NULL;
2627 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2629 /* XXX DAPM do this properly one year */
2630 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2632 if (PL_curcop == &PL_compiling)
2633 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2634 #ifdef OP_IN_REGISTER
2642 =for apidoc find_runcv
2644 Locate the CV corresponding to the currently executing sub or eval.
2645 If db_seqp is non_null, skip CVs that are in the DB package and populate
2646 *db_seqp with the cop sequence number at the point that the DB:: code was
2647 entered. (allows debuggers to eval in the scope of the breakpoint rather
2648 than in in the scope of the debuger itself).
2654 Perl_find_runcv(pTHX_ U32 *db_seqp)
2661 *db_seqp = PL_curcop->cop_seq;
2662 for (si = PL_curstackinfo; si; si = si->si_prev) {
2663 for (ix = si->si_cxix; ix >= 0; ix--) {
2664 cx = &(si->si_cxstack[ix]);
2665 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2666 CV *cv = cx->blk_sub.cv;
2667 /* skip DB:: code */
2668 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2669 *db_seqp = cx->blk_oldcop->cop_seq;
2674 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2682 /* Compile a require/do, an eval '', or a /(?{...})/.
2683 * In the last case, startop is non-null, and contains the address of
2684 * a pointer that should be set to the just-compiled code.
2685 * outside is the lexically enclosing CV (if any) that invoked us.
2688 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2690 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2695 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2696 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2701 SAVESPTR(PL_compcv);
2702 PL_compcv = (CV*)NEWSV(1104,0);
2703 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2704 CvEVAL_on(PL_compcv);
2705 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2706 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2708 CvOUTSIDE_SEQ(PL_compcv) = seq;
2709 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2711 /* set up a scratch pad */
2713 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2716 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2718 /* make sure we compile in the right package */
2720 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2721 SAVESPTR(PL_curstash);
2722 PL_curstash = CopSTASH(PL_curcop);
2724 SAVESPTR(PL_beginav);
2725 PL_beginav = newAV();
2726 SAVEFREESV(PL_beginav);
2727 SAVEI32(PL_error_count);
2729 /* try to compile it */
2731 PL_eval_root = Nullop;
2733 PL_curcop = &PL_compiling;
2734 PL_curcop->cop_arybase = 0;
2735 if (saveop && saveop->op_flags & OPf_SPECIAL)
2736 PL_in_eval |= EVAL_KEEPERR;
2739 if (yyparse() || PL_error_count || !PL_eval_root) {
2743 I32 optype = 0; /* Might be reset by POPEVAL. */
2748 op_free(PL_eval_root);
2749 PL_eval_root = Nullop;
2751 SP = PL_stack_base + POPMARK; /* pop original mark */
2753 POPBLOCK(cx,PL_curpm);
2759 if (optype == OP_REQUIRE) {
2760 char* msg = SvPVx(ERRSV, n_a);
2761 DIE(aTHX_ "%sCompilation failed in require",
2762 *msg ? msg : "Unknown error\n");
2765 char* msg = SvPVx(ERRSV, n_a);
2767 POPBLOCK(cx,PL_curpm);
2769 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2770 (*msg ? msg : "Unknown error\n"));
2773 char* msg = SvPVx(ERRSV, n_a);
2775 sv_setpv(ERRSV, "Compilation error");
2780 CopLINE_set(&PL_compiling, 0);
2782 *startop = PL_eval_root;
2784 SAVEFREEOP(PL_eval_root);
2786 scalarvoid(PL_eval_root);
2787 else if (gimme & G_ARRAY)
2790 scalar(PL_eval_root);
2792 DEBUG_x(dump_eval());
2794 /* Register with debugger: */
2795 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2796 CV *cv = get_cv("DB::postponed", FALSE);
2800 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2802 call_sv((SV*)cv, G_DISCARD);
2806 /* compiled okay, so do it */
2808 CvDEPTH(PL_compcv) = 1;
2809 SP = PL_stack_base + POPMARK; /* pop original mark */
2810 PL_op = saveop; /* The caller may need it. */
2811 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2813 RETURNOP(PL_eval_start);
2817 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2819 STRLEN namelen = strlen(name);
2822 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2823 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2824 char *pmc = SvPV_nolen(pmcsv);
2827 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2828 fp = PerlIO_open(name, mode);
2831 if (PerlLIO_stat(name, &pmstat) < 0 ||
2832 pmstat.st_mtime < pmcstat.st_mtime)
2834 fp = PerlIO_open(pmc, mode);
2837 fp = PerlIO_open(name, mode);
2840 SvREFCNT_dec(pmcsv);
2843 fp = PerlIO_open(name, mode);
2851 register PERL_CONTEXT *cx;
2855 char *tryname = Nullch;
2856 SV *namesv = Nullsv;
2858 I32 gimme = GIMME_V;
2859 PerlIO *tryrsfp = 0;
2861 int filter_has_file = 0;
2862 GV *filter_child_proc = 0;
2863 SV *filter_state = 0;
2870 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2871 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2872 UV rev = 0, ver = 0, sver = 0;
2874 U8 *s = (U8*)SvPVX(sv);
2875 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2877 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2880 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2883 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2886 if (PERL_REVISION < rev
2887 || (PERL_REVISION == rev
2888 && (PERL_VERSION < ver
2889 || (PERL_VERSION == ver
2890 && PERL_SUBVERSION < sver))))
2892 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2893 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2894 PERL_VERSION, PERL_SUBVERSION);
2896 if (ckWARN(WARN_PORTABLE))
2897 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2898 "v-string in use/require non-portable");
2901 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2902 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2903 + ((NV)PERL_SUBVERSION/(NV)1000000)
2904 + 0.00000099 < SvNV(sv))
2908 NV nver = (nrev - rev) * 1000;
2909 UV ver = (UV)(nver + 0.0009);
2910 NV nsver = (nver - ver) * 1000;
2911 UV sver = (UV)(nsver + 0.0009);
2913 /* help out with the "use 5.6" confusion */
2914 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2915 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2916 " (did you mean v%"UVuf".%03"UVuf"?)--"
2917 "this is only v%d.%d.%d, stopped",
2918 rev, ver, sver, rev, ver/100,
2919 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2922 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2923 "this is only v%d.%d.%d, stopped",
2924 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2931 name = SvPV(sv, len);
2932 if (!(name && len > 0 && *name))
2933 DIE(aTHX_ "Null filename used");
2934 TAINT_PROPER("require");
2935 if (PL_op->op_type == OP_REQUIRE &&
2936 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2937 *svp != &PL_sv_undef)
2940 /* prepare to compile file */
2942 if (path_is_absolute(name)) {
2944 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2946 #ifdef MACOS_TRADITIONAL
2950 MacPerl_CanonDir(name, newname, 1);
2951 if (path_is_absolute(newname)) {
2953 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2958 AV *ar = GvAVn(PL_incgv);
2962 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2965 namesv = NEWSV(806, 0);
2966 for (i = 0; i <= AvFILL(ar); i++) {
2967 SV *dirsv = *av_fetch(ar, i, TRUE);
2973 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2974 && !sv_isobject(loader))
2976 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2979 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2980 PTR2UV(SvRV(dirsv)), name);
2981 tryname = SvPVX(namesv);
2992 if (sv_isobject(loader))
2993 count = call_method("INC", G_ARRAY);
2995 count = call_sv(loader, G_ARRAY);
3005 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3009 if (SvTYPE(arg) == SVt_PVGV) {
3010 IO *io = GvIO((GV *)arg);
3015 tryrsfp = IoIFP(io);
3016 if (IoTYPE(io) == IoTYPE_PIPE) {
3017 /* reading from a child process doesn't
3018 nest -- when returning from reading
3019 the inner module, the outer one is
3020 unreadable (closed?) I've tried to
3021 save the gv to manage the lifespan of
3022 the pipe, but this didn't help. XXX */
3023 filter_child_proc = (GV *)arg;
3024 (void)SvREFCNT_inc(filter_child_proc);
3027 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3028 PerlIO_close(IoOFP(io));
3040 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3042 (void)SvREFCNT_inc(filter_sub);
3045 filter_state = SP[i];
3046 (void)SvREFCNT_inc(filter_state);
3050 tryrsfp = PerlIO_open("/dev/null",
3065 filter_has_file = 0;
3066 if (filter_child_proc) {
3067 SvREFCNT_dec(filter_child_proc);
3068 filter_child_proc = 0;
3071 SvREFCNT_dec(filter_state);
3075 SvREFCNT_dec(filter_sub);
3080 if (!path_is_absolute(name)
3081 #ifdef MACOS_TRADITIONAL
3082 /* We consider paths of the form :a:b ambiguous and interpret them first
3083 as global then as local
3085 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3088 char *dir = SvPVx(dirsv, n_a);
3089 #ifdef MACOS_TRADITIONAL
3093 MacPerl_CanonDir(name, buf2, 1);
3094 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3098 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3100 sv_setpv(namesv, unixdir);
3101 sv_catpv(namesv, unixname);
3103 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3106 TAINT_PROPER("require");
3107 tryname = SvPVX(namesv);
3108 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3110 if (tryname[0] == '.' && tryname[1] == '/')
3119 SAVECOPFILE_FREE(&PL_compiling);
3120 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3121 SvREFCNT_dec(namesv);
3123 if (PL_op->op_type == OP_REQUIRE) {
3124 char *msgstr = name;
3125 if (namesv) { /* did we lookup @INC? */
3126 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3127 SV *dirmsgsv = NEWSV(0, 0);
3128 AV *ar = GvAVn(PL_incgv);
3130 sv_catpvn(msg, " in @INC", 8);
3131 if (instr(SvPVX(msg), ".h "))
3132 sv_catpv(msg, " (change .h to .ph maybe?)");
3133 if (instr(SvPVX(msg), ".ph "))
3134 sv_catpv(msg, " (did you run h2ph?)");
3135 sv_catpv(msg, " (@INC contains:");
3136 for (i = 0; i <= AvFILL(ar); i++) {
3137 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3138 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3139 sv_catsv(msg, dirmsgsv);
3141 sv_catpvn(msg, ")", 1);
3142 SvREFCNT_dec(dirmsgsv);
3143 msgstr = SvPV_nolen(msg);
3145 DIE(aTHX_ "Can't locate %s", msgstr);
3151 SETERRNO(0, SS_NORMAL);
3153 /* Assume success here to prevent recursive requirement. */
3155 /* Check whether a hook in @INC has already filled %INC */
3156 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3157 (void)hv_store(GvHVn(PL_incgv), name, len,
3158 (hook_sv ? SvREFCNT_inc(hook_sv)
3159 : newSVpv(CopFILE(&PL_compiling), 0)),
3165 lex_start(sv_2mortal(newSVpvn("",0)));
3166 SAVEGENERICSV(PL_rsfp_filters);
3167 PL_rsfp_filters = Nullav;
3172 SAVESPTR(PL_compiling.cop_warnings);
3173 if (PL_dowarn & G_WARN_ALL_ON)
3174 PL_compiling.cop_warnings = pWARN_ALL ;
3175 else if (PL_dowarn & G_WARN_ALL_OFF)
3176 PL_compiling.cop_warnings = pWARN_NONE ;
3177 else if (PL_taint_warn)
3178 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3180 PL_compiling.cop_warnings = pWARN_STD ;
3181 SAVESPTR(PL_compiling.cop_io);
3182 PL_compiling.cop_io = Nullsv;
3184 if (filter_sub || filter_child_proc) {
3185 SV *datasv = filter_add(run_user_filter, Nullsv);
3186 IoLINES(datasv) = filter_has_file;
3187 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3188 IoTOP_GV(datasv) = (GV *)filter_state;
3189 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3192 /* switch to eval mode */
3193 push_return(PL_op->op_next);
3194 PUSHBLOCK(cx, CXt_EVAL, SP);
3195 PUSHEVAL(cx, name, Nullgv);
3197 SAVECOPLINE(&PL_compiling);
3198 CopLINE_set(&PL_compiling, 0);
3202 /* Store and reset encoding. */
3203 encoding = PL_encoding;
3204 PL_encoding = Nullsv;
3206 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3208 /* Restore encoding. */
3209 PL_encoding = encoding;
3216 return pp_require();
3222 register PERL_CONTEXT *cx;
3224 I32 gimme = GIMME_V, was = PL_sub_generation;
3225 char tbuf[TYPE_DIGITS(long) + 12];
3226 char *tmpbuf = tbuf;
3235 TAINT_PROPER("eval");
3241 /* switch to eval mode */
3243 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3244 SV *sv = sv_newmortal();
3245 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3246 (unsigned long)++PL_evalseq,
3247 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3251 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3252 SAVECOPFILE_FREE(&PL_compiling);
3253 CopFILE_set(&PL_compiling, tmpbuf+2);
3254 SAVECOPLINE(&PL_compiling);
3255 CopLINE_set(&PL_compiling, 1);
3256 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3257 deleting the eval's FILEGV from the stash before gv_check() runs
3258 (i.e. before run-time proper). To work around the coredump that
3259 ensues, we always turn GvMULTI_on for any globals that were
3260 introduced within evals. See force_ident(). GSAR 96-10-12 */
3261 safestr = savepv(tmpbuf);
3262 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3264 PL_hints = PL_op->op_targ;
3265 SAVESPTR(PL_compiling.cop_warnings);
3266 if (specialWARN(PL_curcop->cop_warnings))
3267 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3269 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3270 SAVEFREESV(PL_compiling.cop_warnings);
3272 SAVESPTR(PL_compiling.cop_io);
3273 if (specialCopIO(PL_curcop->cop_io))
3274 PL_compiling.cop_io = PL_curcop->cop_io;
3276 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3277 SAVEFREESV(PL_compiling.cop_io);
3279 /* special case: an eval '' executed within the DB package gets lexically
3280 * placed in the first non-DB CV rather than the current CV - this
3281 * allows the debugger to execute code, find lexicals etc, in the
3282 * scope of the code being debugged. Passing &seq gets find_runcv
3283 * to do the dirty work for us */
3284 runcv = find_runcv(&seq);
3286 push_return(PL_op->op_next);
3287 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3288 PUSHEVAL(cx, 0, Nullgv);
3290 /* prepare to compile string */
3292 if (PERLDB_LINE && PL_curstash != PL_debstash)
3293 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3295 ret = doeval(gimme, NULL, runcv, seq);
3296 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3297 && ret != PL_op->op_next) { /* Successive compilation. */
3298 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3300 return DOCATCH(ret);
3310 register PERL_CONTEXT *cx;
3312 U8 save_flags = PL_op -> op_flags;
3317 retop = pop_return();
3320 if (gimme == G_VOID)
3322 else if (gimme == G_SCALAR) {
3325 if (SvFLAGS(TOPs) & SVs_TEMP)
3328 *MARK = sv_mortalcopy(TOPs);
3332 *MARK = &PL_sv_undef;
3337 /* in case LEAVE wipes old return values */
3338 for (mark = newsp + 1; mark <= SP; mark++) {
3339 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3340 *mark = sv_mortalcopy(*mark);
3341 TAINT_NOT; /* Each item is independent */
3345 PL_curpm = newpm; /* Don't pop $1 et al till now */
3348 assert(CvDEPTH(PL_compcv) == 1);
3350 CvDEPTH(PL_compcv) = 0;
3353 if (optype == OP_REQUIRE &&
3354 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3356 /* Unassume the success we assumed earlier. */
3357 SV *nsv = cx->blk_eval.old_namesv;
3358 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3359 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3360 /* die_where() did LEAVE, or we won't be here */
3364 if (!(save_flags & OPf_SPECIAL))
3374 register PERL_CONTEXT *cx;
3375 I32 gimme = GIMME_V;
3380 push_return(cLOGOP->op_other->op_next);
3381 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3384 PL_in_eval = EVAL_INEVAL;
3387 return DOCATCH(PL_op->op_next);
3398 register PERL_CONTEXT *cx;
3403 retop = pop_return();
3406 if (gimme == G_VOID)
3408 else if (gimme == G_SCALAR) {
3411 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3414 *MARK = sv_mortalcopy(TOPs);
3418 *MARK = &PL_sv_undef;
3423 /* in case LEAVE wipes old return values */
3424 for (mark = newsp + 1; mark <= SP; mark++) {
3425 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3426 *mark = sv_mortalcopy(*mark);
3427 TAINT_NOT; /* Each item is independent */
3431 PL_curpm = newpm; /* Don't pop $1 et al till now */
3439 S_doparseform(pTHX_ SV *sv)
3442 register char *s = SvPV_force(sv, len);
3443 register char *send = s + len;
3444 register char *base = Nullch;
3445 register I32 skipspaces = 0;
3446 bool noblank = FALSE;
3447 bool repeat = FALSE;
3448 bool postspace = FALSE;
3456 Perl_croak(aTHX_ "Null picture in formline");
3458 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3463 *fpc++ = FF_LINEMARK;
3464 noblank = repeat = FALSE;
3482 case ' ': case '\t':
3493 *fpc++ = FF_LITERAL;
3501 *fpc++ = (U16)skipspaces;
3505 *fpc++ = FF_NEWLINE;
3509 arg = fpc - linepc + 1;
3516 *fpc++ = FF_LINEMARK;
3517 noblank = repeat = FALSE;
3526 ischop = s[-1] == '^';
3532 arg = (s - base) - 1;
3534 *fpc++ = FF_LITERAL;
3543 *fpc++ = FF_LINEGLOB;
3545 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3546 arg = ischop ? 512 : 0;
3556 arg |= 256 + (s - f);
3558 *fpc++ = s - base; /* fieldsize for FETCH */
3559 *fpc++ = FF_DECIMAL;
3562 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3563 arg = ischop ? 512 : 0;
3565 s++; /* skip the '0' first */
3574 arg |= 256 + (s - f);
3576 *fpc++ = s - base; /* fieldsize for FETCH */
3577 *fpc++ = FF_0DECIMAL;
3582 bool ismore = FALSE;
3585 while (*++s == '>') ;
3586 prespace = FF_SPACE;
3588 else if (*s == '|') {
3589 while (*++s == '|') ;
3590 prespace = FF_HALFSPACE;
3595 while (*++s == '<') ;
3598 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3602 *fpc++ = s - base; /* fieldsize for FETCH */
3604 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3607 *fpc++ = (U16)prespace;
3622 { /* need to jump to the next word */
3624 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3625 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3626 s = SvPVX(sv) + SvCUR(sv) + z;
3628 Copy(fops, s, arg, U16);
3630 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3635 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3637 SV *datasv = FILTER_DATA(idx);
3638 int filter_has_file = IoLINES(datasv);
3639 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3640 SV *filter_state = (SV *)IoTOP_GV(datasv);
3641 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3644 /* I was having segfault trouble under Linux 2.2.5 after a
3645 parse error occured. (Had to hack around it with a test
3646 for PL_error_count == 0.) Solaris doesn't segfault --
3647 not sure where the trouble is yet. XXX */
3649 if (filter_has_file) {
3650 len = FILTER_READ(idx+1, buf_sv, maxlen);
3653 if (filter_sub && len >= 0) {
3664 PUSHs(sv_2mortal(newSViv(maxlen)));
3666 PUSHs(filter_state);
3669 count = call_sv(filter_sub, G_SCALAR);
3685 IoLINES(datasv) = 0;
3686 if (filter_child_proc) {
3687 SvREFCNT_dec(filter_child_proc);
3688 IoFMT_GV(datasv) = Nullgv;
3691 SvREFCNT_dec(filter_state);
3692 IoTOP_GV(datasv) = Nullgv;
3695 SvREFCNT_dec(filter_sub);
3696 IoBOTTOM_GV(datasv) = Nullgv;
3698 filter_del(run_user_filter);
3704 /* perhaps someone can come up with a better name for
3705 this? it is not really "absolute", per se ... */
3707 S_path_is_absolute(pTHX_ char *name)
3709 if (PERL_FILE_IS_ABSOLUTE(name)
3710 #ifdef MACOS_TRADITIONAL
3713 || (*name == '.' && (name[1] == '/' ||
3714 (name[1] == '.' && name[2] == '/'))))