3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
161 PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
163 if (cx->sb_iters++) {
164 I32 saviters = cx->sb_iters;
165 if (cx->sb_iters > cx->sb_maxiters)
166 DIE(aTHX_ "Substitution loop");
168 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
169 cx->sb_rxtainted |= 2;
170 sv_catsv(dstr, POPs);
173 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
174 s == m, cx->sb_targ, NULL,
175 ((cx->sb_rflags & REXEC_COPY_STR)
176 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
177 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
179 SV *targ = cx->sb_targ;
181 sv_catpvn(dstr, s, cx->sb_strend - s);
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 (void)SvOOK_off(targ);
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_LEAVETRY)
2020 *ops++ = cUNOPo->op_first;
2022 Perl_croak(aTHX_ too_deep);
2025 if (o->op_flags & OPf_KIDS) {
2026 /* First try all the kids at this level, since that's likeliest. */
2027 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2028 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2029 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2032 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2033 if (kid == PL_lastgotoprobe)
2035 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2038 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2039 ops[-1]->op_type == OP_DBSTATE)
2044 if ((o = dofindlabel(kid, label, ops, oplimit)))
2063 register PERL_CONTEXT *cx;
2064 #define GOTO_DEPTH 64
2065 OP *enterops[GOTO_DEPTH];
2067 int do_dump = (PL_op->op_type == OP_DUMP);
2068 static char must_have_label[] = "goto must have label";
2071 if (PL_op->op_flags & OPf_STACKED) {
2075 /* This egregious kludge implements goto &subroutine */
2076 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2078 register PERL_CONTEXT *cx;
2079 CV* cv = (CV*)SvRV(sv);
2085 if (!CvROOT(cv) && !CvXSUB(cv)) {
2090 /* autoloaded stub? */
2091 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2093 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2094 GvNAMELEN(gv), FALSE);
2095 if (autogv && (cv = GvCV(autogv)))
2097 tmpstr = sv_newmortal();
2098 gv_efullname3(tmpstr, gv, Nullch);
2099 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2101 DIE(aTHX_ "Goto undefined subroutine");
2104 /* First do some returnish stuff. */
2105 cxix = dopoptosub(cxstack_ix);
2107 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2108 if (cxix < cxstack_ix)
2112 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2114 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2115 /* put @_ back onto stack */
2116 AV* av = cx->blk_sub.argarray;
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;
2123 SvREFCNT_dec(GvAV(PL_defgv));
2124 GvAV(PL_defgv) = cx->blk_sub.savearray;
2125 /* abandon @_ if it got reified */
2127 (void)sv_2mortal((SV*)av); /* delay until return */
2129 av_extend(av, items-1);
2130 AvFLAGS(av) = AVf_REIFY;
2131 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2134 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2136 av = GvAV(PL_defgv);
2137 items = AvFILLp(av) + 1;
2139 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2140 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2141 PL_stack_sp += items;
2143 if (CxTYPE(cx) == CXt_SUB &&
2144 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2145 SvREFCNT_dec(cx->blk_sub.cv);
2146 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2147 LEAVE_SCOPE(oldsave);
2149 /* Now do some callish stuff. */
2152 #ifdef PERL_XSUB_OLDSTYLE
2153 if (CvOLDSTYLE(cv)) {
2154 I32 (*fp3)(int,int,int);
2159 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2160 items = (*fp3)(CvXSUBANY(cv).any_i32,
2161 mark - PL_stack_base + 1,
2163 SP = PL_stack_base + items;
2166 #endif /* PERL_XSUB_OLDSTYLE */
2171 PL_stack_sp--; /* There is no cv arg. */
2172 /* Push a mark for the start of arglist */
2174 (void)(*CvXSUB(cv))(aTHX_ cv);
2175 /* Pop the current context like a decent sub should */
2176 POPBLOCK(cx, PL_curpm);
2177 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2180 return pop_return();
2183 AV* padlist = CvPADLIST(cv);
2184 if (CxTYPE(cx) == CXt_EVAL) {
2185 PL_in_eval = cx->blk_eval.old_in_eval;
2186 PL_eval_root = cx->blk_eval.old_eval_root;
2187 cx->cx_type = CXt_SUB;
2188 cx->blk_sub.hasargs = 0;
2190 cx->blk_sub.cv = cv;
2191 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2194 if (CvDEPTH(cv) < 2)
2195 (void)SvREFCNT_inc(cv);
2197 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2198 sub_crush_depth(cv);
2199 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2201 PAD_SET_CUR(padlist, CvDEPTH(cv));
2202 if (cx->blk_sub.hasargs)
2204 AV* av = (AV*)PAD_SVl(0);
2207 cx->blk_sub.savearray = GvAV(PL_defgv);
2208 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2209 CX_CURPAD_SAVE(cx->blk_sub);
2210 cx->blk_sub.argarray = av;
2213 if (items >= AvMAX(av) + 1) {
2215 if (AvARRAY(av) != ary) {
2216 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2217 SvPVX(av) = (char*)ary;
2219 if (items >= AvMAX(av) + 1) {
2220 AvMAX(av) = items - 1;
2221 Renew(ary,items+1,SV*);
2223 SvPVX(av) = (char*)ary;
2226 Copy(mark,AvARRAY(av),items,SV*);
2227 AvFILLp(av) = items - 1;
2228 assert(!AvREAL(av));
2235 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2237 * We do not care about using sv to call CV;
2238 * it's for informational purposes only.
2240 SV *sv = GvSV(PL_DBsub);
2243 if (PERLDB_SUB_NN) {
2244 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2247 gv_efullname3(sv, CvGV(cv), Nullch);
2250 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2251 PUSHMARK( PL_stack_sp );
2252 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2256 RETURNOP(CvSTART(cv));
2260 label = SvPV(sv,n_a);
2261 if (!(do_dump || *label))
2262 DIE(aTHX_ must_have_label);
2265 else if (PL_op->op_flags & OPf_SPECIAL) {
2267 DIE(aTHX_ must_have_label);
2270 label = cPVOP->op_pv;
2272 if (label && *label) {
2274 bool leaving_eval = FALSE;
2275 PERL_CONTEXT *last_eval_cx = 0;
2279 PL_lastgotoprobe = 0;
2281 for (ix = cxstack_ix; ix >= 0; ix--) {
2283 switch (CxTYPE(cx)) {
2285 leaving_eval = TRUE;
2286 if (CxREALEVAL(cx)) {
2287 gotoprobe = (last_eval_cx ?
2288 last_eval_cx->blk_eval.old_eval_root :
2293 /* else fall through */
2295 gotoprobe = cx->blk_oldcop->op_sibling;
2301 gotoprobe = cx->blk_oldcop->op_sibling;
2303 gotoprobe = PL_main_root;
2306 if (CvDEPTH(cx->blk_sub.cv)) {
2307 gotoprobe = CvROOT(cx->blk_sub.cv);
2313 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2316 DIE(aTHX_ "panic: goto");
2317 gotoprobe = PL_main_root;
2321 retop = dofindlabel(gotoprobe, label,
2322 enterops, enterops + GOTO_DEPTH);
2326 PL_lastgotoprobe = gotoprobe;
2329 DIE(aTHX_ "Can't find label %s", label);
2331 /* if we're leaving an eval, check before we pop any frames
2332 that we're not going to punt, otherwise the error
2335 if (leaving_eval && *enterops && enterops[1]) {
2337 for (i = 1; enterops[i]; i++)
2338 if (enterops[i]->op_type == OP_ENTERITER)
2339 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2342 /* pop unwanted frames */
2344 if (ix < cxstack_ix) {
2351 oldsave = PL_scopestack[PL_scopestack_ix];
2352 LEAVE_SCOPE(oldsave);
2355 /* push wanted frames */
2357 if (*enterops && enterops[1]) {
2359 for (ix = 1; enterops[ix]; ix++) {
2360 PL_op = enterops[ix];
2361 /* Eventually we may want to stack the needed arguments
2362 * for each op. For now, we punt on the hard ones. */
2363 if (PL_op->op_type == OP_ENTERITER)
2364 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2365 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2373 if (!retop) retop = PL_main_start;
2375 PL_restartop = retop;
2376 PL_do_undump = TRUE;
2380 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2381 PL_do_undump = FALSE;
2397 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2399 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2402 PL_exit_flags |= PERL_EXIT_EXPECTED;
2404 PUSHs(&PL_sv_undef);
2412 NV value = SvNVx(GvSV(cCOP->cop_gv));
2413 register I32 match = I_32(value);
2416 if (((NV)match) > value)
2417 --match; /* was fractional--truncate other way */
2419 match -= cCOP->uop.scop.scop_offset;
2422 else if (match > cCOP->uop.scop.scop_max)
2423 match = cCOP->uop.scop.scop_max;
2424 PL_op = cCOP->uop.scop.scop_next[match];
2434 PL_op = PL_op->op_next; /* can't assume anything */
2437 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2438 match -= cCOP->uop.scop.scop_offset;
2441 else if (match > cCOP->uop.scop.scop_max)
2442 match = cCOP->uop.scop.scop_max;
2443 PL_op = cCOP->uop.scop.scop_next[match];
2452 S_save_lines(pTHX_ AV *array, SV *sv)
2454 register char *s = SvPVX(sv);
2455 register char *send = SvPVX(sv) + SvCUR(sv);
2457 register I32 line = 1;
2459 while (s && s < send) {
2460 SV *tmpstr = NEWSV(85,0);
2462 sv_upgrade(tmpstr, SVt_PVMG);
2463 t = strchr(s, '\n');
2469 sv_setpvn(tmpstr, s, t - s);
2470 av_store(array, line++, tmpstr);
2475 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2477 S_docatch_body(pTHX_ va_list args)
2479 return docatch_body();
2484 S_docatch_body(pTHX)
2491 S_docatch(pTHX_ OP *o)
2496 volatile PERL_SI *cursi = PL_curstackinfo;
2500 assert(CATCH_GET == TRUE);
2504 /* Normally, the leavetry at the end of this block of ops will
2505 * pop an op off the return stack and continue there. By setting
2506 * the op to Nullop, we force an exit from the inner runops()
2509 retop = pop_return();
2510 push_return(Nullop);
2512 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2514 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2520 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2526 /* die caught by an inner eval - continue inner loop */
2527 if (PL_restartop && cursi == PL_curstackinfo) {
2528 PL_op = PL_restartop;
2532 /* a die in this eval - continue in outer loop */
2548 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2549 /* sv Text to convert to OP tree. */
2550 /* startop op_free() this to undo. */
2551 /* code Short string id of the caller. */
2553 dSP; /* Make POPBLOCK work. */
2556 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2560 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2561 char *tmpbuf = tbuf;
2564 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2569 /* switch to eval mode */
2571 if (PL_curcop == &PL_compiling) {
2572 SAVECOPSTASH_FREE(&PL_compiling);
2573 CopSTASH_set(&PL_compiling, PL_curstash);
2575 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2576 SV *sv = sv_newmortal();
2577 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2578 code, (unsigned long)++PL_evalseq,
2579 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2583 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2584 SAVECOPFILE_FREE(&PL_compiling);
2585 CopFILE_set(&PL_compiling, tmpbuf+2);
2586 SAVECOPLINE(&PL_compiling);
2587 CopLINE_set(&PL_compiling, 1);
2588 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2589 deleting the eval's FILEGV from the stash before gv_check() runs
2590 (i.e. before run-time proper). To work around the coredump that
2591 ensues, we always turn GvMULTI_on for any globals that were
2592 introduced within evals. See force_ident(). GSAR 96-10-12 */
2593 safestr = savepv(tmpbuf);
2594 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2596 #ifdef OP_IN_REGISTER
2601 PL_hints &= HINT_UTF8;
2603 /* we get here either during compilation, or via pp_regcomp at runtime */
2604 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2606 runcv = find_runcv(NULL);
2609 PL_op->op_type = OP_ENTEREVAL;
2610 PL_op->op_flags = 0; /* Avoid uninit warning. */
2611 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2612 PUSHEVAL(cx, 0, Nullgv);
2615 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2617 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2618 POPBLOCK(cx,PL_curpm);
2621 (*startop)->op_type = OP_NULL;
2622 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2624 /* XXX DAPM do this properly one year */
2625 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2627 if (PL_curcop == &PL_compiling)
2628 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2629 #ifdef OP_IN_REGISTER
2637 =for apidoc find_runcv
2639 Locate the CV corresponding to the currently executing sub or eval.
2640 If db_seqp is non_null, skip CVs that are in the DB package and populate
2641 *db_seqp with the cop sequence number at the point that the DB:: code was
2642 entered. (allows debuggers to eval in the scope of the breakpoint rather
2643 than in in the scope of the debuger itself).
2649 Perl_find_runcv(pTHX_ U32 *db_seqp)
2656 *db_seqp = PL_curcop->cop_seq;
2657 for (si = PL_curstackinfo; si; si = si->si_prev) {
2658 for (ix = si->si_cxix; ix >= 0; ix--) {
2659 cx = &(si->si_cxstack[ix]);
2660 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2661 CV *cv = cx->blk_sub.cv;
2662 /* skip DB:: code */
2663 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2664 *db_seqp = cx->blk_oldcop->cop_seq;
2669 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2677 /* Compile a require/do, an eval '', or a /(?{...})/.
2678 * In the last case, startop is non-null, and contains the address of
2679 * a pointer that should be set to the just-compiled code.
2680 * outside is the lexically enclosing CV (if any) that invoked us.
2683 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2685 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2690 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2691 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2696 SAVESPTR(PL_compcv);
2697 PL_compcv = (CV*)NEWSV(1104,0);
2698 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2699 CvEVAL_on(PL_compcv);
2700 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2701 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2703 CvOUTSIDE_SEQ(PL_compcv) = seq;
2704 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2706 /* set up a scratch pad */
2708 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2711 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2713 /* make sure we compile in the right package */
2715 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2716 SAVESPTR(PL_curstash);
2717 PL_curstash = CopSTASH(PL_curcop);
2719 SAVESPTR(PL_beginav);
2720 PL_beginav = newAV();
2721 SAVEFREESV(PL_beginav);
2722 SAVEI32(PL_error_count);
2724 /* try to compile it */
2726 PL_eval_root = Nullop;
2728 PL_curcop = &PL_compiling;
2729 PL_curcop->cop_arybase = 0;
2730 if (saveop && saveop->op_flags & OPf_SPECIAL)
2731 PL_in_eval |= EVAL_KEEPERR;
2734 if (yyparse() || PL_error_count || !PL_eval_root) {
2738 I32 optype = 0; /* Might be reset by POPEVAL. */
2743 op_free(PL_eval_root);
2744 PL_eval_root = Nullop;
2746 SP = PL_stack_base + POPMARK; /* pop original mark */
2748 POPBLOCK(cx,PL_curpm);
2754 if (optype == OP_REQUIRE) {
2755 char* msg = SvPVx(ERRSV, n_a);
2756 DIE(aTHX_ "%sCompilation failed in require",
2757 *msg ? msg : "Unknown error\n");
2760 char* msg = SvPVx(ERRSV, n_a);
2762 POPBLOCK(cx,PL_curpm);
2764 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2765 (*msg ? msg : "Unknown error\n"));
2768 char* msg = SvPVx(ERRSV, n_a);
2770 sv_setpv(ERRSV, "Compilation error");
2775 CopLINE_set(&PL_compiling, 0);
2777 *startop = PL_eval_root;
2779 SAVEFREEOP(PL_eval_root);
2781 scalarvoid(PL_eval_root);
2782 else if (gimme & G_ARRAY)
2785 scalar(PL_eval_root);
2787 DEBUG_x(dump_eval());
2789 /* Register with debugger: */
2790 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2791 CV *cv = get_cv("DB::postponed", FALSE);
2795 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2797 call_sv((SV*)cv, G_DISCARD);
2801 /* compiled okay, so do it */
2803 CvDEPTH(PL_compcv) = 1;
2804 SP = PL_stack_base + POPMARK; /* pop original mark */
2805 PL_op = saveop; /* The caller may need it. */
2806 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2808 RETURNOP(PL_eval_start);
2812 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2814 STRLEN namelen = strlen(name);
2817 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2818 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2819 char *pmc = SvPV_nolen(pmcsv);
2822 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2823 fp = PerlIO_open(name, mode);
2826 if (PerlLIO_stat(name, &pmstat) < 0 ||
2827 pmstat.st_mtime < pmcstat.st_mtime)
2829 fp = PerlIO_open(pmc, mode);
2832 fp = PerlIO_open(name, mode);
2835 SvREFCNT_dec(pmcsv);
2838 fp = PerlIO_open(name, mode);
2846 register PERL_CONTEXT *cx;
2850 char *tryname = Nullch;
2851 SV *namesv = Nullsv;
2853 I32 gimme = GIMME_V;
2854 PerlIO *tryrsfp = 0;
2856 int filter_has_file = 0;
2857 GV *filter_child_proc = 0;
2858 SV *filter_state = 0;
2865 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2866 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2867 UV rev = 0, ver = 0, sver = 0;
2869 U8 *s = (U8*)SvPVX(sv);
2870 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2872 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2875 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2878 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2881 if (PERL_REVISION < rev
2882 || (PERL_REVISION == rev
2883 && (PERL_VERSION < ver
2884 || (PERL_VERSION == ver
2885 && PERL_SUBVERSION < sver))))
2887 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2888 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2889 PERL_VERSION, PERL_SUBVERSION);
2891 if (ckWARN(WARN_PORTABLE))
2892 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2893 "v-string in use/require non-portable");
2896 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2897 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2898 + ((NV)PERL_SUBVERSION/(NV)1000000)
2899 + 0.00000099 < SvNV(sv))
2903 NV nver = (nrev - rev) * 1000;
2904 UV ver = (UV)(nver + 0.0009);
2905 NV nsver = (nver - ver) * 1000;
2906 UV sver = (UV)(nsver + 0.0009);
2908 /* help out with the "use 5.6" confusion */
2909 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2910 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2911 " (did you mean v%"UVuf".%03"UVuf"?)--"
2912 "this is only v%d.%d.%d, stopped",
2913 rev, ver, sver, rev, ver/100,
2914 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2917 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2918 "this is only v%d.%d.%d, stopped",
2919 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2926 name = SvPV(sv, len);
2927 if (!(name && len > 0 && *name))
2928 DIE(aTHX_ "Null filename used");
2929 TAINT_PROPER("require");
2930 if (PL_op->op_type == OP_REQUIRE &&
2931 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2932 *svp != &PL_sv_undef)
2935 /* prepare to compile file */
2937 if (path_is_absolute(name)) {
2939 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2941 #ifdef MACOS_TRADITIONAL
2945 MacPerl_CanonDir(name, newname, 1);
2946 if (path_is_absolute(newname)) {
2948 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2953 AV *ar = GvAVn(PL_incgv);
2957 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2960 namesv = NEWSV(806, 0);
2961 for (i = 0; i <= AvFILL(ar); i++) {
2962 SV *dirsv = *av_fetch(ar, i, TRUE);
2968 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2969 && !sv_isobject(loader))
2971 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2974 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2975 PTR2UV(SvRV(dirsv)), name);
2976 tryname = SvPVX(namesv);
2987 if (sv_isobject(loader))
2988 count = call_method("INC", G_ARRAY);
2990 count = call_sv(loader, G_ARRAY);
3000 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3004 if (SvTYPE(arg) == SVt_PVGV) {
3005 IO *io = GvIO((GV *)arg);
3010 tryrsfp = IoIFP(io);
3011 if (IoTYPE(io) == IoTYPE_PIPE) {
3012 /* reading from a child process doesn't
3013 nest -- when returning from reading
3014 the inner module, the outer one is
3015 unreadable (closed?) I've tried to
3016 save the gv to manage the lifespan of
3017 the pipe, but this didn't help. XXX */
3018 filter_child_proc = (GV *)arg;
3019 (void)SvREFCNT_inc(filter_child_proc);
3022 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3023 PerlIO_close(IoOFP(io));
3035 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3037 (void)SvREFCNT_inc(filter_sub);
3040 filter_state = SP[i];
3041 (void)SvREFCNT_inc(filter_state);
3045 tryrsfp = PerlIO_open("/dev/null",
3060 filter_has_file = 0;
3061 if (filter_child_proc) {
3062 SvREFCNT_dec(filter_child_proc);
3063 filter_child_proc = 0;
3066 SvREFCNT_dec(filter_state);
3070 SvREFCNT_dec(filter_sub);
3075 if (!path_is_absolute(name)
3076 #ifdef MACOS_TRADITIONAL
3077 /* We consider paths of the form :a:b ambiguous and interpret them first
3078 as global then as local
3080 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3083 char *dir = SvPVx(dirsv, n_a);
3084 #ifdef MACOS_TRADITIONAL
3088 MacPerl_CanonDir(name, buf2, 1);
3089 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3093 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3095 sv_setpv(namesv, unixdir);
3096 sv_catpv(namesv, unixname);
3098 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3101 TAINT_PROPER("require");
3102 tryname = SvPVX(namesv);
3103 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3105 if (tryname[0] == '.' && tryname[1] == '/')
3114 SAVECOPFILE_FREE(&PL_compiling);
3115 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3116 SvREFCNT_dec(namesv);
3118 if (PL_op->op_type == OP_REQUIRE) {
3119 char *msgstr = name;
3120 if (namesv) { /* did we lookup @INC? */
3121 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3122 SV *dirmsgsv = NEWSV(0, 0);
3123 AV *ar = GvAVn(PL_incgv);
3125 sv_catpvn(msg, " in @INC", 8);
3126 if (instr(SvPVX(msg), ".h "))
3127 sv_catpv(msg, " (change .h to .ph maybe?)");
3128 if (instr(SvPVX(msg), ".ph "))
3129 sv_catpv(msg, " (did you run h2ph?)");
3130 sv_catpv(msg, " (@INC contains:");
3131 for (i = 0; i <= AvFILL(ar); i++) {
3132 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3133 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3134 sv_catsv(msg, dirmsgsv);
3136 sv_catpvn(msg, ")", 1);
3137 SvREFCNT_dec(dirmsgsv);
3138 msgstr = SvPV_nolen(msg);
3140 DIE(aTHX_ "Can't locate %s", msgstr);
3146 SETERRNO(0, SS_NORMAL);
3148 /* Assume success here to prevent recursive requirement. */
3150 /* Check whether a hook in @INC has already filled %INC */
3151 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3152 (void)hv_store(GvHVn(PL_incgv), name, len,
3153 (hook_sv ? SvREFCNT_inc(hook_sv)
3154 : newSVpv(CopFILE(&PL_compiling), 0)),
3160 lex_start(sv_2mortal(newSVpvn("",0)));
3161 SAVEGENERICSV(PL_rsfp_filters);
3162 PL_rsfp_filters = Nullav;
3167 SAVESPTR(PL_compiling.cop_warnings);
3168 if (PL_dowarn & G_WARN_ALL_ON)
3169 PL_compiling.cop_warnings = pWARN_ALL ;
3170 else if (PL_dowarn & G_WARN_ALL_OFF)
3171 PL_compiling.cop_warnings = pWARN_NONE ;
3172 else if (PL_taint_warn)
3173 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3175 PL_compiling.cop_warnings = pWARN_STD ;
3176 SAVESPTR(PL_compiling.cop_io);
3177 PL_compiling.cop_io = Nullsv;
3179 if (filter_sub || filter_child_proc) {
3180 SV *datasv = filter_add(run_user_filter, Nullsv);
3181 IoLINES(datasv) = filter_has_file;
3182 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3183 IoTOP_GV(datasv) = (GV *)filter_state;
3184 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3187 /* switch to eval mode */
3188 push_return(PL_op->op_next);
3189 PUSHBLOCK(cx, CXt_EVAL, SP);
3190 PUSHEVAL(cx, name, Nullgv);
3192 SAVECOPLINE(&PL_compiling);
3193 CopLINE_set(&PL_compiling, 0);
3197 /* Store and reset encoding. */
3198 encoding = PL_encoding;
3199 PL_encoding = Nullsv;
3201 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3203 /* Restore encoding. */
3204 PL_encoding = encoding;
3211 return pp_require();
3217 register PERL_CONTEXT *cx;
3219 I32 gimme = GIMME_V, was = PL_sub_generation;
3220 char tbuf[TYPE_DIGITS(long) + 12];
3221 char *tmpbuf = tbuf;
3230 TAINT_PROPER("eval");
3236 /* switch to eval mode */
3238 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3239 SV *sv = sv_newmortal();
3240 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3241 (unsigned long)++PL_evalseq,
3242 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3246 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3247 SAVECOPFILE_FREE(&PL_compiling);
3248 CopFILE_set(&PL_compiling, tmpbuf+2);
3249 SAVECOPLINE(&PL_compiling);
3250 CopLINE_set(&PL_compiling, 1);
3251 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3252 deleting the eval's FILEGV from the stash before gv_check() runs
3253 (i.e. before run-time proper). To work around the coredump that
3254 ensues, we always turn GvMULTI_on for any globals that were
3255 introduced within evals. See force_ident(). GSAR 96-10-12 */
3256 safestr = savepv(tmpbuf);
3257 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3259 PL_hints = PL_op->op_targ;
3260 SAVESPTR(PL_compiling.cop_warnings);
3261 if (specialWARN(PL_curcop->cop_warnings))
3262 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3264 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3265 SAVEFREESV(PL_compiling.cop_warnings);
3267 SAVESPTR(PL_compiling.cop_io);
3268 if (specialCopIO(PL_curcop->cop_io))
3269 PL_compiling.cop_io = PL_curcop->cop_io;
3271 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3272 SAVEFREESV(PL_compiling.cop_io);
3274 /* special case: an eval '' executed within the DB package gets lexically
3275 * placed in the first non-DB CV rather than the current CV - this
3276 * allows the debugger to execute code, find lexicals etc, in the
3277 * scope of the code being debugged. Passing &seq gets find_runcv
3278 * to do the dirty work for us */
3279 runcv = find_runcv(&seq);
3281 push_return(PL_op->op_next);
3282 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3283 PUSHEVAL(cx, 0, Nullgv);
3285 /* prepare to compile string */
3287 if (PERLDB_LINE && PL_curstash != PL_debstash)
3288 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3290 ret = doeval(gimme, NULL, runcv, seq);
3291 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3292 && ret != PL_op->op_next) { /* Successive compilation. */
3293 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3295 return DOCATCH(ret);
3305 register PERL_CONTEXT *cx;
3307 U8 save_flags = PL_op -> op_flags;
3312 retop = pop_return();
3315 if (gimme == G_VOID)
3317 else if (gimme == G_SCALAR) {
3320 if (SvFLAGS(TOPs) & SVs_TEMP)
3323 *MARK = sv_mortalcopy(TOPs);
3327 *MARK = &PL_sv_undef;
3332 /* in case LEAVE wipes old return values */
3333 for (mark = newsp + 1; mark <= SP; mark++) {
3334 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3335 *mark = sv_mortalcopy(*mark);
3336 TAINT_NOT; /* Each item is independent */
3340 PL_curpm = newpm; /* Don't pop $1 et al till now */
3343 assert(CvDEPTH(PL_compcv) == 1);
3345 CvDEPTH(PL_compcv) = 0;
3348 if (optype == OP_REQUIRE &&
3349 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3351 /* Unassume the success we assumed earlier. */
3352 SV *nsv = cx->blk_eval.old_namesv;
3353 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3354 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3355 /* die_where() did LEAVE, or we won't be here */
3359 if (!(save_flags & OPf_SPECIAL))
3369 register PERL_CONTEXT *cx;
3370 I32 gimme = GIMME_V;
3375 push_return(cLOGOP->op_other->op_next);
3376 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3379 PL_in_eval = EVAL_INEVAL;
3382 return DOCATCH(PL_op->op_next);
3393 register PERL_CONTEXT *cx;
3398 retop = pop_return();
3401 if (gimme == G_VOID)
3403 else if (gimme == G_SCALAR) {
3406 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3409 *MARK = sv_mortalcopy(TOPs);
3413 *MARK = &PL_sv_undef;
3418 /* in case LEAVE wipes old return values */
3419 for (mark = newsp + 1; mark <= SP; mark++) {
3420 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3421 *mark = sv_mortalcopy(*mark);
3422 TAINT_NOT; /* Each item is independent */
3426 PL_curpm = newpm; /* Don't pop $1 et al till now */
3434 S_doparseform(pTHX_ SV *sv)
3437 register char *s = SvPV_force(sv, len);
3438 register char *send = s + len;
3439 register char *base = Nullch;
3440 register I32 skipspaces = 0;
3441 bool noblank = FALSE;
3442 bool repeat = FALSE;
3443 bool postspace = FALSE;
3451 Perl_croak(aTHX_ "Null picture in formline");
3453 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3458 *fpc++ = FF_LINEMARK;
3459 noblank = repeat = FALSE;
3477 case ' ': case '\t':
3488 *fpc++ = FF_LITERAL;
3496 *fpc++ = (U16)skipspaces;
3500 *fpc++ = FF_NEWLINE;
3504 arg = fpc - linepc + 1;
3511 *fpc++ = FF_LINEMARK;
3512 noblank = repeat = FALSE;
3521 ischop = s[-1] == '^';
3527 arg = (s - base) - 1;
3529 *fpc++ = FF_LITERAL;
3538 *fpc++ = FF_LINEGLOB;
3540 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3541 arg = ischop ? 512 : 0;
3551 arg |= 256 + (s - f);
3553 *fpc++ = s - base; /* fieldsize for FETCH */
3554 *fpc++ = FF_DECIMAL;
3557 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3558 arg = ischop ? 512 : 0;
3560 s++; /* skip the '0' first */
3569 arg |= 256 + (s - f);
3571 *fpc++ = s - base; /* fieldsize for FETCH */
3572 *fpc++ = FF_0DECIMAL;
3577 bool ismore = FALSE;
3580 while (*++s == '>') ;
3581 prespace = FF_SPACE;
3583 else if (*s == '|') {
3584 while (*++s == '|') ;
3585 prespace = FF_HALFSPACE;
3590 while (*++s == '<') ;
3593 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3597 *fpc++ = s - base; /* fieldsize for FETCH */
3599 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3602 *fpc++ = (U16)prespace;
3617 { /* need to jump to the next word */
3619 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3620 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3621 s = SvPVX(sv) + SvCUR(sv) + z;
3623 Copy(fops, s, arg, U16);
3625 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3630 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3632 SV *datasv = FILTER_DATA(idx);
3633 int filter_has_file = IoLINES(datasv);
3634 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3635 SV *filter_state = (SV *)IoTOP_GV(datasv);
3636 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3639 /* I was having segfault trouble under Linux 2.2.5 after a
3640 parse error occured. (Had to hack around it with a test
3641 for PL_error_count == 0.) Solaris doesn't segfault --
3642 not sure where the trouble is yet. XXX */
3644 if (filter_has_file) {
3645 len = FILTER_READ(idx+1, buf_sv, maxlen);
3648 if (filter_sub && len >= 0) {
3659 PUSHs(sv_2mortal(newSViv(maxlen)));
3661 PUSHs(filter_state);
3664 count = call_sv(filter_sub, G_SCALAR);
3680 IoLINES(datasv) = 0;
3681 if (filter_child_proc) {
3682 SvREFCNT_dec(filter_child_proc);
3683 IoFMT_GV(datasv) = Nullgv;
3686 SvREFCNT_dec(filter_state);
3687 IoTOP_GV(datasv) = Nullgv;
3690 SvREFCNT_dec(filter_sub);
3691 IoBOTTOM_GV(datasv) = Nullgv;
3693 filter_del(run_user_filter);
3699 /* perhaps someone can come up with a better name for
3700 this? it is not really "absolute", per se ... */
3702 S_path_is_absolute(pTHX_ char *name)
3704 if (PERL_FILE_IS_ABSOLUTE(name)
3705 #ifdef MACOS_TRADITIONAL
3708 || (*name == '.' && (name[1] == '/' ||
3709 (name[1] == '.' && name[2] == '/'))))