3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
161 PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
163 if (cx->sb_iters++) {
164 I32 saviters = cx->sb_iters;
165 if (cx->sb_iters > cx->sb_maxiters)
166 DIE(aTHX_ "Substitution loop");
168 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
169 cx->sb_rxtainted |= 2;
170 sv_catsv(dstr, POPs);
173 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
174 s == m, cx->sb_targ, NULL,
175 ((cx->sb_rflags & REXEC_COPY_STR)
176 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
177 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
179 SV *targ = cx->sb_targ;
181 sv_catpvn(dstr, s, cx->sb_strend - s);
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 (void)SvOOK_off(targ);
185 Safefree(SvPVX(targ));
186 SvPVX(targ) = SvPVX(dstr);
187 SvCUR_set(targ, SvCUR(dstr));
188 SvLEN_set(targ, SvLEN(dstr));
194 TAINT_IF(cx->sb_rxtainted & 1);
195 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
197 (void)SvPOK_only_UTF8(targ);
198 TAINT_IF(cx->sb_rxtainted);
202 LEAVE_SCOPE(cx->sb_oldsave);
204 RETURNOP(pm->op_next);
206 cx->sb_iters = saviters;
208 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
211 cx->sb_orig = orig = rx->subbeg;
213 cx->sb_strend = s + (cx->sb_strend - m);
215 cx->sb_m = m = rx->startp[0] + orig;
217 sv_catpvn(dstr, s, m-s);
218 cx->sb_s = rx->endp[0] + orig;
219 { /* Update the pos() information. */
220 SV *sv = cx->sb_targ;
223 if (SvTYPE(sv) < SVt_PVMG)
224 (void)SvUPGRADE(sv, SVt_PVMG);
225 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
226 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
227 mg = mg_find(sv, PERL_MAGIC_regex_global);
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
235 rxres_save(&cx->sb_rxres, rx);
236 RETURNOP(pm->op_pmreplstart);
240 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
245 if (!p || p[1] < rx->nparens) {
246 i = 6 + rx->nparens * 2;
254 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
255 RX_MATCH_COPIED_off(rx);
259 *p++ = PTR2UV(rx->subbeg);
260 *p++ = (UV)rx->sublen;
261 for (i = 0; i <= rx->nparens; ++i) {
262 *p++ = (UV)rx->startp[i];
263 *p++ = (UV)rx->endp[i];
268 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
273 if (RX_MATCH_COPIED(rx))
274 Safefree(rx->subbeg);
275 RX_MATCH_COPIED_set(rx, *p);
280 rx->subbeg = INT2PTR(char*,*p++);
281 rx->sublen = (I32)(*p++);
282 for (i = 0; i <= rx->nparens; ++i) {
283 rx->startp[i] = (I32)(*p++);
284 rx->endp[i] = (I32)(*p++);
289 Perl_rxres_free(pTHX_ void **rsp)
294 Safefree(INT2PTR(char*,*p));
302 dSP; dMARK; dORIGMARK;
303 register SV *tmpForm = *++MARK;
310 register SV *sv = Nullsv;
315 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
316 char *chophere = Nullch;
317 char *linemark = Nullch;
319 bool gotsome = FALSE;
321 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
322 bool item_is_utf = FALSE;
324 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
325 if (SvREADONLY(tmpForm)) {
326 SvREADONLY_off(tmpForm);
327 doparseform(tmpForm);
328 SvREADONLY_on(tmpForm);
331 doparseform(tmpForm);
334 SvPV_force(PL_formtarget, len);
335 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
337 f = SvPV(tmpForm, len);
338 /* need to jump to the next word */
339 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
348 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
349 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
350 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
351 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
352 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
354 case FF_CHECKNL: name = "CHECKNL"; break;
355 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
356 case FF_SPACE: name = "SPACE"; break;
357 case FF_HALFSPACE: name = "HALFSPACE"; break;
358 case FF_ITEM: name = "ITEM"; break;
359 case FF_CHOP: name = "CHOP"; break;
360 case FF_LINEGLOB: name = "LINEGLOB"; break;
361 case FF_NEWLINE: name = "NEWLINE"; break;
362 case FF_MORE: name = "MORE"; break;
363 case FF_LINEMARK: name = "LINEMARK"; break;
364 case FF_END: name = "END"; break;
365 case FF_0DECIMAL: name = "0DECIMAL"; break;
368 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
370 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
398 if (ckWARN(WARN_SYNTAX))
399 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
404 item = s = SvPV(sv, len);
407 itemsize = sv_len_utf8(sv);
408 if (itemsize != (I32)len) {
410 if (itemsize > fieldsize) {
411 itemsize = fieldsize;
412 itembytes = itemsize;
413 sv_pos_u2b(sv, &itembytes, 0);
417 send = chophere = s + itembytes;
427 sv_pos_b2u(sv, &itemsize);
432 if (itemsize > fieldsize)
433 itemsize = fieldsize;
434 send = chophere = s + itemsize;
446 item = s = SvPV(sv, len);
449 itemsize = sv_len_utf8(sv);
450 if (itemsize != (I32)len) {
452 if (itemsize <= fieldsize) {
453 send = chophere = s + itemsize;
464 itemsize = fieldsize;
465 itembytes = itemsize;
466 sv_pos_u2b(sv, &itembytes, 0);
467 send = chophere = s + itembytes;
468 while (s < send || (s == send && isSPACE(*s))) {
478 if (strchr(PL_chopset, *s))
483 itemsize = chophere - item;
484 sv_pos_b2u(sv, &itemsize);
491 if (itemsize <= fieldsize) {
492 send = chophere = s + itemsize;
503 itemsize = fieldsize;
504 send = chophere = s + itemsize;
505 while (s < send || (s == send && isSPACE(*s))) {
515 if (strchr(PL_chopset, *s))
520 itemsize = chophere - item;
525 arg = fieldsize - itemsize;
534 arg = fieldsize - itemsize;
548 if (UTF8_IS_CONTINUED(*s)) {
549 STRLEN skip = UTF8SKIP(s);
566 if ( !((*t++ = *s++) & ~31) )
574 int ch = *t++ = *s++;
577 if ( !((*t++ = *s++) & ~31) )
586 while (*s && isSPACE(*s))
593 item = s = SvPV(sv, len);
595 item_is_utf = FALSE; /* XXX is this correct? */
607 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
608 sv_catpvn(PL_formtarget, item, itemsize);
609 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
610 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
615 /* If the field is marked with ^ and the value is undefined,
618 if ((arg & 512) && !SvOK(sv)) {
626 /* Formats aren't yet marked for locales, so assume "yes". */
628 STORE_NUMERIC_STANDARD_SET_LOCAL();
629 #if defined(USE_LONG_DOUBLE)
631 sprintf(t, "%#*.*" PERL_PRIfldbl,
632 (int) fieldsize, (int) arg & 255, value);
634 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
639 (int) fieldsize, (int) arg & 255, value);
642 (int) fieldsize, value);
645 RESTORE_NUMERIC_STANDARD();
651 /* If the field is marked with ^ and the value is undefined,
654 if ((arg & 512) && !SvOK(sv)) {
662 /* Formats aren't yet marked for locales, so assume "yes". */
664 STORE_NUMERIC_STANDARD_SET_LOCAL();
665 #if defined(USE_LONG_DOUBLE)
667 sprintf(t, "%#0*.*" PERL_PRIfldbl,
668 (int) fieldsize, (int) arg & 255, value);
669 /* is this legal? I don't have long doubles */
671 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
675 sprintf(t, "%#0*.*f",
676 (int) fieldsize, (int) arg & 255, value);
679 (int) fieldsize, value);
682 RESTORE_NUMERIC_STANDARD();
689 while (t-- > linemark && *t == ' ') ;
697 if (arg) { /* repeat until fields exhausted? */
699 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
700 lines += FmLINES(PL_formtarget);
703 if (strnEQ(linemark, linemark - arg, arg))
704 DIE(aTHX_ "Runaway format");
706 FmLINES(PL_formtarget) = lines;
708 RETURNOP(cLISTOP->op_first);
721 while (*s && isSPACE(*s) && s < send)
725 arg = fieldsize - itemsize;
732 if (strnEQ(s," ",3)) {
733 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
744 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
745 FmLINES(PL_formtarget) += lines;
757 if (PL_stack_base + *PL_markstack_ptr == SP) {
759 if (GIMME_V == G_SCALAR)
760 XPUSHs(sv_2mortal(newSViv(0)));
761 RETURNOP(PL_op->op_next->op_next);
763 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
764 pp_pushmark(); /* push dst */
765 pp_pushmark(); /* push src */
766 ENTER; /* enter outer scope */
769 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
771 ENTER; /* enter inner scope */
774 src = PL_stack_base[*PL_markstack_ptr];
779 if (PL_op->op_type == OP_MAPSTART)
780 pp_pushmark(); /* push top */
781 return ((LOGOP*)PL_op->op_next)->op_other;
786 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
792 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
798 /* first, move source pointer to the next item in the source list */
799 ++PL_markstack_ptr[-1];
801 /* if there are new items, push them into the destination list */
803 /* might need to make room back there first */
804 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
805 /* XXX this implementation is very pessimal because the stack
806 * is repeatedly extended for every set of items. Is possible
807 * to do this without any stack extension or copying at all
808 * by maintaining a separate list over which the map iterates
809 * (like foreach does). --gsar */
811 /* everything in the stack after the destination list moves
812 * towards the end the stack by the amount of room needed */
813 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
815 /* items to shift up (accounting for the moved source pointer) */
816 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
818 /* This optimization is by Ben Tilly and it does
819 * things differently from what Sarathy (gsar)
820 * is describing. The downside of this optimization is
821 * that leaves "holes" (uninitialized and hopefully unused areas)
822 * to the Perl stack, but on the other hand this
823 * shouldn't be a problem. If Sarathy's idea gets
824 * implemented, this optimization should become
825 * irrelevant. --jhi */
827 shift = count; /* Avoid shifting too often --Ben Tilly */
832 PL_markstack_ptr[-1] += shift;
833 *PL_markstack_ptr += shift;
837 /* copy the new items down to the destination list */
838 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
840 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
842 LEAVE; /* exit inner scope */
845 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
848 (void)POPMARK; /* pop top */
849 LEAVE; /* exit outer scope */
850 (void)POPMARK; /* pop src */
851 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
852 (void)POPMARK; /* pop dst */
853 SP = PL_stack_base + POPMARK; /* pop original mark */
854 if (gimme == G_SCALAR) {
858 else if (gimme == G_ARRAY)
865 ENTER; /* enter inner scope */
868 /* set $_ to the new source item */
869 src = PL_stack_base[PL_markstack_ptr[-1]];
873 RETURNOP(cLOGOP->op_other);
881 if (GIMME == G_ARRAY)
883 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
884 return cLOGOP->op_other;
893 if (GIMME == G_ARRAY) {
894 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
898 SV *targ = PAD_SV(PL_op->op_targ);
901 if (PL_op->op_private & OPpFLIP_LINENUM) {
902 if (GvIO(PL_last_in_gv)) {
903 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
906 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
907 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
913 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
914 if (PL_op->op_flags & OPf_SPECIAL) {
922 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
935 if (GIMME == G_ARRAY) {
941 if (SvGMAGICAL(left))
943 if (SvGMAGICAL(right))
946 /* This code tries to decide if "$left .. $right" should use the
947 magical string increment, or if the range is numeric (we make
948 an exception for .."0" [#18165]). AMS 20021031. */
950 if (SvNIOKp(left) || !SvPOKp(left) ||
951 SvNIOKp(right) || !SvPOKp(right) ||
952 (looks_like_number(left) && *SvPVX(left) != '0' &&
953 looks_like_number(right)))
955 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
956 DIE(aTHX_ "Range iterator outside integer range");
967 sv = sv_2mortal(newSViv(i++));
972 SV *final = sv_mortalcopy(right);
974 char *tmps = SvPV(final, len);
976 sv = sv_mortalcopy(left);
978 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
980 if (strEQ(SvPVX(sv),tmps))
982 sv = sv_2mortal(newSVsv(sv));
989 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
993 if (PL_op->op_private & OPpFLIP_LINENUM) {
994 if (GvIO(PL_last_in_gv)) {
995 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
998 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
999 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1007 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1008 sv_catpv(targ, "E0");
1018 static char *context_name[] = {
1029 S_dopoptolabel(pTHX_ char *label)
1032 register PERL_CONTEXT *cx;
1034 for (i = cxstack_ix; i >= 0; i--) {
1036 switch (CxTYPE(cx)) {
1042 if (ckWARN(WARN_EXITING))
1043 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1044 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1045 if (CxTYPE(cx) == CXt_NULL)
1049 if (!cx->blk_loop.label ||
1050 strNE(label, cx->blk_loop.label) ) {
1051 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1052 (long)i, cx->blk_loop.label));
1055 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1063 Perl_dowantarray(pTHX)
1065 I32 gimme = block_gimme();
1066 return (gimme == G_VOID) ? G_SCALAR : gimme;
1070 Perl_block_gimme(pTHX)
1074 cxix = dopoptosub(cxstack_ix);
1078 switch (cxstack[cxix].blk_gimme) {
1086 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1093 Perl_is_lvalue_sub(pTHX)
1097 cxix = dopoptosub(cxstack_ix);
1098 assert(cxix >= 0); /* We should only be called from inside subs */
1100 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1101 return cxstack[cxix].blk_sub.lval;
1107 S_dopoptosub(pTHX_ I32 startingblock)
1109 return dopoptosub_at(cxstack, startingblock);
1113 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1116 register PERL_CONTEXT *cx;
1117 for (i = startingblock; i >= 0; i--) {
1119 switch (CxTYPE(cx)) {
1125 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1133 S_dopoptoeval(pTHX_ I32 startingblock)
1136 register PERL_CONTEXT *cx;
1137 for (i = startingblock; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1143 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1151 S_dopoptoloop(pTHX_ I32 startingblock)
1154 register PERL_CONTEXT *cx;
1155 for (i = startingblock; i >= 0; i--) {
1157 switch (CxTYPE(cx)) {
1163 if (ckWARN(WARN_EXITING))
1164 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1165 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1166 if ((CxTYPE(cx)) == CXt_NULL)
1170 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1178 Perl_dounwind(pTHX_ I32 cxix)
1180 register PERL_CONTEXT *cx;
1183 while (cxstack_ix > cxix) {
1185 cx = &cxstack[cxstack_ix];
1186 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1187 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1188 /* Note: we don't need to restore the base context info till the end. */
1189 switch (CxTYPE(cx)) {
1192 continue; /* not break */
1214 Perl_qerror(pTHX_ SV *err)
1217 sv_catsv(ERRSV, err);
1219 sv_catsv(PL_errors, err);
1221 Perl_warn(aTHX_ "%"SVf, err);
1226 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1234 register PERL_CONTEXT *cx;
1239 if (PL_in_eval & EVAL_KEEPERR) {
1240 static char prefix[] = "\t(in cleanup) ";
1245 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1248 if (*e != *message || strNE(e,message))
1252 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1253 sv_catpvn(err, prefix, sizeof(prefix)-1);
1254 sv_catpvn(err, message, msglen);
1255 if (ckWARN(WARN_MISC)) {
1256 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1257 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1262 sv_setpvn(ERRSV, message, msglen);
1266 message = SvPVx(ERRSV, msglen);
1268 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1269 && PL_curstackinfo->si_prev)
1278 if (cxix < cxstack_ix)
1281 POPBLOCK(cx,PL_curpm);
1282 if (CxTYPE(cx) != CXt_EVAL) {
1283 PerlIO_write(Perl_error_log, "panic: die ", 11);
1284 PerlIO_write(Perl_error_log, message, msglen);
1289 if (gimme == G_SCALAR)
1290 *++newsp = &PL_sv_undef;
1291 PL_stack_sp = newsp;
1295 /* LEAVE could clobber PL_curcop (see save_re_context())
1296 * XXX it might be better to find a way to avoid messing with
1297 * PL_curcop in save_re_context() instead, but this is a more
1298 * minimal fix --GSAR */
1299 PL_curcop = cx->blk_oldcop;
1301 if (optype == OP_REQUIRE) {
1302 char* msg = SvPVx(ERRSV, n_a);
1303 DIE(aTHX_ "%sCompilation failed in require",
1304 *msg ? msg : "Unknown error\n");
1306 return pop_return();
1310 message = SvPVx(ERRSV, msglen);
1312 /* if STDERR is tied, print to it instead */
1313 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1314 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1317 XPUSHs(SvTIED_obj((SV*)io, mg));
1318 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1320 call_method("PRINT", G_SCALAR);
1325 /* SFIO can really mess with your errno */
1328 PerlIO *serr = Perl_error_log;
1330 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1331 (void)PerlIO_flush(serr);
1344 if (SvTRUE(left) != SvTRUE(right))
1356 RETURNOP(cLOGOP->op_other);
1365 RETURNOP(cLOGOP->op_other);
1374 if (!sv || !SvANY(sv)) {
1375 RETURNOP(cLOGOP->op_other);
1378 switch (SvTYPE(sv)) {
1380 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1384 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1388 if (CvROOT(sv) || CvXSUB(sv))
1398 RETURNOP(cLOGOP->op_other);
1404 register I32 cxix = dopoptosub(cxstack_ix);
1405 register PERL_CONTEXT *cx;
1406 register PERL_CONTEXT *ccstack = cxstack;
1407 PERL_SI *top_si = PL_curstackinfo;
1418 /* we may be in a higher stacklevel, so dig down deeper */
1419 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1420 top_si = top_si->si_prev;
1421 ccstack = top_si->si_cxstack;
1422 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1425 if (GIMME != G_ARRAY) {
1431 if (PL_DBsub && cxix >= 0 &&
1432 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1436 cxix = dopoptosub_at(ccstack, cxix - 1);
1439 cx = &ccstack[cxix];
1440 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1441 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1442 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1443 field below is defined for any cx. */
1444 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1445 cx = &ccstack[dbcxix];
1448 stashname = CopSTASHPV(cx->blk_oldcop);
1449 if (GIMME != G_ARRAY) {
1452 PUSHs(&PL_sv_undef);
1455 sv_setpv(TARG, stashname);
1464 PUSHs(&PL_sv_undef);
1466 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1467 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1468 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1471 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1472 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1473 /* So is ccstack[dbcxix]. */
1476 gv_efullname3(sv, cvgv, Nullch);
1477 PUSHs(sv_2mortal(sv));
1478 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1481 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1482 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1486 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1487 PUSHs(sv_2mortal(newSViv(0)));
1489 gimme = (I32)cx->blk_gimme;
1490 if (gimme == G_VOID)
1491 PUSHs(&PL_sv_undef);
1493 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1494 if (CxTYPE(cx) == CXt_EVAL) {
1496 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1497 PUSHs(cx->blk_eval.cur_text);
1501 else if (cx->blk_eval.old_namesv) {
1502 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1505 /* eval BLOCK (try blocks have old_namesv == 0) */
1507 PUSHs(&PL_sv_undef);
1508 PUSHs(&PL_sv_undef);
1512 PUSHs(&PL_sv_undef);
1513 PUSHs(&PL_sv_undef);
1515 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1516 && CopSTASH_eq(PL_curcop, PL_debstash))
1518 AV *ary = cx->blk_sub.argarray;
1519 int off = AvARRAY(ary) - AvALLOC(ary);
1523 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1526 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1529 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1530 av_extend(PL_dbargs, AvFILLp(ary) + off);
1531 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1532 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1534 /* XXX only hints propagated via op_private are currently
1535 * visible (others are not easily accessible, since they
1536 * use the global PL_hints) */
1537 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1538 HINT_PRIVATE_MASK)));
1541 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1543 if (old_warnings == pWARN_NONE ||
1544 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1545 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1546 else if (old_warnings == pWARN_ALL ||
1547 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1548 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1550 mask = newSVsv(old_warnings);
1551 PUSHs(sv_2mortal(mask));
1566 sv_reset(tmps, CopSTASH(PL_curcop));
1576 /* like pp_nextstate, but used instead when the debugger is active */
1580 PL_curcop = (COP*)PL_op;
1581 TAINT_NOT; /* Each statement is presumed innocent */
1582 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1585 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1589 register PERL_CONTEXT *cx;
1590 I32 gimme = G_ARRAY;
1597 DIE(aTHX_ "No DB::DB routine defined");
1599 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1600 /* don't do recursive DB::DB call */
1612 push_return(PL_op->op_next);
1613 PUSHBLOCK(cx, CXt_SUB, SP);
1616 (void)SvREFCNT_inc(cv);
1617 PAD_SET_CUR(CvPADLIST(cv),1);
1618 RETURNOP(CvSTART(cv));
1632 register PERL_CONTEXT *cx;
1633 I32 gimme = GIMME_V;
1635 U32 cxtype = CXt_LOOP;
1643 if (PL_op->op_targ) {
1644 #ifndef USE_ITHREADS
1645 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1648 SAVEPADSV(PL_op->op_targ);
1649 iterdata = INT2PTR(void*, PL_op->op_targ);
1650 cxtype |= CXp_PADVAR;
1655 svp = &GvSV(gv); /* symbol table variable */
1656 SAVEGENERICSV(*svp);
1659 iterdata = (void*)gv;
1665 PUSHBLOCK(cx, cxtype, SP);
1667 PUSHLOOP(cx, iterdata, MARK);
1669 PUSHLOOP(cx, svp, MARK);
1671 if (PL_op->op_flags & OPf_STACKED) {
1672 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1673 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1675 /* See comment in pp_flop() */
1676 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1677 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1678 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1679 looks_like_number((SV*)cx->blk_loop.iterary)))
1681 if (SvNV(sv) < IV_MIN ||
1682 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1683 DIE(aTHX_ "Range iterator outside integer range");
1684 cx->blk_loop.iterix = SvIV(sv);
1685 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1688 cx->blk_loop.iterlval = newSVsv(sv);
1692 cx->blk_loop.iterary = PL_curstack;
1693 AvFILLp(PL_curstack) = SP - PL_stack_base;
1694 cx->blk_loop.iterix = MARK - PL_stack_base;
1703 register PERL_CONTEXT *cx;
1704 I32 gimme = GIMME_V;
1710 PUSHBLOCK(cx, CXt_LOOP, SP);
1711 PUSHLOOP(cx, 0, SP);
1719 register PERL_CONTEXT *cx;
1727 newsp = PL_stack_base + cx->blk_loop.resetsp;
1730 if (gimme == G_VOID)
1732 else if (gimme == G_SCALAR) {
1734 *++newsp = sv_mortalcopy(*SP);
1736 *++newsp = &PL_sv_undef;
1740 *++newsp = sv_mortalcopy(*++mark);
1741 TAINT_NOT; /* Each item is independent */
1747 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1748 PL_curpm = newpm; /* ... and pop $1 et al */
1760 register PERL_CONTEXT *cx;
1761 bool popsub2 = FALSE;
1762 bool clear_errsv = FALSE;
1769 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1770 if (cxstack_ix == PL_sortcxix
1771 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1773 if (cxstack_ix > PL_sortcxix)
1774 dounwind(PL_sortcxix);
1775 AvARRAY(PL_curstack)[1] = *SP;
1776 PL_stack_sp = PL_stack_base + 1;
1781 cxix = dopoptosub(cxstack_ix);
1783 DIE(aTHX_ "Can't return outside a subroutine");
1784 if (cxix < cxstack_ix)
1788 switch (CxTYPE(cx)) {
1793 if (!(PL_in_eval & EVAL_KEEPERR))
1799 if (optype == OP_REQUIRE &&
1800 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1802 /* Unassume the success we assumed earlier. */
1803 SV *nsv = cx->blk_eval.old_namesv;
1804 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1805 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1812 DIE(aTHX_ "panic: return");
1816 if (gimme == G_SCALAR) {
1819 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1821 *++newsp = SvREFCNT_inc(*SP);
1826 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1828 *++newsp = sv_mortalcopy(sv);
1833 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1836 *++newsp = sv_mortalcopy(*SP);
1839 *++newsp = &PL_sv_undef;
1841 else if (gimme == G_ARRAY) {
1842 while (++MARK <= SP) {
1843 *++newsp = (popsub2 && SvTEMP(*MARK))
1844 ? *MARK : sv_mortalcopy(*MARK);
1845 TAINT_NOT; /* Each item is independent */
1848 PL_stack_sp = newsp;
1850 /* Stack values are safe: */
1852 POPSUB(cx,sv); /* release CV and @_ ... */
1856 PL_curpm = newpm; /* ... and pop $1 et al */
1862 return pop_return();
1869 register PERL_CONTEXT *cx;
1879 if (PL_op->op_flags & OPf_SPECIAL) {
1880 cxix = dopoptoloop(cxstack_ix);
1882 DIE(aTHX_ "Can't \"last\" outside a loop block");
1885 cxix = dopoptolabel(cPVOP->op_pv);
1887 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1889 if (cxix < cxstack_ix)
1894 switch (CxTYPE(cx)) {
1897 newsp = PL_stack_base + cx->blk_loop.resetsp;
1898 nextop = cx->blk_loop.last_op->op_next;
1902 nextop = pop_return();
1906 nextop = pop_return();
1910 nextop = pop_return();
1913 DIE(aTHX_ "panic: last");
1917 if (gimme == G_SCALAR) {
1919 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1920 ? *SP : sv_mortalcopy(*SP);
1922 *++newsp = &PL_sv_undef;
1924 else if (gimme == G_ARRAY) {
1925 while (++MARK <= SP) {
1926 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1927 ? *MARK : sv_mortalcopy(*MARK);
1928 TAINT_NOT; /* Each item is independent */
1934 /* Stack values are safe: */
1937 POPLOOP(cx); /* release loop vars ... */
1941 POPSUB(cx,sv); /* release CV and @_ ... */
1944 PL_curpm = newpm; /* ... and pop $1 et al */
1954 register PERL_CONTEXT *cx;
1957 if (PL_op->op_flags & OPf_SPECIAL) {
1958 cxix = dopoptoloop(cxstack_ix);
1960 DIE(aTHX_ "Can't \"next\" outside a loop block");
1963 cxix = dopoptolabel(cPVOP->op_pv);
1965 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1967 if (cxix < cxstack_ix)
1970 /* clear off anything above the scope we're re-entering, but
1971 * save the rest until after a possible continue block */
1972 inner = PL_scopestack_ix;
1974 if (PL_scopestack_ix < inner)
1975 leave_scope(PL_scopestack[PL_scopestack_ix]);
1976 return cx->blk_loop.next_op;
1982 register PERL_CONTEXT *cx;
1985 if (PL_op->op_flags & OPf_SPECIAL) {
1986 cxix = dopoptoloop(cxstack_ix);
1988 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1991 cxix = dopoptolabel(cPVOP->op_pv);
1993 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1995 if (cxix < cxstack_ix)
1999 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2000 LEAVE_SCOPE(oldsave);
2001 return cx->blk_loop.redo_op;
2005 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2009 static char too_deep[] = "Target of goto is too deeply nested";
2012 Perl_croak(aTHX_ too_deep);
2013 if (o->op_type == OP_LEAVE ||
2014 o->op_type == OP_SCOPE ||
2015 o->op_type == OP_LEAVELOOP ||
2016 o->op_type == OP_LEAVETRY)
2018 *ops++ = cUNOPo->op_first;
2020 Perl_croak(aTHX_ too_deep);
2023 if (o->op_flags & OPf_KIDS) {
2024 /* First try all the kids at this level, since that's likeliest. */
2025 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2026 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2027 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2030 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2031 if (kid == PL_lastgotoprobe)
2033 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2036 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2037 ops[-1]->op_type == OP_DBSTATE)
2042 if ((o = dofindlabel(kid, label, ops, oplimit)))
2061 register PERL_CONTEXT *cx;
2062 #define GOTO_DEPTH 64
2063 OP *enterops[GOTO_DEPTH];
2065 int do_dump = (PL_op->op_type == OP_DUMP);
2066 static char must_have_label[] = "goto must have label";
2069 if (PL_op->op_flags & OPf_STACKED) {
2073 /* This egregious kludge implements goto &subroutine */
2074 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2076 register PERL_CONTEXT *cx;
2077 CV* cv = (CV*)SvRV(sv);
2083 if (!CvROOT(cv) && !CvXSUB(cv)) {
2088 /* autoloaded stub? */
2089 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2091 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2092 GvNAMELEN(gv), FALSE);
2093 if (autogv && (cv = GvCV(autogv)))
2095 tmpstr = sv_newmortal();
2096 gv_efullname3(tmpstr, gv, Nullch);
2097 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2099 DIE(aTHX_ "Goto undefined subroutine");
2102 /* First do some returnish stuff. */
2103 cxix = dopoptosub(cxstack_ix);
2105 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2106 if (cxix < cxstack_ix)
2110 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2112 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2113 /* put @_ back onto stack */
2114 AV* av = cx->blk_sub.argarray;
2116 items = AvFILLp(av) + 1;
2118 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2119 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2120 PL_stack_sp += items;
2121 SvREFCNT_dec(GvAV(PL_defgv));
2122 GvAV(PL_defgv) = cx->blk_sub.savearray;
2123 /* abandon @_ if it got reified */
2125 (void)sv_2mortal((SV*)av); /* delay until return */
2127 av_extend(av, items-1);
2128 AvFLAGS(av) = AVf_REIFY;
2129 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2132 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2134 av = GvAV(PL_defgv);
2135 items = AvFILLp(av) + 1;
2137 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2138 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2139 PL_stack_sp += items;
2141 if (CxTYPE(cx) == CXt_SUB &&
2142 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2143 SvREFCNT_dec(cx->blk_sub.cv);
2144 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2145 LEAVE_SCOPE(oldsave);
2147 /* Now do some callish stuff. */
2150 #ifdef PERL_XSUB_OLDSTYLE
2151 if (CvOLDSTYLE(cv)) {
2152 I32 (*fp3)(int,int,int);
2157 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2158 items = (*fp3)(CvXSUBANY(cv).any_i32,
2159 mark - PL_stack_base + 1,
2161 SP = PL_stack_base + items;
2164 #endif /* PERL_XSUB_OLDSTYLE */
2169 PL_stack_sp--; /* There is no cv arg. */
2170 /* Push a mark for the start of arglist */
2172 (void)(*CvXSUB(cv))(aTHX_ cv);
2173 /* Pop the current context like a decent sub should */
2174 POPBLOCK(cx, PL_curpm);
2175 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2178 return pop_return();
2181 AV* padlist = CvPADLIST(cv);
2182 if (CxTYPE(cx) == CXt_EVAL) {
2183 PL_in_eval = cx->blk_eval.old_in_eval;
2184 PL_eval_root = cx->blk_eval.old_eval_root;
2185 cx->cx_type = CXt_SUB;
2186 cx->blk_sub.hasargs = 0;
2188 cx->blk_sub.cv = cv;
2189 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2192 if (CvDEPTH(cv) < 2)
2193 (void)SvREFCNT_inc(cv);
2195 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2196 sub_crush_depth(cv);
2197 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2199 PAD_SET_CUR(padlist, CvDEPTH(cv));
2200 if (cx->blk_sub.hasargs)
2202 AV* av = (AV*)PAD_SVl(0);
2205 cx->blk_sub.savearray = GvAV(PL_defgv);
2206 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2207 CX_CURPAD_SAVE(cx->blk_sub);
2208 cx->blk_sub.argarray = av;
2211 if (items >= AvMAX(av) + 1) {
2213 if (AvARRAY(av) != ary) {
2214 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2215 SvPVX(av) = (char*)ary;
2217 if (items >= AvMAX(av) + 1) {
2218 AvMAX(av) = items - 1;
2219 Renew(ary,items+1,SV*);
2221 SvPVX(av) = (char*)ary;
2224 Copy(mark,AvARRAY(av),items,SV*);
2225 AvFILLp(av) = items - 1;
2226 assert(!AvREAL(av));
2233 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2235 * We do not care about using sv to call CV;
2236 * it's for informational purposes only.
2238 SV *sv = GvSV(PL_DBsub);
2241 if (PERLDB_SUB_NN) {
2242 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2245 gv_efullname3(sv, CvGV(cv), Nullch);
2248 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2249 PUSHMARK( PL_stack_sp );
2250 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2254 RETURNOP(CvSTART(cv));
2258 label = SvPV(sv,n_a);
2259 if (!(do_dump || *label))
2260 DIE(aTHX_ must_have_label);
2263 else if (PL_op->op_flags & OPf_SPECIAL) {
2265 DIE(aTHX_ must_have_label);
2268 label = cPVOP->op_pv;
2270 if (label && *label) {
2272 bool leaving_eval = FALSE;
2273 PERL_CONTEXT *last_eval_cx = 0;
2277 PL_lastgotoprobe = 0;
2279 for (ix = cxstack_ix; ix >= 0; ix--) {
2281 switch (CxTYPE(cx)) {
2283 leaving_eval = TRUE;
2284 if (CxREALEVAL(cx)) {
2285 gotoprobe = (last_eval_cx ?
2286 last_eval_cx->blk_eval.old_eval_root :
2291 /* else fall through */
2293 gotoprobe = cx->blk_oldcop->op_sibling;
2299 gotoprobe = cx->blk_oldcop->op_sibling;
2301 gotoprobe = PL_main_root;
2304 if (CvDEPTH(cx->blk_sub.cv)) {
2305 gotoprobe = CvROOT(cx->blk_sub.cv);
2311 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2314 DIE(aTHX_ "panic: goto");
2315 gotoprobe = PL_main_root;
2319 retop = dofindlabel(gotoprobe, label,
2320 enterops, enterops + GOTO_DEPTH);
2324 PL_lastgotoprobe = gotoprobe;
2327 DIE(aTHX_ "Can't find label %s", label);
2329 /* if we're leaving an eval, check before we pop any frames
2330 that we're not going to punt, otherwise the error
2333 if (leaving_eval && *enterops && enterops[1]) {
2335 for (i = 1; enterops[i]; i++)
2336 if (enterops[i]->op_type == OP_ENTERITER)
2337 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2340 /* pop unwanted frames */
2342 if (ix < cxstack_ix) {
2349 oldsave = PL_scopestack[PL_scopestack_ix];
2350 LEAVE_SCOPE(oldsave);
2353 /* push wanted frames */
2355 if (*enterops && enterops[1]) {
2357 for (ix = 1; enterops[ix]; ix++) {
2358 PL_op = enterops[ix];
2359 /* Eventually we may want to stack the needed arguments
2360 * for each op. For now, we punt on the hard ones. */
2361 if (PL_op->op_type == OP_ENTERITER)
2362 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2363 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2371 if (!retop) retop = PL_main_start;
2373 PL_restartop = retop;
2374 PL_do_undump = TRUE;
2378 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2379 PL_do_undump = FALSE;
2395 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2397 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2400 PL_exit_flags |= PERL_EXIT_EXPECTED;
2402 PUSHs(&PL_sv_undef);
2410 NV value = SvNVx(GvSV(cCOP->cop_gv));
2411 register I32 match = I_32(value);
2414 if (((NV)match) > value)
2415 --match; /* was fractional--truncate other way */
2417 match -= cCOP->uop.scop.scop_offset;
2420 else if (match > cCOP->uop.scop.scop_max)
2421 match = cCOP->uop.scop.scop_max;
2422 PL_op = cCOP->uop.scop.scop_next[match];
2432 PL_op = PL_op->op_next; /* can't assume anything */
2435 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2436 match -= cCOP->uop.scop.scop_offset;
2439 else if (match > cCOP->uop.scop.scop_max)
2440 match = cCOP->uop.scop.scop_max;
2441 PL_op = cCOP->uop.scop.scop_next[match];
2450 S_save_lines(pTHX_ AV *array, SV *sv)
2452 register char *s = SvPVX(sv);
2453 register char *send = SvPVX(sv) + SvCUR(sv);
2455 register I32 line = 1;
2457 while (s && s < send) {
2458 SV *tmpstr = NEWSV(85,0);
2460 sv_upgrade(tmpstr, SVt_PVMG);
2461 t = strchr(s, '\n');
2467 sv_setpvn(tmpstr, s, t - s);
2468 av_store(array, line++, tmpstr);
2473 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2475 S_docatch_body(pTHX_ va_list args)
2477 return docatch_body();
2482 S_docatch_body(pTHX)
2489 S_docatch(pTHX_ OP *o)
2494 volatile PERL_SI *cursi = PL_curstackinfo;
2498 assert(CATCH_GET == TRUE);
2502 /* Normally, the leavetry at the end of this block of ops will
2503 * pop an op off the return stack and continue there. By setting
2504 * the op to Nullop, we force an exit from the inner runops()
2507 retop = pop_return();
2508 push_return(Nullop);
2510 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2512 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2518 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2524 /* die caught by an inner eval - continue inner loop */
2525 if (PL_restartop && cursi == PL_curstackinfo) {
2526 PL_op = PL_restartop;
2530 /* a die in this eval - continue in outer loop */
2546 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2547 /* sv Text to convert to OP tree. */
2548 /* startop op_free() this to undo. */
2549 /* code Short string id of the caller. */
2551 dSP; /* Make POPBLOCK work. */
2554 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2558 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2559 char *tmpbuf = tbuf;
2562 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2567 /* switch to eval mode */
2569 if (PL_curcop == &PL_compiling) {
2570 SAVECOPSTASH_FREE(&PL_compiling);
2571 CopSTASH_set(&PL_compiling, PL_curstash);
2573 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2574 SV *sv = sv_newmortal();
2575 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2576 code, (unsigned long)++PL_evalseq,
2577 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2581 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2582 SAVECOPFILE_FREE(&PL_compiling);
2583 CopFILE_set(&PL_compiling, tmpbuf+2);
2584 SAVECOPLINE(&PL_compiling);
2585 CopLINE_set(&PL_compiling, 1);
2586 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2587 deleting the eval's FILEGV from the stash before gv_check() runs
2588 (i.e. before run-time proper). To work around the coredump that
2589 ensues, we always turn GvMULTI_on for any globals that were
2590 introduced within evals. See force_ident(). GSAR 96-10-12 */
2591 safestr = savepv(tmpbuf);
2592 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2594 #ifdef OP_IN_REGISTER
2599 PL_hints &= HINT_UTF8;
2601 /* we get here either during compilation, or via pp_regcomp at runtime */
2602 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2604 runcv = find_runcv(NULL);
2607 PL_op->op_type = OP_ENTEREVAL;
2608 PL_op->op_flags = 0; /* Avoid uninit warning. */
2609 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2610 PUSHEVAL(cx, 0, Nullgv);
2613 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2615 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2616 POPBLOCK(cx,PL_curpm);
2619 (*startop)->op_type = OP_NULL;
2620 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2622 /* XXX DAPM do this properly one year */
2623 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2625 if (PL_curcop == &PL_compiling)
2626 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2627 #ifdef OP_IN_REGISTER
2635 =for apidoc find_runcv
2637 Locate the CV corresponding to the currently executing sub or eval.
2638 If db_seqp is non_null, skip CVs that are in the DB package and populate
2639 *db_seqp with the cop sequence number at the point that the DB:: code was
2640 entered. (allows debuggers to eval in the scope of the breakpoint rather
2641 than in in the scope of the debuger itself).
2647 Perl_find_runcv(pTHX_ U32 *db_seqp)
2654 *db_seqp = PL_curcop->cop_seq;
2655 for (si = PL_curstackinfo; si; si = si->si_prev) {
2656 for (ix = si->si_cxix; ix >= 0; ix--) {
2657 cx = &(si->si_cxstack[ix]);
2658 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2659 CV *cv = cx->blk_sub.cv;
2660 /* skip DB:: code */
2661 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2662 *db_seqp = cx->blk_oldcop->cop_seq;
2667 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2675 /* Compile a require/do, an eval '', or a /(?{...})/.
2676 * In the last case, startop is non-null, and contains the address of
2677 * a pointer that should be set to the just-compiled code.
2678 * outside is the lexically enclosing CV (if any) that invoked us.
2681 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2683 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2688 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2689 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2694 SAVESPTR(PL_compcv);
2695 PL_compcv = (CV*)NEWSV(1104,0);
2696 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2697 CvEVAL_on(PL_compcv);
2698 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2699 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2701 CvOUTSIDE_SEQ(PL_compcv) = seq;
2702 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2704 /* set up a scratch pad */
2706 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2709 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2711 /* make sure we compile in the right package */
2713 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2714 SAVESPTR(PL_curstash);
2715 PL_curstash = CopSTASH(PL_curcop);
2717 SAVESPTR(PL_beginav);
2718 PL_beginav = newAV();
2719 SAVEFREESV(PL_beginav);
2720 SAVEI32(PL_error_count);
2722 /* try to compile it */
2724 PL_eval_root = Nullop;
2726 PL_curcop = &PL_compiling;
2727 PL_curcop->cop_arybase = 0;
2728 if (saveop && saveop->op_flags & OPf_SPECIAL)
2729 PL_in_eval |= EVAL_KEEPERR;
2732 if (yyparse() || PL_error_count || !PL_eval_root) {
2736 I32 optype = 0; /* Might be reset by POPEVAL. */
2741 op_free(PL_eval_root);
2742 PL_eval_root = Nullop;
2744 SP = PL_stack_base + POPMARK; /* pop original mark */
2746 POPBLOCK(cx,PL_curpm);
2752 if (optype == OP_REQUIRE) {
2753 char* msg = SvPVx(ERRSV, n_a);
2754 DIE(aTHX_ "%sCompilation failed in require",
2755 *msg ? msg : "Unknown error\n");
2758 char* msg = SvPVx(ERRSV, n_a);
2760 POPBLOCK(cx,PL_curpm);
2762 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2763 (*msg ? msg : "Unknown error\n"));
2766 char* msg = SvPVx(ERRSV, n_a);
2768 sv_setpv(ERRSV, "Compilation error");
2773 CopLINE_set(&PL_compiling, 0);
2775 *startop = PL_eval_root;
2777 SAVEFREEOP(PL_eval_root);
2779 scalarvoid(PL_eval_root);
2780 else if (gimme & G_ARRAY)
2783 scalar(PL_eval_root);
2785 DEBUG_x(dump_eval());
2787 /* Register with debugger: */
2788 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2789 CV *cv = get_cv("DB::postponed", FALSE);
2793 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2795 call_sv((SV*)cv, G_DISCARD);
2799 /* compiled okay, so do it */
2801 CvDEPTH(PL_compcv) = 1;
2802 SP = PL_stack_base + POPMARK; /* pop original mark */
2803 PL_op = saveop; /* The caller may need it. */
2804 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2806 RETURNOP(PL_eval_start);
2810 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2812 STRLEN namelen = strlen(name);
2815 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2816 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2817 char *pmc = SvPV_nolen(pmcsv);
2820 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2821 fp = PerlIO_open(name, mode);
2824 if (PerlLIO_stat(name, &pmstat) < 0 ||
2825 pmstat.st_mtime < pmcstat.st_mtime)
2827 fp = PerlIO_open(pmc, mode);
2830 fp = PerlIO_open(name, mode);
2833 SvREFCNT_dec(pmcsv);
2836 fp = PerlIO_open(name, mode);
2844 register PERL_CONTEXT *cx;
2848 char *tryname = Nullch;
2849 SV *namesv = Nullsv;
2851 I32 gimme = GIMME_V;
2852 PerlIO *tryrsfp = 0;
2854 int filter_has_file = 0;
2855 GV *filter_child_proc = 0;
2856 SV *filter_state = 0;
2863 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2864 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2865 UV rev = 0, ver = 0, sver = 0;
2867 U8 *s = (U8*)SvPVX(sv);
2868 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2870 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2873 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2876 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2879 if (PERL_REVISION < rev
2880 || (PERL_REVISION == rev
2881 && (PERL_VERSION < ver
2882 || (PERL_VERSION == ver
2883 && PERL_SUBVERSION < sver))))
2885 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2886 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2887 PERL_VERSION, PERL_SUBVERSION);
2889 if (ckWARN(WARN_PORTABLE))
2890 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2891 "v-string in use/require non-portable");
2894 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2895 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2896 + ((NV)PERL_SUBVERSION/(NV)1000000)
2897 + 0.00000099 < SvNV(sv))
2901 NV nver = (nrev - rev) * 1000;
2902 UV ver = (UV)(nver + 0.0009);
2903 NV nsver = (nver - ver) * 1000;
2904 UV sver = (UV)(nsver + 0.0009);
2906 /* help out with the "use 5.6" confusion */
2907 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2908 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2909 " (did you mean v%"UVuf".%03"UVuf"?)--"
2910 "this is only v%d.%d.%d, stopped",
2911 rev, ver, sver, rev, ver/100,
2912 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2915 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2916 "this is only v%d.%d.%d, stopped",
2917 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2924 name = SvPV(sv, len);
2925 if (!(name && len > 0 && *name))
2926 DIE(aTHX_ "Null filename used");
2927 TAINT_PROPER("require");
2928 if (PL_op->op_type == OP_REQUIRE &&
2929 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2930 *svp != &PL_sv_undef)
2933 /* prepare to compile file */
2935 if (path_is_absolute(name)) {
2937 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2939 #ifdef MACOS_TRADITIONAL
2943 MacPerl_CanonDir(name, newname, 1);
2944 if (path_is_absolute(newname)) {
2946 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2951 AV *ar = GvAVn(PL_incgv);
2955 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2958 namesv = NEWSV(806, 0);
2959 for (i = 0; i <= AvFILL(ar); i++) {
2960 SV *dirsv = *av_fetch(ar, i, TRUE);
2966 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2967 && !sv_isobject(loader))
2969 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2972 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2973 PTR2UV(SvRV(dirsv)), name);
2974 tryname = SvPVX(namesv);
2985 if (sv_isobject(loader))
2986 count = call_method("INC", G_ARRAY);
2988 count = call_sv(loader, G_ARRAY);
2998 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3002 if (SvTYPE(arg) == SVt_PVGV) {
3003 IO *io = GvIO((GV *)arg);
3008 tryrsfp = IoIFP(io);
3009 if (IoTYPE(io) == IoTYPE_PIPE) {
3010 /* reading from a child process doesn't
3011 nest -- when returning from reading
3012 the inner module, the outer one is
3013 unreadable (closed?) I've tried to
3014 save the gv to manage the lifespan of
3015 the pipe, but this didn't help. XXX */
3016 filter_child_proc = (GV *)arg;
3017 (void)SvREFCNT_inc(filter_child_proc);
3020 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3021 PerlIO_close(IoOFP(io));
3033 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3035 (void)SvREFCNT_inc(filter_sub);
3038 filter_state = SP[i];
3039 (void)SvREFCNT_inc(filter_state);
3043 tryrsfp = PerlIO_open("/dev/null",
3058 filter_has_file = 0;
3059 if (filter_child_proc) {
3060 SvREFCNT_dec(filter_child_proc);
3061 filter_child_proc = 0;
3064 SvREFCNT_dec(filter_state);
3068 SvREFCNT_dec(filter_sub);
3073 if (!path_is_absolute(name)
3074 #ifdef MACOS_TRADITIONAL
3075 /* We consider paths of the form :a:b ambiguous and interpret them first
3076 as global then as local
3078 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3081 char *dir = SvPVx(dirsv, n_a);
3082 #ifdef MACOS_TRADITIONAL
3086 MacPerl_CanonDir(name, buf2, 1);
3087 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3091 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3093 sv_setpv(namesv, unixdir);
3094 sv_catpv(namesv, unixname);
3096 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3099 TAINT_PROPER("require");
3100 tryname = SvPVX(namesv);
3101 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3103 if (tryname[0] == '.' && tryname[1] == '/')
3112 SAVECOPFILE_FREE(&PL_compiling);
3113 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3114 SvREFCNT_dec(namesv);
3116 if (PL_op->op_type == OP_REQUIRE) {
3117 char *msgstr = name;
3118 if (namesv) { /* did we lookup @INC? */
3119 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3120 SV *dirmsgsv = NEWSV(0, 0);
3121 AV *ar = GvAVn(PL_incgv);
3123 sv_catpvn(msg, " in @INC", 8);
3124 if (instr(SvPVX(msg), ".h "))
3125 sv_catpv(msg, " (change .h to .ph maybe?)");
3126 if (instr(SvPVX(msg), ".ph "))
3127 sv_catpv(msg, " (did you run h2ph?)");
3128 sv_catpv(msg, " (@INC contains:");
3129 for (i = 0; i <= AvFILL(ar); i++) {
3130 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3131 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3132 sv_catsv(msg, dirmsgsv);
3134 sv_catpvn(msg, ")", 1);
3135 SvREFCNT_dec(dirmsgsv);
3136 msgstr = SvPV_nolen(msg);
3138 DIE(aTHX_ "Can't locate %s", msgstr);
3144 SETERRNO(0, SS_NORMAL);
3146 /* Assume success here to prevent recursive requirement. */
3148 /* Check whether a hook in @INC has already filled %INC */
3149 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3150 (void)hv_store(GvHVn(PL_incgv), name, len,
3151 (hook_sv ? SvREFCNT_inc(hook_sv)
3152 : newSVpv(CopFILE(&PL_compiling), 0)),
3158 lex_start(sv_2mortal(newSVpvn("",0)));
3159 SAVEGENERICSV(PL_rsfp_filters);
3160 PL_rsfp_filters = Nullav;
3165 SAVESPTR(PL_compiling.cop_warnings);
3166 if (PL_dowarn & G_WARN_ALL_ON)
3167 PL_compiling.cop_warnings = pWARN_ALL ;
3168 else if (PL_dowarn & G_WARN_ALL_OFF)
3169 PL_compiling.cop_warnings = pWARN_NONE ;
3170 else if (PL_taint_warn)
3171 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3173 PL_compiling.cop_warnings = pWARN_STD ;
3174 SAVESPTR(PL_compiling.cop_io);
3175 PL_compiling.cop_io = Nullsv;
3177 if (filter_sub || filter_child_proc) {
3178 SV *datasv = filter_add(run_user_filter, Nullsv);
3179 IoLINES(datasv) = filter_has_file;
3180 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3181 IoTOP_GV(datasv) = (GV *)filter_state;
3182 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3185 /* switch to eval mode */
3186 push_return(PL_op->op_next);
3187 PUSHBLOCK(cx, CXt_EVAL, SP);
3188 PUSHEVAL(cx, name, Nullgv);
3190 SAVECOPLINE(&PL_compiling);
3191 CopLINE_set(&PL_compiling, 0);
3195 /* Store and reset encoding. */
3196 encoding = PL_encoding;
3197 PL_encoding = Nullsv;
3199 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3201 /* Restore encoding. */
3202 PL_encoding = encoding;
3209 return pp_require();
3215 register PERL_CONTEXT *cx;
3217 I32 gimme = GIMME_V, was = PL_sub_generation;
3218 char tbuf[TYPE_DIGITS(long) + 12];
3219 char *tmpbuf = tbuf;
3228 TAINT_PROPER("eval");
3234 /* switch to eval mode */
3236 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3237 SV *sv = sv_newmortal();
3238 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3239 (unsigned long)++PL_evalseq,
3240 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3244 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3245 SAVECOPFILE_FREE(&PL_compiling);
3246 CopFILE_set(&PL_compiling, tmpbuf+2);
3247 SAVECOPLINE(&PL_compiling);
3248 CopLINE_set(&PL_compiling, 1);
3249 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3250 deleting the eval's FILEGV from the stash before gv_check() runs
3251 (i.e. before run-time proper). To work around the coredump that
3252 ensues, we always turn GvMULTI_on for any globals that were
3253 introduced within evals. See force_ident(). GSAR 96-10-12 */
3254 safestr = savepv(tmpbuf);
3255 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3257 PL_hints = PL_op->op_targ;
3258 SAVESPTR(PL_compiling.cop_warnings);
3259 if (specialWARN(PL_curcop->cop_warnings))
3260 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3262 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3263 SAVEFREESV(PL_compiling.cop_warnings);
3265 SAVESPTR(PL_compiling.cop_io);
3266 if (specialCopIO(PL_curcop->cop_io))
3267 PL_compiling.cop_io = PL_curcop->cop_io;
3269 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3270 SAVEFREESV(PL_compiling.cop_io);
3272 /* special case: an eval '' executed within the DB package gets lexically
3273 * placed in the first non-DB CV rather than the current CV - this
3274 * allows the debugger to execute code, find lexicals etc, in the
3275 * scope of the code being debugged. Passing &seq gets find_runcv
3276 * to do the dirty work for us */
3277 runcv = find_runcv(&seq);
3279 push_return(PL_op->op_next);
3280 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3281 PUSHEVAL(cx, 0, Nullgv);
3283 /* prepare to compile string */
3285 if (PERLDB_LINE && PL_curstash != PL_debstash)
3286 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3288 ret = doeval(gimme, NULL, runcv, seq);
3289 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3290 && ret != PL_op->op_next) { /* Successive compilation. */
3291 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3293 return DOCATCH(ret);
3303 register PERL_CONTEXT *cx;
3305 U8 save_flags = PL_op -> op_flags;
3310 retop = pop_return();
3313 if (gimme == G_VOID)
3315 else if (gimme == G_SCALAR) {
3318 if (SvFLAGS(TOPs) & SVs_TEMP)
3321 *MARK = sv_mortalcopy(TOPs);
3325 *MARK = &PL_sv_undef;
3330 /* in case LEAVE wipes old return values */
3331 for (mark = newsp + 1; mark <= SP; mark++) {
3332 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3333 *mark = sv_mortalcopy(*mark);
3334 TAINT_NOT; /* Each item is independent */
3338 PL_curpm = newpm; /* Don't pop $1 et al till now */
3341 assert(CvDEPTH(PL_compcv) == 1);
3343 CvDEPTH(PL_compcv) = 0;
3346 if (optype == OP_REQUIRE &&
3347 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3349 /* Unassume the success we assumed earlier. */
3350 SV *nsv = cx->blk_eval.old_namesv;
3351 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3352 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3353 /* die_where() did LEAVE, or we won't be here */
3357 if (!(save_flags & OPf_SPECIAL))
3367 register PERL_CONTEXT *cx;
3368 I32 gimme = GIMME_V;
3373 push_return(cLOGOP->op_other->op_next);
3374 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3377 PL_in_eval = EVAL_INEVAL;
3380 return DOCATCH(PL_op->op_next);
3391 register PERL_CONTEXT *cx;
3396 retop = pop_return();
3399 if (gimme == G_VOID)
3401 else if (gimme == G_SCALAR) {
3404 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3407 *MARK = sv_mortalcopy(TOPs);
3411 *MARK = &PL_sv_undef;
3416 /* in case LEAVE wipes old return values */
3417 for (mark = newsp + 1; mark <= SP; mark++) {
3418 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3419 *mark = sv_mortalcopy(*mark);
3420 TAINT_NOT; /* Each item is independent */
3424 PL_curpm = newpm; /* Don't pop $1 et al till now */
3432 S_doparseform(pTHX_ SV *sv)
3435 register char *s = SvPV_force(sv, len);
3436 register char *send = s + len;
3437 register char *base = Nullch;
3438 register I32 skipspaces = 0;
3439 bool noblank = FALSE;
3440 bool repeat = FALSE;
3441 bool postspace = FALSE;
3449 Perl_croak(aTHX_ "Null picture in formline");
3451 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3456 *fpc++ = FF_LINEMARK;
3457 noblank = repeat = FALSE;
3475 case ' ': case '\t':
3486 *fpc++ = FF_LITERAL;
3494 *fpc++ = (U16)skipspaces;
3498 *fpc++ = FF_NEWLINE;
3502 arg = fpc - linepc + 1;
3509 *fpc++ = FF_LINEMARK;
3510 noblank = repeat = FALSE;
3519 ischop = s[-1] == '^';
3525 arg = (s - base) - 1;
3527 *fpc++ = FF_LITERAL;
3536 *fpc++ = FF_LINEGLOB;
3538 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3539 arg = ischop ? 512 : 0;
3549 arg |= 256 + (s - f);
3551 *fpc++ = s - base; /* fieldsize for FETCH */
3552 *fpc++ = FF_DECIMAL;
3555 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3556 arg = ischop ? 512 : 0;
3558 s++; /* skip the '0' first */
3567 arg |= 256 + (s - f);
3569 *fpc++ = s - base; /* fieldsize for FETCH */
3570 *fpc++ = FF_0DECIMAL;
3575 bool ismore = FALSE;
3578 while (*++s == '>') ;
3579 prespace = FF_SPACE;
3581 else if (*s == '|') {
3582 while (*++s == '|') ;
3583 prespace = FF_HALFSPACE;
3588 while (*++s == '<') ;
3591 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3595 *fpc++ = s - base; /* fieldsize for FETCH */
3597 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3600 *fpc++ = (U16)prespace;
3615 { /* need to jump to the next word */
3617 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3618 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3619 s = SvPVX(sv) + SvCUR(sv) + z;
3621 Copy(fops, s, arg, U16);
3623 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3628 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3630 SV *datasv = FILTER_DATA(idx);
3631 int filter_has_file = IoLINES(datasv);
3632 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3633 SV *filter_state = (SV *)IoTOP_GV(datasv);
3634 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3637 /* I was having segfault trouble under Linux 2.2.5 after a
3638 parse error occured. (Had to hack around it with a test
3639 for PL_error_count == 0.) Solaris doesn't segfault --
3640 not sure where the trouble is yet. XXX */
3642 if (filter_has_file) {
3643 len = FILTER_READ(idx+1, buf_sv, maxlen);
3646 if (filter_sub && len >= 0) {
3657 PUSHs(sv_2mortal(newSViv(maxlen)));
3659 PUSHs(filter_state);
3662 count = call_sv(filter_sub, G_SCALAR);
3678 IoLINES(datasv) = 0;
3679 if (filter_child_proc) {
3680 SvREFCNT_dec(filter_child_proc);
3681 IoFMT_GV(datasv) = Nullgv;
3684 SvREFCNT_dec(filter_state);
3685 IoTOP_GV(datasv) = Nullgv;
3688 SvREFCNT_dec(filter_sub);
3689 IoBOTTOM_GV(datasv) = Nullgv;
3691 filter_del(run_user_filter);
3697 /* perhaps someone can come up with a better name for
3698 this? it is not really "absolute", per se ... */
3700 S_path_is_absolute(pTHX_ char *name)
3702 if (PERL_FILE_IS_ABSOLUTE(name)
3703 #ifdef MACOS_TRADITIONAL
3706 || (*name == '.' && (name[1] == '/' ||
3707 (name[1] == '.' && name[2] == '/'))))