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");
1019 S_dopoptolabel(pTHX_ char *label)
1022 register PERL_CONTEXT *cx;
1024 for (i = cxstack_ix; i >= 0; i--) {
1026 switch (CxTYPE(cx)) {
1028 if (ckWARN(WARN_EXITING))
1029 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1033 if (ckWARN(WARN_EXITING))
1034 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1038 if (ckWARN(WARN_EXITING))
1039 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1043 if (ckWARN(WARN_EXITING))
1044 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1048 if (ckWARN(WARN_EXITING))
1049 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1053 if (!cx->blk_loop.label ||
1054 strNE(label, cx->blk_loop.label) ) {
1055 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1056 (long)i, cx->blk_loop.label));
1059 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1067 Perl_dowantarray(pTHX)
1069 I32 gimme = block_gimme();
1070 return (gimme == G_VOID) ? G_SCALAR : gimme;
1074 Perl_block_gimme(pTHX)
1078 cxix = dopoptosub(cxstack_ix);
1082 switch (cxstack[cxix].blk_gimme) {
1090 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1097 Perl_is_lvalue_sub(pTHX)
1101 cxix = dopoptosub(cxstack_ix);
1102 assert(cxix >= 0); /* We should only be called from inside subs */
1104 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1105 return cxstack[cxix].blk_sub.lval;
1111 S_dopoptosub(pTHX_ I32 startingblock)
1113 return dopoptosub_at(cxstack, startingblock);
1117 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1120 register PERL_CONTEXT *cx;
1121 for (i = startingblock; i >= 0; i--) {
1123 switch (CxTYPE(cx)) {
1129 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1137 S_dopoptoeval(pTHX_ I32 startingblock)
1140 register PERL_CONTEXT *cx;
1141 for (i = startingblock; i >= 0; i--) {
1143 switch (CxTYPE(cx)) {
1147 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1155 S_dopoptoloop(pTHX_ I32 startingblock)
1158 register PERL_CONTEXT *cx;
1159 for (i = startingblock; i >= 0; i--) {
1161 switch (CxTYPE(cx)) {
1163 if (ckWARN(WARN_EXITING))
1164 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1168 if (ckWARN(WARN_EXITING))
1169 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1173 if (ckWARN(WARN_EXITING))
1174 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1178 if (ckWARN(WARN_EXITING))
1179 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1183 if (ckWARN(WARN_EXITING))
1184 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1188 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1196 Perl_dounwind(pTHX_ I32 cxix)
1198 register PERL_CONTEXT *cx;
1201 while (cxstack_ix > cxix) {
1203 cx = &cxstack[cxstack_ix];
1204 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1205 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1206 /* Note: we don't need to restore the base context info till the end. */
1207 switch (CxTYPE(cx)) {
1210 continue; /* not break */
1232 Perl_qerror(pTHX_ SV *err)
1235 sv_catsv(ERRSV, err);
1237 sv_catsv(PL_errors, err);
1239 Perl_warn(aTHX_ "%"SVf, err);
1244 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1252 register PERL_CONTEXT *cx;
1257 if (PL_in_eval & EVAL_KEEPERR) {
1258 static char prefix[] = "\t(in cleanup) ";
1263 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1266 if (*e != *message || strNE(e,message))
1270 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1271 sv_catpvn(err, prefix, sizeof(prefix)-1);
1272 sv_catpvn(err, message, msglen);
1273 if (ckWARN(WARN_MISC)) {
1274 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1275 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1280 sv_setpvn(ERRSV, message, msglen);
1284 message = SvPVx(ERRSV, msglen);
1286 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1287 && PL_curstackinfo->si_prev)
1296 if (cxix < cxstack_ix)
1299 POPBLOCK(cx,PL_curpm);
1300 if (CxTYPE(cx) != CXt_EVAL) {
1301 PerlIO_write(Perl_error_log, "panic: die ", 11);
1302 PerlIO_write(Perl_error_log, message, msglen);
1307 if (gimme == G_SCALAR)
1308 *++newsp = &PL_sv_undef;
1309 PL_stack_sp = newsp;
1313 /* LEAVE could clobber PL_curcop (see save_re_context())
1314 * XXX it might be better to find a way to avoid messing with
1315 * PL_curcop in save_re_context() instead, but this is a more
1316 * minimal fix --GSAR */
1317 PL_curcop = cx->blk_oldcop;
1319 if (optype == OP_REQUIRE) {
1320 char* msg = SvPVx(ERRSV, n_a);
1321 DIE(aTHX_ "%sCompilation failed in require",
1322 *msg ? msg : "Unknown error\n");
1324 return pop_return();
1328 message = SvPVx(ERRSV, msglen);
1330 /* if STDERR is tied, print to it instead */
1331 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1332 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1335 XPUSHs(SvTIED_obj((SV*)io, mg));
1336 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1338 call_method("PRINT", G_SCALAR);
1343 /* SFIO can really mess with your errno */
1346 PerlIO *serr = Perl_error_log;
1348 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1349 (void)PerlIO_flush(serr);
1362 if (SvTRUE(left) != SvTRUE(right))
1374 RETURNOP(cLOGOP->op_other);
1383 RETURNOP(cLOGOP->op_other);
1392 if (!sv || !SvANY(sv)) {
1393 RETURNOP(cLOGOP->op_other);
1396 switch (SvTYPE(sv)) {
1398 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1402 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1406 if (CvROOT(sv) || CvXSUB(sv))
1416 RETURNOP(cLOGOP->op_other);
1422 register I32 cxix = dopoptosub(cxstack_ix);
1423 register PERL_CONTEXT *cx;
1424 register PERL_CONTEXT *ccstack = cxstack;
1425 PERL_SI *top_si = PL_curstackinfo;
1436 /* we may be in a higher stacklevel, so dig down deeper */
1437 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1438 top_si = top_si->si_prev;
1439 ccstack = top_si->si_cxstack;
1440 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1443 if (GIMME != G_ARRAY) {
1449 if (PL_DBsub && cxix >= 0 &&
1450 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1454 cxix = dopoptosub_at(ccstack, cxix - 1);
1457 cx = &ccstack[cxix];
1458 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1459 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1460 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1461 field below is defined for any cx. */
1462 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1463 cx = &ccstack[dbcxix];
1466 stashname = CopSTASHPV(cx->blk_oldcop);
1467 if (GIMME != G_ARRAY) {
1470 PUSHs(&PL_sv_undef);
1473 sv_setpv(TARG, stashname);
1482 PUSHs(&PL_sv_undef);
1484 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1485 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1486 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1489 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1490 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1491 /* So is ccstack[dbcxix]. */
1494 gv_efullname3(sv, cvgv, Nullch);
1495 PUSHs(sv_2mortal(sv));
1496 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1499 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1500 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1504 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1505 PUSHs(sv_2mortal(newSViv(0)));
1507 gimme = (I32)cx->blk_gimme;
1508 if (gimme == G_VOID)
1509 PUSHs(&PL_sv_undef);
1511 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1512 if (CxTYPE(cx) == CXt_EVAL) {
1514 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1515 PUSHs(cx->blk_eval.cur_text);
1519 else if (cx->blk_eval.old_namesv) {
1520 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1523 /* eval BLOCK (try blocks have old_namesv == 0) */
1525 PUSHs(&PL_sv_undef);
1526 PUSHs(&PL_sv_undef);
1530 PUSHs(&PL_sv_undef);
1531 PUSHs(&PL_sv_undef);
1533 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1534 && CopSTASH_eq(PL_curcop, PL_debstash))
1536 AV *ary = cx->blk_sub.argarray;
1537 int off = AvARRAY(ary) - AvALLOC(ary);
1541 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1544 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1547 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1548 av_extend(PL_dbargs, AvFILLp(ary) + off);
1549 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1550 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1552 /* XXX only hints propagated via op_private are currently
1553 * visible (others are not easily accessible, since they
1554 * use the global PL_hints) */
1555 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1556 HINT_PRIVATE_MASK)));
1559 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1561 if (old_warnings == pWARN_NONE ||
1562 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1563 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1564 else if (old_warnings == pWARN_ALL ||
1565 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1566 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1568 mask = newSVsv(old_warnings);
1569 PUSHs(sv_2mortal(mask));
1584 sv_reset(tmps, CopSTASH(PL_curcop));
1594 /* like pp_nextstate, but used instead when the debugger is active */
1598 PL_curcop = (COP*)PL_op;
1599 TAINT_NOT; /* Each statement is presumed innocent */
1600 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1603 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1607 register PERL_CONTEXT *cx;
1608 I32 gimme = G_ARRAY;
1615 DIE(aTHX_ "No DB::DB routine defined");
1617 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1618 /* don't do recursive DB::DB call */
1630 push_return(PL_op->op_next);
1631 PUSHBLOCK(cx, CXt_SUB, SP);
1634 (void)SvREFCNT_inc(cv);
1635 PAD_SET_CUR(CvPADLIST(cv),1);
1636 RETURNOP(CvSTART(cv));
1650 register PERL_CONTEXT *cx;
1651 I32 gimme = GIMME_V;
1653 U32 cxtype = CXt_LOOP;
1661 if (PL_op->op_targ) {
1662 #ifndef USE_ITHREADS
1663 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1666 SAVEPADSV(PL_op->op_targ);
1667 iterdata = INT2PTR(void*, PL_op->op_targ);
1668 cxtype |= CXp_PADVAR;
1673 svp = &GvSV(gv); /* symbol table variable */
1674 SAVEGENERICSV(*svp);
1677 iterdata = (void*)gv;
1683 PUSHBLOCK(cx, cxtype, SP);
1685 PUSHLOOP(cx, iterdata, MARK);
1687 PUSHLOOP(cx, svp, MARK);
1689 if (PL_op->op_flags & OPf_STACKED) {
1690 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1691 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1693 /* See comment in pp_flop() */
1694 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1695 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1696 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1697 looks_like_number((SV*)cx->blk_loop.iterary)))
1699 if (SvNV(sv) < IV_MIN ||
1700 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1701 DIE(aTHX_ "Range iterator outside integer range");
1702 cx->blk_loop.iterix = SvIV(sv);
1703 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1706 cx->blk_loop.iterlval = newSVsv(sv);
1710 cx->blk_loop.iterary = PL_curstack;
1711 AvFILLp(PL_curstack) = SP - PL_stack_base;
1712 cx->blk_loop.iterix = MARK - PL_stack_base;
1721 register PERL_CONTEXT *cx;
1722 I32 gimme = GIMME_V;
1728 PUSHBLOCK(cx, CXt_LOOP, SP);
1729 PUSHLOOP(cx, 0, SP);
1737 register PERL_CONTEXT *cx;
1745 newsp = PL_stack_base + cx->blk_loop.resetsp;
1748 if (gimme == G_VOID)
1750 else if (gimme == G_SCALAR) {
1752 *++newsp = sv_mortalcopy(*SP);
1754 *++newsp = &PL_sv_undef;
1758 *++newsp = sv_mortalcopy(*++mark);
1759 TAINT_NOT; /* Each item is independent */
1765 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1766 PL_curpm = newpm; /* ... and pop $1 et al */
1778 register PERL_CONTEXT *cx;
1779 bool popsub2 = FALSE;
1780 bool clear_errsv = FALSE;
1787 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1788 if (cxstack_ix == PL_sortcxix
1789 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1791 if (cxstack_ix > PL_sortcxix)
1792 dounwind(PL_sortcxix);
1793 AvARRAY(PL_curstack)[1] = *SP;
1794 PL_stack_sp = PL_stack_base + 1;
1799 cxix = dopoptosub(cxstack_ix);
1801 DIE(aTHX_ "Can't return outside a subroutine");
1802 if (cxix < cxstack_ix)
1806 switch (CxTYPE(cx)) {
1811 if (!(PL_in_eval & EVAL_KEEPERR))
1817 if (optype == OP_REQUIRE &&
1818 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1820 /* Unassume the success we assumed earlier. */
1821 SV *nsv = cx->blk_eval.old_namesv;
1822 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1823 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1830 DIE(aTHX_ "panic: return");
1834 if (gimme == G_SCALAR) {
1837 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1839 *++newsp = SvREFCNT_inc(*SP);
1844 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1846 *++newsp = sv_mortalcopy(sv);
1851 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1854 *++newsp = sv_mortalcopy(*SP);
1857 *++newsp = &PL_sv_undef;
1859 else if (gimme == G_ARRAY) {
1860 while (++MARK <= SP) {
1861 *++newsp = (popsub2 && SvTEMP(*MARK))
1862 ? *MARK : sv_mortalcopy(*MARK);
1863 TAINT_NOT; /* Each item is independent */
1866 PL_stack_sp = newsp;
1868 /* Stack values are safe: */
1870 POPSUB(cx,sv); /* release CV and @_ ... */
1874 PL_curpm = newpm; /* ... and pop $1 et al */
1880 return pop_return();
1887 register PERL_CONTEXT *cx;
1897 if (PL_op->op_flags & OPf_SPECIAL) {
1898 cxix = dopoptoloop(cxstack_ix);
1900 DIE(aTHX_ "Can't \"last\" outside a loop block");
1903 cxix = dopoptolabel(cPVOP->op_pv);
1905 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1907 if (cxix < cxstack_ix)
1912 switch (CxTYPE(cx)) {
1915 newsp = PL_stack_base + cx->blk_loop.resetsp;
1916 nextop = cx->blk_loop.last_op->op_next;
1920 nextop = pop_return();
1924 nextop = pop_return();
1928 nextop = pop_return();
1931 DIE(aTHX_ "panic: last");
1935 if (gimme == G_SCALAR) {
1937 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1938 ? *SP : sv_mortalcopy(*SP);
1940 *++newsp = &PL_sv_undef;
1942 else if (gimme == G_ARRAY) {
1943 while (++MARK <= SP) {
1944 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1945 ? *MARK : sv_mortalcopy(*MARK);
1946 TAINT_NOT; /* Each item is independent */
1952 /* Stack values are safe: */
1955 POPLOOP(cx); /* release loop vars ... */
1959 POPSUB(cx,sv); /* release CV and @_ ... */
1962 PL_curpm = newpm; /* ... and pop $1 et al */
1972 register PERL_CONTEXT *cx;
1975 if (PL_op->op_flags & OPf_SPECIAL) {
1976 cxix = dopoptoloop(cxstack_ix);
1978 DIE(aTHX_ "Can't \"next\" outside a loop block");
1981 cxix = dopoptolabel(cPVOP->op_pv);
1983 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1985 if (cxix < cxstack_ix)
1988 /* clear off anything above the scope we're re-entering, but
1989 * save the rest until after a possible continue block */
1990 inner = PL_scopestack_ix;
1992 if (PL_scopestack_ix < inner)
1993 leave_scope(PL_scopestack[PL_scopestack_ix]);
1994 return cx->blk_loop.next_op;
2000 register PERL_CONTEXT *cx;
2003 if (PL_op->op_flags & OPf_SPECIAL) {
2004 cxix = dopoptoloop(cxstack_ix);
2006 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2009 cxix = dopoptolabel(cPVOP->op_pv);
2011 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2013 if (cxix < cxstack_ix)
2017 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2018 LEAVE_SCOPE(oldsave);
2019 return cx->blk_loop.redo_op;
2023 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2027 static char too_deep[] = "Target of goto is too deeply nested";
2030 Perl_croak(aTHX_ too_deep);
2031 if (o->op_type == OP_LEAVE ||
2032 o->op_type == OP_SCOPE ||
2033 o->op_type == OP_LEAVELOOP ||
2034 o->op_type == OP_LEAVETRY)
2036 *ops++ = cUNOPo->op_first;
2038 Perl_croak(aTHX_ too_deep);
2041 if (o->op_flags & OPf_KIDS) {
2042 /* First try all the kids at this level, since that's likeliest. */
2043 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2044 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2045 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2048 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2049 if (kid == PL_lastgotoprobe)
2051 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2054 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2055 ops[-1]->op_type == OP_DBSTATE)
2060 if ((o = dofindlabel(kid, label, ops, oplimit)))
2079 register PERL_CONTEXT *cx;
2080 #define GOTO_DEPTH 64
2081 OP *enterops[GOTO_DEPTH];
2083 int do_dump = (PL_op->op_type == OP_DUMP);
2084 static char must_have_label[] = "goto must have label";
2087 if (PL_op->op_flags & OPf_STACKED) {
2091 /* This egregious kludge implements goto &subroutine */
2092 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2094 register PERL_CONTEXT *cx;
2095 CV* cv = (CV*)SvRV(sv);
2101 if (!CvROOT(cv) && !CvXSUB(cv)) {
2106 /* autoloaded stub? */
2107 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2109 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2110 GvNAMELEN(gv), FALSE);
2111 if (autogv && (cv = GvCV(autogv)))
2113 tmpstr = sv_newmortal();
2114 gv_efullname3(tmpstr, gv, Nullch);
2115 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2117 DIE(aTHX_ "Goto undefined subroutine");
2120 /* First do some returnish stuff. */
2121 cxix = dopoptosub(cxstack_ix);
2123 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2124 if (cxix < cxstack_ix)
2128 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2130 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2131 /* put @_ back onto stack */
2132 AV* av = cx->blk_sub.argarray;
2134 items = AvFILLp(av) + 1;
2136 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2137 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2138 PL_stack_sp += items;
2139 SvREFCNT_dec(GvAV(PL_defgv));
2140 GvAV(PL_defgv) = cx->blk_sub.savearray;
2141 /* abandon @_ if it got reified */
2143 (void)sv_2mortal((SV*)av); /* delay until return */
2145 av_extend(av, items-1);
2146 AvFLAGS(av) = AVf_REIFY;
2147 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2150 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2152 av = GvAV(PL_defgv);
2153 items = AvFILLp(av) + 1;
2155 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2156 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2157 PL_stack_sp += items;
2159 if (CxTYPE(cx) == CXt_SUB &&
2160 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2161 SvREFCNT_dec(cx->blk_sub.cv);
2162 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2163 LEAVE_SCOPE(oldsave);
2165 /* Now do some callish stuff. */
2168 #ifdef PERL_XSUB_OLDSTYLE
2169 if (CvOLDSTYLE(cv)) {
2170 I32 (*fp3)(int,int,int);
2175 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2176 items = (*fp3)(CvXSUBANY(cv).any_i32,
2177 mark - PL_stack_base + 1,
2179 SP = PL_stack_base + items;
2182 #endif /* PERL_XSUB_OLDSTYLE */
2187 PL_stack_sp--; /* There is no cv arg. */
2188 /* Push a mark for the start of arglist */
2190 (void)(*CvXSUB(cv))(aTHX_ cv);
2191 /* Pop the current context like a decent sub should */
2192 POPBLOCK(cx, PL_curpm);
2193 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2196 return pop_return();
2199 AV* padlist = CvPADLIST(cv);
2200 if (CxTYPE(cx) == CXt_EVAL) {
2201 PL_in_eval = cx->blk_eval.old_in_eval;
2202 PL_eval_root = cx->blk_eval.old_eval_root;
2203 cx->cx_type = CXt_SUB;
2204 cx->blk_sub.hasargs = 0;
2206 cx->blk_sub.cv = cv;
2207 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2210 if (CvDEPTH(cv) < 2)
2211 (void)SvREFCNT_inc(cv);
2213 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2214 sub_crush_depth(cv);
2215 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2217 PAD_SET_CUR(padlist, CvDEPTH(cv));
2218 if (cx->blk_sub.hasargs)
2220 AV* av = (AV*)PAD_SVl(0);
2223 cx->blk_sub.savearray = GvAV(PL_defgv);
2224 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2225 CX_CURPAD_SAVE(cx->blk_sub);
2226 cx->blk_sub.argarray = av;
2229 if (items >= AvMAX(av) + 1) {
2231 if (AvARRAY(av) != ary) {
2232 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2233 SvPVX(av) = (char*)ary;
2235 if (items >= AvMAX(av) + 1) {
2236 AvMAX(av) = items - 1;
2237 Renew(ary,items+1,SV*);
2239 SvPVX(av) = (char*)ary;
2242 Copy(mark,AvARRAY(av),items,SV*);
2243 AvFILLp(av) = items - 1;
2244 assert(!AvREAL(av));
2251 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2253 * We do not care about using sv to call CV;
2254 * it's for informational purposes only.
2256 SV *sv = GvSV(PL_DBsub);
2259 if (PERLDB_SUB_NN) {
2260 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2263 gv_efullname3(sv, CvGV(cv), Nullch);
2266 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2267 PUSHMARK( PL_stack_sp );
2268 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2272 RETURNOP(CvSTART(cv));
2276 label = SvPV(sv,n_a);
2277 if (!(do_dump || *label))
2278 DIE(aTHX_ must_have_label);
2281 else if (PL_op->op_flags & OPf_SPECIAL) {
2283 DIE(aTHX_ must_have_label);
2286 label = cPVOP->op_pv;
2288 if (label && *label) {
2290 bool leaving_eval = FALSE;
2291 PERL_CONTEXT *last_eval_cx = 0;
2295 PL_lastgotoprobe = 0;
2297 for (ix = cxstack_ix; ix >= 0; ix--) {
2299 switch (CxTYPE(cx)) {
2301 leaving_eval = TRUE;
2302 if (CxREALEVAL(cx)) {
2303 gotoprobe = (last_eval_cx ?
2304 last_eval_cx->blk_eval.old_eval_root :
2309 /* else fall through */
2311 gotoprobe = cx->blk_oldcop->op_sibling;
2317 gotoprobe = cx->blk_oldcop->op_sibling;
2319 gotoprobe = PL_main_root;
2322 if (CvDEPTH(cx->blk_sub.cv)) {
2323 gotoprobe = CvROOT(cx->blk_sub.cv);
2329 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2332 DIE(aTHX_ "panic: goto");
2333 gotoprobe = PL_main_root;
2337 retop = dofindlabel(gotoprobe, label,
2338 enterops, enterops + GOTO_DEPTH);
2342 PL_lastgotoprobe = gotoprobe;
2345 DIE(aTHX_ "Can't find label %s", label);
2347 /* if we're leaving an eval, check before we pop any frames
2348 that we're not going to punt, otherwise the error
2351 if (leaving_eval && *enterops && enterops[1]) {
2353 for (i = 1; enterops[i]; i++)
2354 if (enterops[i]->op_type == OP_ENTERITER)
2355 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2358 /* pop unwanted frames */
2360 if (ix < cxstack_ix) {
2367 oldsave = PL_scopestack[PL_scopestack_ix];
2368 LEAVE_SCOPE(oldsave);
2371 /* push wanted frames */
2373 if (*enterops && enterops[1]) {
2375 for (ix = 1; enterops[ix]; ix++) {
2376 PL_op = enterops[ix];
2377 /* Eventually we may want to stack the needed arguments
2378 * for each op. For now, we punt on the hard ones. */
2379 if (PL_op->op_type == OP_ENTERITER)
2380 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2381 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2389 if (!retop) retop = PL_main_start;
2391 PL_restartop = retop;
2392 PL_do_undump = TRUE;
2396 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2397 PL_do_undump = FALSE;
2413 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2415 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2418 PL_exit_flags |= PERL_EXIT_EXPECTED;
2420 PUSHs(&PL_sv_undef);
2428 NV value = SvNVx(GvSV(cCOP->cop_gv));
2429 register I32 match = I_32(value);
2432 if (((NV)match) > value)
2433 --match; /* was fractional--truncate other way */
2435 match -= cCOP->uop.scop.scop_offset;
2438 else if (match > cCOP->uop.scop.scop_max)
2439 match = cCOP->uop.scop.scop_max;
2440 PL_op = cCOP->uop.scop.scop_next[match];
2450 PL_op = PL_op->op_next; /* can't assume anything */
2453 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2454 match -= cCOP->uop.scop.scop_offset;
2457 else if (match > cCOP->uop.scop.scop_max)
2458 match = cCOP->uop.scop.scop_max;
2459 PL_op = cCOP->uop.scop.scop_next[match];
2468 S_save_lines(pTHX_ AV *array, SV *sv)
2470 register char *s = SvPVX(sv);
2471 register char *send = SvPVX(sv) + SvCUR(sv);
2473 register I32 line = 1;
2475 while (s && s < send) {
2476 SV *tmpstr = NEWSV(85,0);
2478 sv_upgrade(tmpstr, SVt_PVMG);
2479 t = strchr(s, '\n');
2485 sv_setpvn(tmpstr, s, t - s);
2486 av_store(array, line++, tmpstr);
2491 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2493 S_docatch_body(pTHX_ va_list args)
2495 return docatch_body();
2500 S_docatch_body(pTHX)
2507 S_docatch(pTHX_ OP *o)
2512 volatile PERL_SI *cursi = PL_curstackinfo;
2516 assert(CATCH_GET == TRUE);
2520 /* Normally, the leavetry at the end of this block of ops will
2521 * pop an op off the return stack and continue there. By setting
2522 * the op to Nullop, we force an exit from the inner runops()
2525 retop = pop_return();
2526 push_return(Nullop);
2528 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2530 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2536 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2542 /* die caught by an inner eval - continue inner loop */
2543 if (PL_restartop && cursi == PL_curstackinfo) {
2544 PL_op = PL_restartop;
2548 /* a die in this eval - continue in outer loop */
2564 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2565 /* sv Text to convert to OP tree. */
2566 /* startop op_free() this to undo. */
2567 /* code Short string id of the caller. */
2569 dSP; /* Make POPBLOCK work. */
2572 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2576 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2577 char *tmpbuf = tbuf;
2585 /* switch to eval mode */
2587 if (PL_curcop == &PL_compiling) {
2588 SAVECOPSTASH_FREE(&PL_compiling);
2589 CopSTASH_set(&PL_compiling, PL_curstash);
2591 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2592 SV *sv = sv_newmortal();
2593 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2594 code, (unsigned long)++PL_evalseq,
2595 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2599 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2600 SAVECOPFILE_FREE(&PL_compiling);
2601 CopFILE_set(&PL_compiling, tmpbuf+2);
2602 SAVECOPLINE(&PL_compiling);
2603 CopLINE_set(&PL_compiling, 1);
2604 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2605 deleting the eval's FILEGV from the stash before gv_check() runs
2606 (i.e. before run-time proper). To work around the coredump that
2607 ensues, we always turn GvMULTI_on for any globals that were
2608 introduced within evals. See force_ident(). GSAR 96-10-12 */
2609 safestr = savepv(tmpbuf);
2610 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2612 #ifdef OP_IN_REGISTER
2617 PL_hints &= HINT_UTF8;
2619 /* we get here either during compilation, or via pp_regcomp at runtime */
2620 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2622 runcv = find_runcv(NULL);
2625 PL_op->op_type = OP_ENTEREVAL;
2626 PL_op->op_flags = 0; /* Avoid uninit warning. */
2627 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2628 PUSHEVAL(cx, 0, Nullgv);
2631 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2633 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2634 POPBLOCK(cx,PL_curpm);
2637 (*startop)->op_type = OP_NULL;
2638 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2640 /* XXX DAPM do this properly one year */
2641 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2643 if (PL_curcop == &PL_compiling)
2644 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2645 #ifdef OP_IN_REGISTER
2653 =for apidoc find_runcv
2655 Locate the CV corresponding to the currently executing sub or eval.
2656 If db_seqp is non_null, skip CVs that are in the DB package and populate
2657 *db_seqp with the cop sequence number at the point that the DB:: code was
2658 entered. (allows debuggers to eval in the scope of the breakpoint rather
2659 than in in the scope of the debuger itself).
2665 Perl_find_runcv(pTHX_ U32 *db_seqp)
2672 *db_seqp = PL_curcop->cop_seq;
2673 for (si = PL_curstackinfo; si; si = si->si_prev) {
2674 for (ix = si->si_cxix; ix >= 0; ix--) {
2675 cx = &(si->si_cxstack[ix]);
2676 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2677 CV *cv = cx->blk_sub.cv;
2678 /* skip DB:: code */
2679 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2680 *db_seqp = cx->blk_oldcop->cop_seq;
2685 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2693 /* Compile a require/do, an eval '', or a /(?{...})/.
2694 * In the last case, startop is non-null, and contains the address of
2695 * a pointer that should be set to the just-compiled code.
2696 * outside is the lexically enclosing CV (if any) that invoked us.
2699 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2701 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2706 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2707 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2712 SAVESPTR(PL_compcv);
2713 PL_compcv = (CV*)NEWSV(1104,0);
2714 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2715 CvEVAL_on(PL_compcv);
2716 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2717 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2719 CvOUTSIDE_SEQ(PL_compcv) = seq;
2720 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2722 /* set up a scratch pad */
2724 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2727 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2729 /* make sure we compile in the right package */
2731 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2732 SAVESPTR(PL_curstash);
2733 PL_curstash = CopSTASH(PL_curcop);
2735 SAVESPTR(PL_beginav);
2736 PL_beginav = newAV();
2737 SAVEFREESV(PL_beginav);
2738 SAVEI32(PL_error_count);
2740 /* try to compile it */
2742 PL_eval_root = Nullop;
2744 PL_curcop = &PL_compiling;
2745 PL_curcop->cop_arybase = 0;
2746 if (saveop && saveop->op_flags & OPf_SPECIAL)
2747 PL_in_eval |= EVAL_KEEPERR;
2750 if (yyparse() || PL_error_count || !PL_eval_root) {
2754 I32 optype = 0; /* Might be reset by POPEVAL. */
2759 op_free(PL_eval_root);
2760 PL_eval_root = Nullop;
2762 SP = PL_stack_base + POPMARK; /* pop original mark */
2764 POPBLOCK(cx,PL_curpm);
2770 if (optype == OP_REQUIRE) {
2771 char* msg = SvPVx(ERRSV, n_a);
2772 DIE(aTHX_ "%sCompilation failed in require",
2773 *msg ? msg : "Unknown error\n");
2776 char* msg = SvPVx(ERRSV, n_a);
2778 POPBLOCK(cx,PL_curpm);
2780 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2781 (*msg ? msg : "Unknown error\n"));
2784 char* msg = SvPVx(ERRSV, n_a);
2786 sv_setpv(ERRSV, "Compilation error");
2791 CopLINE_set(&PL_compiling, 0);
2793 *startop = PL_eval_root;
2795 SAVEFREEOP(PL_eval_root);
2797 scalarvoid(PL_eval_root);
2798 else if (gimme & G_ARRAY)
2801 scalar(PL_eval_root);
2803 DEBUG_x(dump_eval());
2805 /* Register with debugger: */
2806 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2807 CV *cv = get_cv("DB::postponed", FALSE);
2811 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2813 call_sv((SV*)cv, G_DISCARD);
2817 /* compiled okay, so do it */
2819 CvDEPTH(PL_compcv) = 1;
2820 SP = PL_stack_base + POPMARK; /* pop original mark */
2821 PL_op = saveop; /* The caller may need it. */
2822 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2824 RETURNOP(PL_eval_start);
2828 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2830 STRLEN namelen = strlen(name);
2833 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2834 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2835 char *pmc = SvPV_nolen(pmcsv);
2838 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2839 fp = PerlIO_open(name, mode);
2842 if (PerlLIO_stat(name, &pmstat) < 0 ||
2843 pmstat.st_mtime < pmcstat.st_mtime)
2845 fp = PerlIO_open(pmc, mode);
2848 fp = PerlIO_open(name, mode);
2851 SvREFCNT_dec(pmcsv);
2854 fp = PerlIO_open(name, mode);
2862 register PERL_CONTEXT *cx;
2866 char *tryname = Nullch;
2867 SV *namesv = Nullsv;
2869 I32 gimme = GIMME_V;
2870 PerlIO *tryrsfp = 0;
2872 int filter_has_file = 0;
2873 GV *filter_child_proc = 0;
2874 SV *filter_state = 0;
2881 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2882 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2883 UV rev = 0, ver = 0, sver = 0;
2885 U8 *s = (U8*)SvPVX(sv);
2886 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2888 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2891 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2894 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2897 if (PERL_REVISION < rev
2898 || (PERL_REVISION == rev
2899 && (PERL_VERSION < ver
2900 || (PERL_VERSION == ver
2901 && PERL_SUBVERSION < sver))))
2903 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2904 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2905 PERL_VERSION, PERL_SUBVERSION);
2907 if (ckWARN(WARN_PORTABLE))
2908 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2909 "v-string in use/require non-portable");
2912 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2913 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2914 + ((NV)PERL_SUBVERSION/(NV)1000000)
2915 + 0.00000099 < SvNV(sv))
2919 NV nver = (nrev - rev) * 1000;
2920 UV ver = (UV)(nver + 0.0009);
2921 NV nsver = (nver - ver) * 1000;
2922 UV sver = (UV)(nsver + 0.0009);
2924 /* help out with the "use 5.6" confusion */
2925 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2926 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2927 " (did you mean v%"UVuf".%03"UVuf"?)--"
2928 "this is only v%d.%d.%d, stopped",
2929 rev, ver, sver, rev, ver/100,
2930 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2933 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2934 "this is only v%d.%d.%d, stopped",
2935 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2942 name = SvPV(sv, len);
2943 if (!(name && len > 0 && *name))
2944 DIE(aTHX_ "Null filename used");
2945 TAINT_PROPER("require");
2946 if (PL_op->op_type == OP_REQUIRE &&
2947 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2948 *svp != &PL_sv_undef)
2951 /* prepare to compile file */
2953 if (path_is_absolute(name)) {
2955 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2957 #ifdef MACOS_TRADITIONAL
2961 MacPerl_CanonDir(name, newname, 1);
2962 if (path_is_absolute(newname)) {
2964 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2969 AV *ar = GvAVn(PL_incgv);
2973 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2976 namesv = NEWSV(806, 0);
2977 for (i = 0; i <= AvFILL(ar); i++) {
2978 SV *dirsv = *av_fetch(ar, i, TRUE);
2984 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2985 && !sv_isobject(loader))
2987 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2990 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2991 PTR2UV(SvRV(dirsv)), name);
2992 tryname = SvPVX(namesv);
3003 if (sv_isobject(loader))
3004 count = call_method("INC", G_ARRAY);
3006 count = call_sv(loader, G_ARRAY);
3016 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3020 if (SvTYPE(arg) == SVt_PVGV) {
3021 IO *io = GvIO((GV *)arg);
3026 tryrsfp = IoIFP(io);
3027 if (IoTYPE(io) == IoTYPE_PIPE) {
3028 /* reading from a child process doesn't
3029 nest -- when returning from reading
3030 the inner module, the outer one is
3031 unreadable (closed?) I've tried to
3032 save the gv to manage the lifespan of
3033 the pipe, but this didn't help. XXX */
3034 filter_child_proc = (GV *)arg;
3035 (void)SvREFCNT_inc(filter_child_proc);
3038 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3039 PerlIO_close(IoOFP(io));
3051 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3053 (void)SvREFCNT_inc(filter_sub);
3056 filter_state = SP[i];
3057 (void)SvREFCNT_inc(filter_state);
3061 tryrsfp = PerlIO_open("/dev/null",
3076 filter_has_file = 0;
3077 if (filter_child_proc) {
3078 SvREFCNT_dec(filter_child_proc);
3079 filter_child_proc = 0;
3082 SvREFCNT_dec(filter_state);
3086 SvREFCNT_dec(filter_sub);
3091 if (!path_is_absolute(name)
3092 #ifdef MACOS_TRADITIONAL
3093 /* We consider paths of the form :a:b ambiguous and interpret them first
3094 as global then as local
3096 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3099 char *dir = SvPVx(dirsv, n_a);
3100 #ifdef MACOS_TRADITIONAL
3104 MacPerl_CanonDir(name, buf2, 1);
3105 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3109 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3111 sv_setpv(namesv, unixdir);
3112 sv_catpv(namesv, unixname);
3114 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3117 TAINT_PROPER("require");
3118 tryname = SvPVX(namesv);
3119 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3121 if (tryname[0] == '.' && tryname[1] == '/')
3130 SAVECOPFILE_FREE(&PL_compiling);
3131 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3132 SvREFCNT_dec(namesv);
3134 if (PL_op->op_type == OP_REQUIRE) {
3135 char *msgstr = name;
3136 if (namesv) { /* did we lookup @INC? */
3137 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3138 SV *dirmsgsv = NEWSV(0, 0);
3139 AV *ar = GvAVn(PL_incgv);
3141 sv_catpvn(msg, " in @INC", 8);
3142 if (instr(SvPVX(msg), ".h "))
3143 sv_catpv(msg, " (change .h to .ph maybe?)");
3144 if (instr(SvPVX(msg), ".ph "))
3145 sv_catpv(msg, " (did you run h2ph?)");
3146 sv_catpv(msg, " (@INC contains:");
3147 for (i = 0; i <= AvFILL(ar); i++) {
3148 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3149 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3150 sv_catsv(msg, dirmsgsv);
3152 sv_catpvn(msg, ")", 1);
3153 SvREFCNT_dec(dirmsgsv);
3154 msgstr = SvPV_nolen(msg);
3156 DIE(aTHX_ "Can't locate %s", msgstr);
3162 SETERRNO(0, SS_NORMAL);
3164 /* Assume success here to prevent recursive requirement. */
3166 /* Check whether a hook in @INC has already filled %INC */
3167 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3168 (void)hv_store(GvHVn(PL_incgv), name, len,
3169 (hook_sv ? SvREFCNT_inc(hook_sv)
3170 : newSVpv(CopFILE(&PL_compiling), 0)),
3176 lex_start(sv_2mortal(newSVpvn("",0)));
3177 SAVEGENERICSV(PL_rsfp_filters);
3178 PL_rsfp_filters = Nullav;
3183 SAVESPTR(PL_compiling.cop_warnings);
3184 if (PL_dowarn & G_WARN_ALL_ON)
3185 PL_compiling.cop_warnings = pWARN_ALL ;
3186 else if (PL_dowarn & G_WARN_ALL_OFF)
3187 PL_compiling.cop_warnings = pWARN_NONE ;
3188 else if (PL_taint_warn)
3189 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3191 PL_compiling.cop_warnings = pWARN_STD ;
3192 SAVESPTR(PL_compiling.cop_io);
3193 PL_compiling.cop_io = Nullsv;
3195 if (filter_sub || filter_child_proc) {
3196 SV *datasv = filter_add(run_user_filter, Nullsv);
3197 IoLINES(datasv) = filter_has_file;
3198 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3199 IoTOP_GV(datasv) = (GV *)filter_state;
3200 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3203 /* switch to eval mode */
3204 push_return(PL_op->op_next);
3205 PUSHBLOCK(cx, CXt_EVAL, SP);
3206 PUSHEVAL(cx, name, Nullgv);
3208 SAVECOPLINE(&PL_compiling);
3209 CopLINE_set(&PL_compiling, 0);
3213 /* Store and reset encoding. */
3214 encoding = PL_encoding;
3215 PL_encoding = Nullsv;
3217 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3219 /* Restore encoding. */
3220 PL_encoding = encoding;
3227 return pp_require();
3233 register PERL_CONTEXT *cx;
3235 I32 gimme = GIMME_V, was = PL_sub_generation;
3236 char tbuf[TYPE_DIGITS(long) + 12];
3237 char *tmpbuf = tbuf;
3246 TAINT_PROPER("eval");
3252 /* switch to eval mode */
3254 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3255 SV *sv = sv_newmortal();
3256 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3257 (unsigned long)++PL_evalseq,
3258 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3262 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3263 SAVECOPFILE_FREE(&PL_compiling);
3264 CopFILE_set(&PL_compiling, tmpbuf+2);
3265 SAVECOPLINE(&PL_compiling);
3266 CopLINE_set(&PL_compiling, 1);
3267 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3268 deleting the eval's FILEGV from the stash before gv_check() runs
3269 (i.e. before run-time proper). To work around the coredump that
3270 ensues, we always turn GvMULTI_on for any globals that were
3271 introduced within evals. See force_ident(). GSAR 96-10-12 */
3272 safestr = savepv(tmpbuf);
3273 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3275 PL_hints = PL_op->op_targ;
3276 SAVESPTR(PL_compiling.cop_warnings);
3277 if (specialWARN(PL_curcop->cop_warnings))
3278 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3280 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3281 SAVEFREESV(PL_compiling.cop_warnings);
3283 SAVESPTR(PL_compiling.cop_io);
3284 if (specialCopIO(PL_curcop->cop_io))
3285 PL_compiling.cop_io = PL_curcop->cop_io;
3287 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3288 SAVEFREESV(PL_compiling.cop_io);
3290 /* special case: an eval '' executed within the DB package gets lexically
3291 * placed in the first non-DB CV rather than the current CV - this
3292 * allows the debugger to execute code, find lexicals etc, in the
3293 * scope of the code being debugged. Passing &seq gets find_runcv
3294 * to do the dirty work for us */
3295 runcv = find_runcv(&seq);
3297 push_return(PL_op->op_next);
3298 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3299 PUSHEVAL(cx, 0, Nullgv);
3301 /* prepare to compile string */
3303 if (PERLDB_LINE && PL_curstash != PL_debstash)
3304 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3306 ret = doeval(gimme, NULL, runcv, seq);
3307 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3308 && ret != PL_op->op_next) { /* Successive compilation. */
3309 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3311 return DOCATCH(ret);
3321 register PERL_CONTEXT *cx;
3323 U8 save_flags = PL_op -> op_flags;
3328 retop = pop_return();
3331 if (gimme == G_VOID)
3333 else if (gimme == G_SCALAR) {
3336 if (SvFLAGS(TOPs) & SVs_TEMP)
3339 *MARK = sv_mortalcopy(TOPs);
3343 *MARK = &PL_sv_undef;
3348 /* in case LEAVE wipes old return values */
3349 for (mark = newsp + 1; mark <= SP; mark++) {
3350 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3351 *mark = sv_mortalcopy(*mark);
3352 TAINT_NOT; /* Each item is independent */
3356 PL_curpm = newpm; /* Don't pop $1 et al till now */
3359 assert(CvDEPTH(PL_compcv) == 1);
3361 CvDEPTH(PL_compcv) = 0;
3364 if (optype == OP_REQUIRE &&
3365 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3367 /* Unassume the success we assumed earlier. */
3368 SV *nsv = cx->blk_eval.old_namesv;
3369 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3370 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3371 /* die_where() did LEAVE, or we won't be here */
3375 if (!(save_flags & OPf_SPECIAL))
3385 register PERL_CONTEXT *cx;
3386 I32 gimme = GIMME_V;
3391 push_return(cLOGOP->op_other->op_next);
3392 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3395 PL_in_eval = EVAL_INEVAL;
3398 return DOCATCH(PL_op->op_next);
3409 register PERL_CONTEXT *cx;
3414 retop = pop_return();
3417 if (gimme == G_VOID)
3419 else if (gimme == G_SCALAR) {
3422 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3425 *MARK = sv_mortalcopy(TOPs);
3429 *MARK = &PL_sv_undef;
3434 /* in case LEAVE wipes old return values */
3435 for (mark = newsp + 1; mark <= SP; mark++) {
3436 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3437 *mark = sv_mortalcopy(*mark);
3438 TAINT_NOT; /* Each item is independent */
3442 PL_curpm = newpm; /* Don't pop $1 et al till now */
3450 S_doparseform(pTHX_ SV *sv)
3453 register char *s = SvPV_force(sv, len);
3454 register char *send = s + len;
3455 register char *base = Nullch;
3456 register I32 skipspaces = 0;
3457 bool noblank = FALSE;
3458 bool repeat = FALSE;
3459 bool postspace = FALSE;
3467 Perl_croak(aTHX_ "Null picture in formline");
3469 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3474 *fpc++ = FF_LINEMARK;
3475 noblank = repeat = FALSE;
3493 case ' ': case '\t':
3504 *fpc++ = FF_LITERAL;
3512 *fpc++ = (U16)skipspaces;
3516 *fpc++ = FF_NEWLINE;
3520 arg = fpc - linepc + 1;
3527 *fpc++ = FF_LINEMARK;
3528 noblank = repeat = FALSE;
3537 ischop = s[-1] == '^';
3543 arg = (s - base) - 1;
3545 *fpc++ = FF_LITERAL;
3554 *fpc++ = FF_LINEGLOB;
3556 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3557 arg = ischop ? 512 : 0;
3567 arg |= 256 + (s - f);
3569 *fpc++ = s - base; /* fieldsize for FETCH */
3570 *fpc++ = FF_DECIMAL;
3573 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3574 arg = ischop ? 512 : 0;
3576 s++; /* skip the '0' first */
3585 arg |= 256 + (s - f);
3587 *fpc++ = s - base; /* fieldsize for FETCH */
3588 *fpc++ = FF_0DECIMAL;
3593 bool ismore = FALSE;
3596 while (*++s == '>') ;
3597 prespace = FF_SPACE;
3599 else if (*s == '|') {
3600 while (*++s == '|') ;
3601 prespace = FF_HALFSPACE;
3606 while (*++s == '<') ;
3609 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3613 *fpc++ = s - base; /* fieldsize for FETCH */
3615 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3618 *fpc++ = (U16)prespace;
3633 { /* need to jump to the next word */
3635 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3636 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3637 s = SvPVX(sv) + SvCUR(sv) + z;
3639 Copy(fops, s, arg, U16);
3641 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3646 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3648 SV *datasv = FILTER_DATA(idx);
3649 int filter_has_file = IoLINES(datasv);
3650 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3651 SV *filter_state = (SV *)IoTOP_GV(datasv);
3652 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3655 /* I was having segfault trouble under Linux 2.2.5 after a
3656 parse error occured. (Had to hack around it with a test
3657 for PL_error_count == 0.) Solaris doesn't segfault --
3658 not sure where the trouble is yet. XXX */
3660 if (filter_has_file) {
3661 len = FILTER_READ(idx+1, buf_sv, maxlen);
3664 if (filter_sub && len >= 0) {
3675 PUSHs(sv_2mortal(newSViv(maxlen)));
3677 PUSHs(filter_state);
3680 count = call_sv(filter_sub, G_SCALAR);
3696 IoLINES(datasv) = 0;
3697 if (filter_child_proc) {
3698 SvREFCNT_dec(filter_child_proc);
3699 IoFMT_GV(datasv) = Nullgv;
3702 SvREFCNT_dec(filter_state);
3703 IoTOP_GV(datasv) = Nullgv;
3706 SvREFCNT_dec(filter_sub);
3707 IoBOTTOM_GV(datasv) = Nullgv;
3709 filter_del(run_user_filter);
3715 /* perhaps someone can come up with a better name for
3716 this? it is not really "absolute", per se ... */
3718 S_path_is_absolute(pTHX_ char *name)
3720 if (PERL_FILE_IS_ABSOLUTE(name)
3721 #ifdef MACOS_TRADITIONAL
3724 || (*name == '.' && (name[1] == '/' ||
3725 (name[1] == '.' && name[2] == '/'))))