3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
21 #define PERL_IN_PP_CTL_C
25 #define WORD_ALIGN sizeof(U32)
28 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
30 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
38 cxix = dopoptosub(cxstack_ix);
42 switch (cxstack[cxix].blk_gimme) {
59 /* XXXX Should store the old value to allow for tie/overload - and
60 restore in regcomp, where marked with XXXX. */
69 register PMOP *pm = (PMOP*)cLOGOP->op_other;
73 MAGIC *mg = Null(MAGIC*);
77 /* prevent recompiling under /o and ithreads. */
78 #if defined(USE_ITHREADS)
79 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
84 SV *sv = SvRV(tmpstr);
86 mg = mg_find(sv, PERL_MAGIC_qr);
89 regexp *re = (regexp *)mg->mg_obj;
90 ReREFCNT_dec(PM_GETRE(pm));
91 PM_SETRE(pm, ReREFCNT_inc(re));
94 t = SvPV(tmpstr, len);
96 /* Check against the last compiled regexp. */
97 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
98 PM_GETRE(pm)->prelen != (I32)len ||
99 memNE(PM_GETRE(pm)->precomp, t, len))
102 ReREFCNT_dec(PM_GETRE(pm));
103 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
105 if (PL_op->op_flags & OPf_SPECIAL)
106 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
108 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
110 pm->op_pmdynflags |= PMdf_DYN_UTF8;
112 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
113 if (pm->op_pmdynflags & PMdf_UTF8)
114 t = (char*)bytes_to_utf8((U8*)t, &len);
116 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
117 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
119 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
120 inside tie/overload accessors. */
124 #ifndef INCOMPLETE_TAINTS
127 pm->op_pmdynflags |= PMdf_TAINTED;
129 pm->op_pmdynflags &= ~PMdf_TAINTED;
133 if (!PM_GETRE(pm)->prelen && PL_curpm)
135 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
136 pm->op_pmflags |= PMf_WHITE;
138 pm->op_pmflags &= ~PMf_WHITE;
140 /* XXX runtime compiled output needs to move to the pad */
141 if (pm->op_pmflags & PMf_KEEP) {
142 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
143 #if !defined(USE_ITHREADS)
144 /* XXX can't change the optree at runtime either */
145 cLOGOP->op_first->op_next = PL_op->op_next;
154 register PMOP *pm = (PMOP*) cLOGOP->op_other;
155 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
156 register SV *dstr = cx->sb_dstr;
157 register char *s = cx->sb_s;
158 register char *m = cx->sb_m;
159 char *orig = cx->sb_orig;
160 register REGEXP *rx = cx->sb_rx;
162 REGEXP *old = PM_GETRE(pm);
169 rxres_restore(&cx->sb_rxres, rx);
170 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
172 if (cx->sb_iters++) {
173 I32 saviters = cx->sb_iters;
174 if (cx->sb_iters > cx->sb_maxiters)
175 DIE(aTHX_ "Substitution loop");
177 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
178 cx->sb_rxtainted |= 2;
179 sv_catsv(dstr, POPs);
182 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
183 s == m, cx->sb_targ, NULL,
184 ((cx->sb_rflags & REXEC_COPY_STR)
185 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
186 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
188 SV *targ = cx->sb_targ;
190 if (DO_UTF8(dstr) && !SvUTF8(targ))
191 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
193 sv_catpvn(dstr, s, cx->sb_strend - s);
194 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
196 #ifdef PERL_COPY_ON_WRITE
198 sv_force_normal_flags(targ, SV_COW_DROP_PV);
202 (void)SvOOK_off(targ);
204 Safefree(SvPVX(targ));
206 SvPVX(targ) = SvPVX(dstr);
207 SvCUR_set(targ, SvCUR(dstr));
208 SvLEN_set(targ, SvLEN(dstr));
214 TAINT_IF(cx->sb_rxtainted & 1);
215 PUSHs(sv_2mortal(newSViv(saviters - 1)));
217 (void)SvPOK_only_UTF8(targ);
218 TAINT_IF(cx->sb_rxtainted);
222 LEAVE_SCOPE(cx->sb_oldsave);
225 RETURNOP(pm->op_next);
227 cx->sb_iters = saviters;
229 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
232 cx->sb_orig = orig = rx->subbeg;
234 cx->sb_strend = s + (cx->sb_strend - m);
236 cx->sb_m = m = rx->startp[0] + orig;
238 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
239 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
241 sv_catpvn(dstr, s, m-s);
243 cx->sb_s = rx->endp[0] + orig;
244 { /* Update the pos() information. */
245 SV *sv = cx->sb_targ;
248 if (SvTYPE(sv) < SVt_PVMG)
249 (void)SvUPGRADE(sv, SVt_PVMG);
250 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
251 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
252 mg = mg_find(sv, PERL_MAGIC_regex_global);
261 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
262 rxres_save(&cx->sb_rxres, rx);
263 RETURNOP(pm->op_pmreplstart);
267 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
272 if (!p || p[1] < rx->nparens) {
273 #ifdef PERL_COPY_ON_WRITE
274 i = 7 + rx->nparens * 2;
276 i = 6 + rx->nparens * 2;
285 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
286 RX_MATCH_COPIED_off(rx);
288 #ifdef PERL_COPY_ON_WRITE
289 *p++ = PTR2UV(rx->saved_copy);
290 rx->saved_copy = Nullsv;
295 *p++ = PTR2UV(rx->subbeg);
296 *p++ = (UV)rx->sublen;
297 for (i = 0; i <= rx->nparens; ++i) {
298 *p++ = (UV)rx->startp[i];
299 *p++ = (UV)rx->endp[i];
304 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
309 RX_MATCH_COPY_FREE(rx);
310 RX_MATCH_COPIED_set(rx, *p);
313 #ifdef PERL_COPY_ON_WRITE
315 SvREFCNT_dec (rx->saved_copy);
316 rx->saved_copy = INT2PTR(SV*,*p);
322 rx->subbeg = INT2PTR(char*,*p++);
323 rx->sublen = (I32)(*p++);
324 for (i = 0; i <= rx->nparens; ++i) {
325 rx->startp[i] = (I32)(*p++);
326 rx->endp[i] = (I32)(*p++);
331 Perl_rxres_free(pTHX_ void **rsp)
336 Safefree(INT2PTR(char*,*p));
337 #ifdef PERL_COPY_ON_WRITE
339 SvREFCNT_dec (INT2PTR(SV*,p[1]));
349 dSP; dMARK; dORIGMARK;
350 register SV *tmpForm = *++MARK;
357 register SV *sv = Nullsv;
362 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
363 char *chophere = Nullch;
364 char *linemark = Nullch;
366 bool gotsome = FALSE;
368 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
369 bool item_is_utf8 = FALSE;
370 bool targ_is_utf8 = FALSE;
376 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
377 if (SvREADONLY(tmpForm)) {
378 SvREADONLY_off(tmpForm);
379 parseres = doparseform(tmpForm);
380 SvREADONLY_on(tmpForm);
383 parseres = doparseform(tmpForm);
387 SvPV_force(PL_formtarget, len);
388 if (DO_UTF8(PL_formtarget))
390 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
392 f = SvPV(tmpForm, len);
393 /* need to jump to the next word */
394 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
403 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
404 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
405 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
406 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
407 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
409 case FF_CHECKNL: name = "CHECKNL"; break;
410 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
411 case FF_SPACE: name = "SPACE"; break;
412 case FF_HALFSPACE: name = "HALFSPACE"; break;
413 case FF_ITEM: name = "ITEM"; break;
414 case FF_CHOP: name = "CHOP"; break;
415 case FF_LINEGLOB: name = "LINEGLOB"; break;
416 case FF_NEWLINE: name = "NEWLINE"; break;
417 case FF_MORE: name = "MORE"; break;
418 case FF_LINEMARK: name = "LINEMARK"; break;
419 case FF_END: name = "END"; break;
420 case FF_0DECIMAL: name = "0DECIMAL"; break;
421 case FF_LINESNGL: name = "LINESNGL"; break;
424 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
426 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
437 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
438 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
440 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
441 t = SvEND(PL_formtarget);
444 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
445 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
447 sv_utf8_upgrade(PL_formtarget);
448 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
449 t = SvEND(PL_formtarget);
469 if (ckWARN(WARN_SYNTAX))
470 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
475 item = s = SvPV(sv, len);
478 itemsize = sv_len_utf8(sv);
479 if (itemsize != (I32)len) {
481 if (itemsize > fieldsize) {
482 itemsize = fieldsize;
483 itembytes = itemsize;
484 sv_pos_u2b(sv, &itembytes, 0);
488 send = chophere = s + itembytes;
498 sv_pos_b2u(sv, &itemsize);
502 item_is_utf8 = FALSE;
503 if (itemsize > fieldsize)
504 itemsize = fieldsize;
505 send = chophere = s + itemsize;
517 item = s = SvPV(sv, len);
520 itemsize = sv_len_utf8(sv);
521 if (itemsize != (I32)len) {
523 if (itemsize <= fieldsize) {
524 send = chophere = s + itemsize;
536 itemsize = fieldsize;
537 itembytes = itemsize;
538 sv_pos_u2b(sv, &itembytes, 0);
539 send = chophere = s + itembytes;
540 while (s < send || (s == send && isSPACE(*s))) {
550 if (strchr(PL_chopset, *s))
555 itemsize = chophere - item;
556 sv_pos_b2u(sv, &itemsize);
562 item_is_utf8 = FALSE;
563 if (itemsize <= fieldsize) {
564 send = chophere = s + itemsize;
576 itemsize = fieldsize;
577 send = chophere = s + itemsize;
578 while (s < send || (s == send && isSPACE(*s))) {
588 if (strchr(PL_chopset, *s))
593 itemsize = chophere - item;
598 arg = fieldsize - itemsize;
607 arg = fieldsize - itemsize;
621 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
623 sv_utf8_upgrade(PL_formtarget);
624 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
625 t = SvEND(PL_formtarget);
629 if (UTF8_IS_CONTINUED(*s)) {
630 STRLEN skip = UTF8SKIP(s);
647 if ( !((*t++ = *s++) & ~31) )
653 if (targ_is_utf8 && !item_is_utf8) {
654 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
656 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
657 for (; t < SvEND(PL_formtarget); t++) {
670 int ch = *t++ = *s++;
673 if ( !((*t++ = *s++) & ~31) )
682 while (*s && isSPACE(*s))
696 item = s = SvPV(sv, len);
698 if ((item_is_utf8 = DO_UTF8(sv)))
699 itemsize = sv_len_utf8(sv);
701 bool chopped = FALSE;
704 chophere = s + itemsize;
720 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
722 SvUTF8_on(PL_formtarget);
724 SvCUR_set(sv, chophere - item);
725 sv_catsv(PL_formtarget, sv);
726 SvCUR_set(sv, itemsize);
728 sv_catsv(PL_formtarget, sv);
730 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
731 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
732 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
740 #if defined(USE_LONG_DOUBLE)
741 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
743 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
748 #if defined(USE_LONG_DOUBLE)
749 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
751 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
754 /* If the field is marked with ^ and the value is undefined,
756 if ((arg & 512) && !SvOK(sv)) {
764 /* overflow evidence */
765 if (num_overflow(value, fieldsize, arg)) {
771 /* Formats aren't yet marked for locales, so assume "yes". */
773 STORE_NUMERIC_STANDARD_SET_LOCAL();
774 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
775 RESTORE_NUMERIC_STANDARD();
782 while (t-- > linemark && *t == ' ') ;
790 if (arg) { /* repeat until fields exhausted? */
792 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
793 lines += FmLINES(PL_formtarget);
796 if (strnEQ(linemark, linemark - arg, arg))
797 DIE(aTHX_ "Runaway format");
800 SvUTF8_on(PL_formtarget);
801 FmLINES(PL_formtarget) = lines;
803 RETURNOP(cLISTOP->op_first);
816 while (*s && isSPACE(*s) && s < send)
820 arg = fieldsize - itemsize;
827 if (strnEQ(s," ",3)) {
828 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
839 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
841 SvUTF8_on(PL_formtarget);
842 FmLINES(PL_formtarget) += lines;
854 if (PL_stack_base + *PL_markstack_ptr == SP) {
856 if (GIMME_V == G_SCALAR)
857 XPUSHs(sv_2mortal(newSViv(0)));
858 RETURNOP(PL_op->op_next->op_next);
860 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
861 pp_pushmark(); /* push dst */
862 pp_pushmark(); /* push src */
863 ENTER; /* enter outer scope */
866 if (PL_op->op_private & OPpGREP_LEX)
867 SAVESPTR(PAD_SVl(PL_op->op_targ));
870 ENTER; /* enter inner scope */
873 src = PL_stack_base[*PL_markstack_ptr];
875 if (PL_op->op_private & OPpGREP_LEX)
876 PAD_SVl(PL_op->op_targ) = src;
881 if (PL_op->op_type == OP_MAPSTART)
882 pp_pushmark(); /* push top */
883 return ((LOGOP*)PL_op->op_next)->op_other;
888 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
895 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
901 /* first, move source pointer to the next item in the source list */
902 ++PL_markstack_ptr[-1];
904 /* if there are new items, push them into the destination list */
905 if (items && gimme != G_VOID) {
906 /* might need to make room back there first */
907 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
908 /* XXX this implementation is very pessimal because the stack
909 * is repeatedly extended for every set of items. Is possible
910 * to do this without any stack extension or copying at all
911 * by maintaining a separate list over which the map iterates
912 * (like foreach does). --gsar */
914 /* everything in the stack after the destination list moves
915 * towards the end the stack by the amount of room needed */
916 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
918 /* items to shift up (accounting for the moved source pointer) */
919 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
921 /* This optimization is by Ben Tilly and it does
922 * things differently from what Sarathy (gsar)
923 * is describing. The downside of this optimization is
924 * that leaves "holes" (uninitialized and hopefully unused areas)
925 * to the Perl stack, but on the other hand this
926 * shouldn't be a problem. If Sarathy's idea gets
927 * implemented, this optimization should become
928 * irrelevant. --jhi */
930 shift = count; /* Avoid shifting too often --Ben Tilly */
935 PL_markstack_ptr[-1] += shift;
936 *PL_markstack_ptr += shift;
940 /* copy the new items down to the destination list */
941 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
942 if (gimme == G_ARRAY) {
944 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
947 /* scalar context: we don't care about which values map returns
948 * (we use undef here). And so we certainly don't want to do mortal
949 * copies of meaningless values. */
950 while (items-- > 0) {
952 *dst-- = &PL_sv_undef;
956 LEAVE; /* exit inner scope */
959 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
961 (void)POPMARK; /* pop top */
962 LEAVE; /* exit outer scope */
963 (void)POPMARK; /* pop src */
964 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
965 (void)POPMARK; /* pop dst */
966 SP = PL_stack_base + POPMARK; /* pop original mark */
967 if (gimme == G_SCALAR) {
968 if (PL_op->op_private & OPpGREP_LEX) {
969 SV* sv = sv_newmortal();
978 else if (gimme == G_ARRAY)
985 ENTER; /* enter inner scope */
988 /* set $_ to the new source item */
989 src = PL_stack_base[PL_markstack_ptr[-1]];
991 if (PL_op->op_private & OPpGREP_LEX)
992 PAD_SVl(PL_op->op_targ) = src;
996 RETURNOP(cLOGOP->op_other);
1004 if (GIMME == G_ARRAY)
1006 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1007 return cLOGOP->op_other;
1016 if (GIMME == G_ARRAY) {
1017 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1021 SV *targ = PAD_SV(PL_op->op_targ);
1024 if (PL_op->op_private & OPpFLIP_LINENUM) {
1025 if (GvIO(PL_last_in_gv)) {
1026 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1029 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1030 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1036 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1037 if (PL_op->op_flags & OPf_SPECIAL) {
1045 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1054 /* This code tries to decide if "$left .. $right" should use the
1055 magical string increment, or if the range is numeric (we make
1056 an exception for .."0" [#18165]). AMS 20021031. */
1058 #define RANGE_IS_NUMERIC(left,right) ( \
1059 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1060 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1061 (((!SvOK(left) && SvOK(right)) || (looks_like_number(left) && \
1062 SvPOKp(left) && *SvPVX(left) != '0')) && looks_like_number(right)))
1068 if (GIMME == G_ARRAY) {
1074 if (SvGMAGICAL(left))
1076 if (SvGMAGICAL(right))
1079 if (RANGE_IS_NUMERIC(left,right)) {
1080 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1081 DIE(aTHX_ "Range iterator outside integer range");
1092 sv = sv_2mortal(newSViv(i++));
1097 SV *final = sv_mortalcopy(right);
1099 char *tmps = SvPV(final, len);
1101 sv = sv_mortalcopy(left);
1103 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1105 if (strEQ(SvPVX(sv),tmps))
1107 sv = sv_2mortal(newSVsv(sv));
1114 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1118 if (PL_op->op_private & OPpFLIP_LINENUM) {
1119 if (GvIO(PL_last_in_gv)) {
1120 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1123 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1124 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1132 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1133 sv_catpv(targ, "E0");
1143 static char *context_name[] = {
1154 S_dopoptolabel(pTHX_ char *label)
1157 register PERL_CONTEXT *cx;
1159 for (i = cxstack_ix; i >= 0; i--) {
1161 switch (CxTYPE(cx)) {
1167 if (ckWARN(WARN_EXITING))
1168 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1169 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1170 if (CxTYPE(cx) == CXt_NULL)
1174 if (!cx->blk_loop.label ||
1175 strNE(label, cx->blk_loop.label) ) {
1176 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1177 (long)i, cx->blk_loop.label));
1180 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1188 Perl_dowantarray(pTHX)
1190 I32 gimme = block_gimme();
1191 return (gimme == G_VOID) ? G_SCALAR : gimme;
1195 Perl_block_gimme(pTHX)
1199 cxix = dopoptosub(cxstack_ix);
1203 switch (cxstack[cxix].blk_gimme) {
1211 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1218 Perl_is_lvalue_sub(pTHX)
1222 cxix = dopoptosub(cxstack_ix);
1223 assert(cxix >= 0); /* We should only be called from inside subs */
1225 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1226 return cxstack[cxix].blk_sub.lval;
1232 S_dopoptosub(pTHX_ I32 startingblock)
1234 return dopoptosub_at(cxstack, startingblock);
1238 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1241 register PERL_CONTEXT *cx;
1242 for (i = startingblock; i >= 0; i--) {
1244 switch (CxTYPE(cx)) {
1250 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1258 S_dopoptoeval(pTHX_ I32 startingblock)
1261 register PERL_CONTEXT *cx;
1262 for (i = startingblock; i >= 0; i--) {
1264 switch (CxTYPE(cx)) {
1268 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1276 S_dopoptoloop(pTHX_ I32 startingblock)
1279 register PERL_CONTEXT *cx;
1280 for (i = startingblock; i >= 0; i--) {
1282 switch (CxTYPE(cx)) {
1288 if (ckWARN(WARN_EXITING))
1289 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1290 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1291 if ((CxTYPE(cx)) == CXt_NULL)
1295 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1303 Perl_dounwind(pTHX_ I32 cxix)
1305 register PERL_CONTEXT *cx;
1308 while (cxstack_ix > cxix) {
1310 cx = &cxstack[cxstack_ix];
1311 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1312 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1313 /* Note: we don't need to restore the base context info till the end. */
1314 switch (CxTYPE(cx)) {
1317 continue; /* not break */
1339 Perl_qerror(pTHX_ SV *err)
1342 sv_catsv(ERRSV, err);
1344 sv_catsv(PL_errors, err);
1346 Perl_warn(aTHX_ "%"SVf, err);
1351 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1357 register PERL_CONTEXT *cx;
1362 if (PL_in_eval & EVAL_KEEPERR) {
1363 static char prefix[] = "\t(in cleanup) ";
1368 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1371 if (*e != *message || strNE(e,message))
1375 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1376 sv_catpvn(err, prefix, sizeof(prefix)-1);
1377 sv_catpvn(err, message, msglen);
1378 if (ckWARN(WARN_MISC)) {
1379 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1380 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1385 sv_setpvn(ERRSV, message, msglen);
1389 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1390 && PL_curstackinfo->si_prev)
1399 if (cxix < cxstack_ix)
1402 POPBLOCK(cx,PL_curpm);
1403 if (CxTYPE(cx) != CXt_EVAL) {
1405 message = SvPVx(ERRSV, msglen);
1406 PerlIO_write(Perl_error_log, "panic: die ", 11);
1407 PerlIO_write(Perl_error_log, message, msglen);
1412 if (gimme == G_SCALAR)
1413 *++newsp = &PL_sv_undef;
1414 PL_stack_sp = newsp;
1418 /* LEAVE could clobber PL_curcop (see save_re_context())
1419 * XXX it might be better to find a way to avoid messing with
1420 * PL_curcop in save_re_context() instead, but this is a more
1421 * minimal fix --GSAR */
1422 PL_curcop = cx->blk_oldcop;
1424 if (optype == OP_REQUIRE) {
1425 char* msg = SvPVx(ERRSV, n_a);
1426 SV *nsv = cx->blk_eval.old_namesv;
1427 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1429 DIE(aTHX_ "%sCompilation failed in require",
1430 *msg ? msg : "Unknown error\n");
1432 return pop_return();
1436 message = SvPVx(ERRSV, msglen);
1438 write_to_stderr(message, msglen);
1447 if (SvTRUE(left) != SvTRUE(right))
1459 RETURNOP(cLOGOP->op_other);
1468 RETURNOP(cLOGOP->op_other);
1477 if (!sv || !SvANY(sv)) {
1478 RETURNOP(cLOGOP->op_other);
1481 switch (SvTYPE(sv)) {
1483 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1487 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1491 if (CvROOT(sv) || CvXSUB(sv))
1501 RETURNOP(cLOGOP->op_other);
1507 register I32 cxix = dopoptosub(cxstack_ix);
1508 register PERL_CONTEXT *cx;
1509 register PERL_CONTEXT *ccstack = cxstack;
1510 PERL_SI *top_si = PL_curstackinfo;
1521 /* we may be in a higher stacklevel, so dig down deeper */
1522 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1523 top_si = top_si->si_prev;
1524 ccstack = top_si->si_cxstack;
1525 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1528 if (GIMME != G_ARRAY) {
1534 if (PL_DBsub && cxix >= 0 &&
1535 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1539 cxix = dopoptosub_at(ccstack, cxix - 1);
1542 cx = &ccstack[cxix];
1543 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1544 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1545 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1546 field below is defined for any cx. */
1547 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1548 cx = &ccstack[dbcxix];
1551 stashname = CopSTASHPV(cx->blk_oldcop);
1552 if (GIMME != G_ARRAY) {
1555 PUSHs(&PL_sv_undef);
1558 sv_setpv(TARG, stashname);
1567 PUSHs(&PL_sv_undef);
1569 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1570 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1571 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1574 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1575 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1576 /* So is ccstack[dbcxix]. */
1579 gv_efullname3(sv, cvgv, Nullch);
1580 PUSHs(sv_2mortal(sv));
1581 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1584 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1585 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1589 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1590 PUSHs(sv_2mortal(newSViv(0)));
1592 gimme = (I32)cx->blk_gimme;
1593 if (gimme == G_VOID)
1594 PUSHs(&PL_sv_undef);
1596 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1597 if (CxTYPE(cx) == CXt_EVAL) {
1599 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1600 PUSHs(cx->blk_eval.cur_text);
1604 else if (cx->blk_eval.old_namesv) {
1605 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1608 /* eval BLOCK (try blocks have old_namesv == 0) */
1610 PUSHs(&PL_sv_undef);
1611 PUSHs(&PL_sv_undef);
1615 PUSHs(&PL_sv_undef);
1616 PUSHs(&PL_sv_undef);
1618 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1619 && CopSTASH_eq(PL_curcop, PL_debstash))
1621 AV *ary = cx->blk_sub.argarray;
1622 int off = AvARRAY(ary) - AvALLOC(ary);
1626 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1629 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1632 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1633 av_extend(PL_dbargs, AvFILLp(ary) + off);
1634 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1635 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1637 /* XXX only hints propagated via op_private are currently
1638 * visible (others are not easily accessible, since they
1639 * use the global PL_hints) */
1640 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1641 HINT_PRIVATE_MASK)));
1644 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1646 if (old_warnings == pWARN_NONE ||
1647 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1648 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1649 else if (old_warnings == pWARN_ALL ||
1650 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1651 /* Get the bit mask for $warnings::Bits{all}, because
1652 * it could have been extended by warnings::register */
1654 HV *bits = get_hv("warnings::Bits", FALSE);
1655 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1656 mask = newSVsv(*bits_all);
1659 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1663 mask = newSVsv(old_warnings);
1664 PUSHs(sv_2mortal(mask));
1679 sv_reset(tmps, CopSTASH(PL_curcop));
1689 /* like pp_nextstate, but used instead when the debugger is active */
1693 PL_curcop = (COP*)PL_op;
1694 TAINT_NOT; /* Each statement is presumed innocent */
1695 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1698 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1699 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1703 register PERL_CONTEXT *cx;
1704 I32 gimme = G_ARRAY;
1711 DIE(aTHX_ "No DB::DB routine defined");
1713 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1714 /* don't do recursive DB::DB call */
1726 push_return(PL_op->op_next);
1727 PUSHBLOCK(cx, CXt_SUB, SP);
1730 PAD_SET_CUR(CvPADLIST(cv),1);
1731 RETURNOP(CvSTART(cv));
1745 register PERL_CONTEXT *cx;
1746 I32 gimme = GIMME_V;
1748 U32 cxtype = CXt_LOOP;
1756 if (PL_op->op_targ) {
1757 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1758 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1759 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1760 SVs_PADSTALE, SVs_PADSTALE);
1762 #ifndef USE_ITHREADS
1763 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1766 SAVEPADSV(PL_op->op_targ);
1767 iterdata = INT2PTR(void*, PL_op->op_targ);
1768 cxtype |= CXp_PADVAR;
1773 svp = &GvSV(gv); /* symbol table variable */
1774 SAVEGENERICSV(*svp);
1777 iterdata = (void*)gv;
1783 PUSHBLOCK(cx, cxtype, SP);
1785 PUSHLOOP(cx, iterdata, MARK);
1787 PUSHLOOP(cx, svp, MARK);
1789 if (PL_op->op_flags & OPf_STACKED) {
1790 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1791 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1793 if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
1794 if (SvNV(sv) < IV_MIN ||
1795 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1796 DIE(aTHX_ "Range iterator outside integer range");
1797 cx->blk_loop.iterix = SvIV(sv);
1798 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1802 cx->blk_loop.iterlval = newSVsv(sv);
1803 SvPV_force(cx->blk_loop.iterlval,n_a);
1808 cx->blk_loop.iterary = PL_curstack;
1809 AvFILLp(PL_curstack) = SP - PL_stack_base;
1810 cx->blk_loop.iterix = MARK - PL_stack_base;
1819 register PERL_CONTEXT *cx;
1820 I32 gimme = GIMME_V;
1826 PUSHBLOCK(cx, CXt_LOOP, SP);
1827 PUSHLOOP(cx, 0, SP);
1835 register PERL_CONTEXT *cx;
1843 newsp = PL_stack_base + cx->blk_loop.resetsp;
1846 if (gimme == G_VOID)
1848 else if (gimme == G_SCALAR) {
1850 *++newsp = sv_mortalcopy(*SP);
1852 *++newsp = &PL_sv_undef;
1856 *++newsp = sv_mortalcopy(*++mark);
1857 TAINT_NOT; /* Each item is independent */
1863 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1864 PL_curpm = newpm; /* ... and pop $1 et al */
1876 register PERL_CONTEXT *cx;
1877 bool popsub2 = FALSE;
1878 bool clear_errsv = FALSE;
1885 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1886 if (cxstack_ix == PL_sortcxix
1887 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1889 if (cxstack_ix > PL_sortcxix)
1890 dounwind(PL_sortcxix);
1891 AvARRAY(PL_curstack)[1] = *SP;
1892 PL_stack_sp = PL_stack_base + 1;
1897 cxix = dopoptosub(cxstack_ix);
1899 DIE(aTHX_ "Can't return outside a subroutine");
1900 if (cxix < cxstack_ix)
1904 switch (CxTYPE(cx)) {
1907 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1910 if (!(PL_in_eval & EVAL_KEEPERR))
1916 if (optype == OP_REQUIRE &&
1917 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1919 /* Unassume the success we assumed earlier. */
1920 SV *nsv = cx->blk_eval.old_namesv;
1921 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1922 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1929 DIE(aTHX_ "panic: return");
1933 if (gimme == G_SCALAR) {
1936 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1938 *++newsp = SvREFCNT_inc(*SP);
1943 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1945 *++newsp = sv_mortalcopy(sv);
1950 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1953 *++newsp = sv_mortalcopy(*SP);
1956 *++newsp = &PL_sv_undef;
1958 else if (gimme == G_ARRAY) {
1959 while (++MARK <= SP) {
1960 *++newsp = (popsub2 && SvTEMP(*MARK))
1961 ? *MARK : sv_mortalcopy(*MARK);
1962 TAINT_NOT; /* Each item is independent */
1965 PL_stack_sp = newsp;
1968 /* Stack values are safe: */
1971 POPSUB(cx,sv); /* release CV and @_ ... */
1975 PL_curpm = newpm; /* ... and pop $1 et al */
1980 return pop_return();
1987 register PERL_CONTEXT *cx;
1997 if (PL_op->op_flags & OPf_SPECIAL) {
1998 cxix = dopoptoloop(cxstack_ix);
2000 DIE(aTHX_ "Can't \"last\" outside a loop block");
2003 cxix = dopoptolabel(cPVOP->op_pv);
2005 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2007 if (cxix < cxstack_ix)
2011 cxstack_ix++; /* temporarily protect top context */
2013 switch (CxTYPE(cx)) {
2016 newsp = PL_stack_base + cx->blk_loop.resetsp;
2017 nextop = cx->blk_loop.last_op->op_next;
2021 nextop = pop_return();
2025 nextop = pop_return();
2029 nextop = pop_return();
2032 DIE(aTHX_ "panic: last");
2036 if (gimme == G_SCALAR) {
2038 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2039 ? *SP : sv_mortalcopy(*SP);
2041 *++newsp = &PL_sv_undef;
2043 else if (gimme == G_ARRAY) {
2044 while (++MARK <= SP) {
2045 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2046 ? *MARK : sv_mortalcopy(*MARK);
2047 TAINT_NOT; /* Each item is independent */
2055 /* Stack values are safe: */
2058 POPLOOP(cx); /* release loop vars ... */
2062 POPSUB(cx,sv); /* release CV and @_ ... */
2065 PL_curpm = newpm; /* ... and pop $1 et al */
2074 register PERL_CONTEXT *cx;
2077 if (PL_op->op_flags & OPf_SPECIAL) {
2078 cxix = dopoptoloop(cxstack_ix);
2080 DIE(aTHX_ "Can't \"next\" outside a loop block");
2083 cxix = dopoptolabel(cPVOP->op_pv);
2085 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2087 if (cxix < cxstack_ix)
2090 /* clear off anything above the scope we're re-entering, but
2091 * save the rest until after a possible continue block */
2092 inner = PL_scopestack_ix;
2094 if (PL_scopestack_ix < inner)
2095 leave_scope(PL_scopestack[PL_scopestack_ix]);
2096 return cx->blk_loop.next_op;
2102 register PERL_CONTEXT *cx;
2105 if (PL_op->op_flags & OPf_SPECIAL) {
2106 cxix = dopoptoloop(cxstack_ix);
2108 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2111 cxix = dopoptolabel(cPVOP->op_pv);
2113 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2115 if (cxix < cxstack_ix)
2119 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2120 LEAVE_SCOPE(oldsave);
2122 return cx->blk_loop.redo_op;
2126 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2130 static char too_deep[] = "Target of goto is too deeply nested";
2133 Perl_croak(aTHX_ too_deep);
2134 if (o->op_type == OP_LEAVE ||
2135 o->op_type == OP_SCOPE ||
2136 o->op_type == OP_LEAVELOOP ||
2137 o->op_type == OP_LEAVESUB ||
2138 o->op_type == OP_LEAVETRY)
2140 *ops++ = cUNOPo->op_first;
2142 Perl_croak(aTHX_ too_deep);
2145 if (o->op_flags & OPf_KIDS) {
2146 /* First try all the kids at this level, since that's likeliest. */
2147 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2148 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2149 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2152 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2153 if (kid == PL_lastgotoprobe)
2155 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2158 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2159 ops[-1]->op_type == OP_DBSTATE)
2164 if ((o = dofindlabel(kid, label, ops, oplimit)))
2183 register PERL_CONTEXT *cx;
2184 #define GOTO_DEPTH 64
2185 OP *enterops[GOTO_DEPTH];
2187 int do_dump = (PL_op->op_type == OP_DUMP);
2188 static char must_have_label[] = "goto must have label";
2192 if (PL_op->op_flags & OPf_STACKED) {
2196 /* This egregious kludge implements goto &subroutine */
2197 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2199 register PERL_CONTEXT *cx;
2200 CV* cv = (CV*)SvRV(sv);
2206 if (!CvROOT(cv) && !CvXSUB(cv)) {
2211 /* autoloaded stub? */
2212 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2214 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2215 GvNAMELEN(gv), FALSE);
2216 if (autogv && (cv = GvCV(autogv)))
2218 tmpstr = sv_newmortal();
2219 gv_efullname3(tmpstr, gv, Nullch);
2220 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2222 DIE(aTHX_ "Goto undefined subroutine");
2225 /* First do some returnish stuff. */
2226 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2228 cxix = dopoptosub(cxstack_ix);
2230 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2231 if (cxix < cxstack_ix)
2235 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2237 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2238 /* put @_ back onto stack */
2239 AV* av = cx->blk_sub.argarray;
2241 items = AvFILLp(av) + 1;
2243 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2244 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2245 PL_stack_sp += items;
2246 SvREFCNT_dec(GvAV(PL_defgv));
2247 GvAV(PL_defgv) = cx->blk_sub.savearray;
2248 /* abandon @_ if it got reified */
2250 oldav = av; /* delay until return */
2252 av_extend(av, items-1);
2253 AvFLAGS(av) = AVf_REIFY;
2254 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2259 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2261 av = GvAV(PL_defgv);
2262 items = AvFILLp(av) + 1;
2264 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2265 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2266 PL_stack_sp += items;
2268 if (CxTYPE(cx) == CXt_SUB &&
2269 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2270 SvREFCNT_dec(cx->blk_sub.cv);
2271 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2272 LEAVE_SCOPE(oldsave);
2274 /* Now do some callish stuff. */
2276 /* For reified @_, delay freeing till return from new sub */
2278 SAVEFREESV((SV*)oldav);
2279 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2281 #ifdef PERL_XSUB_OLDSTYLE
2282 if (CvOLDSTYLE(cv)) {
2283 I32 (*fp3)(int,int,int);
2288 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2289 items = (*fp3)(CvXSUBANY(cv).any_i32,
2290 mark - PL_stack_base + 1,
2292 SP = PL_stack_base + items;
2295 #endif /* PERL_XSUB_OLDSTYLE */
2300 PL_stack_sp--; /* There is no cv arg. */
2301 /* Push a mark for the start of arglist */
2303 (void)(*CvXSUB(cv))(aTHX_ cv);
2304 /* Pop the current context like a decent sub should */
2305 POPBLOCK(cx, PL_curpm);
2306 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2309 return pop_return();
2312 AV* padlist = CvPADLIST(cv);
2313 if (CxTYPE(cx) == CXt_EVAL) {
2314 PL_in_eval = cx->blk_eval.old_in_eval;
2315 PL_eval_root = cx->blk_eval.old_eval_root;
2316 cx->cx_type = CXt_SUB;
2317 cx->blk_sub.hasargs = 0;
2319 cx->blk_sub.cv = cv;
2320 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2323 if (CvDEPTH(cv) < 2)
2324 (void)SvREFCNT_inc(cv);
2326 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2327 sub_crush_depth(cv);
2328 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2330 PAD_SET_CUR(padlist, CvDEPTH(cv));
2331 if (cx->blk_sub.hasargs)
2333 AV* av = (AV*)PAD_SVl(0);
2336 cx->blk_sub.savearray = GvAV(PL_defgv);
2337 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2338 CX_CURPAD_SAVE(cx->blk_sub);
2339 cx->blk_sub.argarray = av;
2342 if (items >= AvMAX(av) + 1) {
2344 if (AvARRAY(av) != ary) {
2345 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2346 SvPVX(av) = (char*)ary;
2348 if (items >= AvMAX(av) + 1) {
2349 AvMAX(av) = items - 1;
2350 Renew(ary,items+1,SV*);
2352 SvPVX(av) = (char*)ary;
2355 Copy(mark,AvARRAY(av),items,SV*);
2356 AvFILLp(av) = items - 1;
2357 assert(!AvREAL(av));
2364 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2366 * We do not care about using sv to call CV;
2367 * it's for informational purposes only.
2369 SV *sv = GvSV(PL_DBsub);
2372 if (PERLDB_SUB_NN) {
2373 (void)SvUPGRADE(sv, SVt_PVIV);
2376 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2379 gv_efullname3(sv, CvGV(cv), Nullch);
2382 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2383 PUSHMARK( PL_stack_sp );
2384 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2388 RETURNOP(CvSTART(cv));
2392 label = SvPV(sv,n_a);
2393 if (!(do_dump || *label))
2394 DIE(aTHX_ must_have_label);
2397 else if (PL_op->op_flags & OPf_SPECIAL) {
2399 DIE(aTHX_ must_have_label);
2402 label = cPVOP->op_pv;
2404 if (label && *label) {
2406 bool leaving_eval = FALSE;
2407 bool in_block = FALSE;
2408 PERL_CONTEXT *last_eval_cx = 0;
2412 PL_lastgotoprobe = 0;
2414 for (ix = cxstack_ix; ix >= 0; ix--) {
2416 switch (CxTYPE(cx)) {
2418 leaving_eval = TRUE;
2419 if (!CxTRYBLOCK(cx)) {
2420 gotoprobe = (last_eval_cx ?
2421 last_eval_cx->blk_eval.old_eval_root :
2426 /* else fall through */
2428 gotoprobe = cx->blk_oldcop->op_sibling;
2434 gotoprobe = cx->blk_oldcop->op_sibling;
2437 gotoprobe = PL_main_root;
2440 if (CvDEPTH(cx->blk_sub.cv)) {
2441 gotoprobe = CvROOT(cx->blk_sub.cv);
2447 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2450 DIE(aTHX_ "panic: goto");
2451 gotoprobe = PL_main_root;
2455 retop = dofindlabel(gotoprobe, label,
2456 enterops, enterops + GOTO_DEPTH);
2460 PL_lastgotoprobe = gotoprobe;
2463 DIE(aTHX_ "Can't find label %s", label);
2465 /* if we're leaving an eval, check before we pop any frames
2466 that we're not going to punt, otherwise the error
2469 if (leaving_eval && *enterops && enterops[1]) {
2471 for (i = 1; enterops[i]; i++)
2472 if (enterops[i]->op_type == OP_ENTERITER)
2473 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2476 /* pop unwanted frames */
2478 if (ix < cxstack_ix) {
2485 oldsave = PL_scopestack[PL_scopestack_ix];
2486 LEAVE_SCOPE(oldsave);
2489 /* push wanted frames */
2491 if (*enterops && enterops[1]) {
2493 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2494 for (; enterops[ix]; ix++) {
2495 PL_op = enterops[ix];
2496 /* Eventually we may want to stack the needed arguments
2497 * for each op. For now, we punt on the hard ones. */
2498 if (PL_op->op_type == OP_ENTERITER)
2499 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2500 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2508 if (!retop) retop = PL_main_start;
2510 PL_restartop = retop;
2511 PL_do_undump = TRUE;
2515 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2516 PL_do_undump = FALSE;
2532 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2534 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2537 PL_exit_flags |= PERL_EXIT_EXPECTED;
2539 PUSHs(&PL_sv_undef);
2547 NV value = SvNVx(GvSV(cCOP->cop_gv));
2548 register I32 match = I_32(value);
2551 if (((NV)match) > value)
2552 --match; /* was fractional--truncate other way */
2554 match -= cCOP->uop.scop.scop_offset;
2557 else if (match > cCOP->uop.scop.scop_max)
2558 match = cCOP->uop.scop.scop_max;
2559 PL_op = cCOP->uop.scop.scop_next[match];
2569 PL_op = PL_op->op_next; /* can't assume anything */
2572 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2573 match -= cCOP->uop.scop.scop_offset;
2576 else if (match > cCOP->uop.scop.scop_max)
2577 match = cCOP->uop.scop.scop_max;
2578 PL_op = cCOP->uop.scop.scop_next[match];
2587 S_save_lines(pTHX_ AV *array, SV *sv)
2589 register char *s = SvPVX(sv);
2590 register char *send = SvPVX(sv) + SvCUR(sv);
2592 register I32 line = 1;
2594 while (s && s < send) {
2595 SV *tmpstr = NEWSV(85,0);
2597 sv_upgrade(tmpstr, SVt_PVMG);
2598 t = strchr(s, '\n');
2604 sv_setpvn(tmpstr, s, t - s);
2605 av_store(array, line++, tmpstr);
2610 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2612 S_docatch_body(pTHX_ va_list args)
2614 return docatch_body();
2619 S_docatch_body(pTHX)
2626 S_docatch(pTHX_ OP *o)
2631 volatile PERL_SI *cursi = PL_curstackinfo;
2635 assert(CATCH_GET == TRUE);
2639 /* Normally, the leavetry at the end of this block of ops will
2640 * pop an op off the return stack and continue there. By setting
2641 * the op to Nullop, we force an exit from the inner runops()
2644 retop = pop_return();
2645 push_return(Nullop);
2647 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2649 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2655 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2661 /* die caught by an inner eval - continue inner loop */
2662 if (PL_restartop && cursi == PL_curstackinfo) {
2663 PL_op = PL_restartop;
2667 /* a die in this eval - continue in outer loop */
2683 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2684 /* sv Text to convert to OP tree. */
2685 /* startop op_free() this to undo. */
2686 /* code Short string id of the caller. */
2688 dSP; /* Make POPBLOCK work. */
2691 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2695 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2696 char *tmpbuf = tbuf;
2699 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2704 /* switch to eval mode */
2706 if (IN_PERL_COMPILETIME) {
2707 SAVECOPSTASH_FREE(&PL_compiling);
2708 CopSTASH_set(&PL_compiling, PL_curstash);
2710 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2711 SV *sv = sv_newmortal();
2712 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2713 code, (unsigned long)++PL_evalseq,
2714 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2718 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2719 SAVECOPFILE_FREE(&PL_compiling);
2720 CopFILE_set(&PL_compiling, tmpbuf+2);
2721 SAVECOPLINE(&PL_compiling);
2722 CopLINE_set(&PL_compiling, 1);
2723 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2724 deleting the eval's FILEGV from the stash before gv_check() runs
2725 (i.e. before run-time proper). To work around the coredump that
2726 ensues, we always turn GvMULTI_on for any globals that were
2727 introduced within evals. See force_ident(). GSAR 96-10-12 */
2728 safestr = savepv(tmpbuf);
2729 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2731 #ifdef OP_IN_REGISTER
2737 /* we get here either during compilation, or via pp_regcomp at runtime */
2738 runtime = IN_PERL_RUNTIME;
2740 runcv = find_runcv(NULL);
2743 PL_op->op_type = OP_ENTEREVAL;
2744 PL_op->op_flags = 0; /* Avoid uninit warning. */
2745 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2746 PUSHEVAL(cx, 0, Nullgv);
2749 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2751 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2752 POPBLOCK(cx,PL_curpm);
2755 (*startop)->op_type = OP_NULL;
2756 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2758 /* XXX DAPM do this properly one year */
2759 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2761 if (IN_PERL_COMPILETIME)
2762 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2763 #ifdef OP_IN_REGISTER
2771 =for apidoc find_runcv
2773 Locate the CV corresponding to the currently executing sub or eval.
2774 If db_seqp is non_null, skip CVs that are in the DB package and populate
2775 *db_seqp with the cop sequence number at the point that the DB:: code was
2776 entered. (allows debuggers to eval in the scope of the breakpoint rather
2777 than in in the scope of the debuger itself).
2783 Perl_find_runcv(pTHX_ U32 *db_seqp)
2790 *db_seqp = PL_curcop->cop_seq;
2791 for (si = PL_curstackinfo; si; si = si->si_prev) {
2792 for (ix = si->si_cxix; ix >= 0; ix--) {
2793 cx = &(si->si_cxstack[ix]);
2794 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2795 CV *cv = cx->blk_sub.cv;
2796 /* skip DB:: code */
2797 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2798 *db_seqp = cx->blk_oldcop->cop_seq;
2803 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2811 /* Compile a require/do, an eval '', or a /(?{...})/.
2812 * In the last case, startop is non-null, and contains the address of
2813 * a pointer that should be set to the just-compiled code.
2814 * outside is the lexically enclosing CV (if any) that invoked us.
2817 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2819 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2824 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2825 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2830 SAVESPTR(PL_compcv);
2831 PL_compcv = (CV*)NEWSV(1104,0);
2832 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2833 CvEVAL_on(PL_compcv);
2834 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2835 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2837 CvOUTSIDE_SEQ(PL_compcv) = seq;
2838 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2840 /* set up a scratch pad */
2842 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2845 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2847 /* make sure we compile in the right package */
2849 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2850 SAVESPTR(PL_curstash);
2851 PL_curstash = CopSTASH(PL_curcop);
2853 SAVESPTR(PL_beginav);
2854 PL_beginav = newAV();
2855 SAVEFREESV(PL_beginav);
2856 SAVEI32(PL_error_count);
2858 /* try to compile it */
2860 PL_eval_root = Nullop;
2862 PL_curcop = &PL_compiling;
2863 PL_curcop->cop_arybase = 0;
2864 if (saveop && saveop->op_flags & OPf_SPECIAL)
2865 PL_in_eval |= EVAL_KEEPERR;
2868 if (yyparse() || PL_error_count || !PL_eval_root) {
2869 SV **newsp; /* Used by POPBLOCK. */
2870 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2871 I32 optype = 0; /* Might be reset by POPEVAL. */
2876 op_free(PL_eval_root);
2877 PL_eval_root = Nullop;
2879 SP = PL_stack_base + POPMARK; /* pop original mark */
2881 POPBLOCK(cx,PL_curpm);
2887 if (optype == OP_REQUIRE) {
2888 char* msg = SvPVx(ERRSV, n_a);
2889 SV *nsv = cx->blk_eval.old_namesv;
2890 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2892 DIE(aTHX_ "%sCompilation failed in require",
2893 *msg ? msg : "Unknown error\n");
2896 char* msg = SvPVx(ERRSV, n_a);
2898 POPBLOCK(cx,PL_curpm);
2900 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2901 (*msg ? msg : "Unknown error\n"));
2904 char* msg = SvPVx(ERRSV, n_a);
2906 sv_setpv(ERRSV, "Compilation error");
2911 CopLINE_set(&PL_compiling, 0);
2913 *startop = PL_eval_root;
2915 SAVEFREEOP(PL_eval_root);
2917 /* Set the context for this new optree.
2918 * If the last op is an OP_REQUIRE, force scalar context.
2919 * Otherwise, propagate the context from the eval(). */
2920 if (PL_eval_root->op_type == OP_LEAVEEVAL
2921 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2922 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2924 scalar(PL_eval_root);
2925 else if (gimme & G_VOID)
2926 scalarvoid(PL_eval_root);
2927 else if (gimme & G_ARRAY)
2930 scalar(PL_eval_root);
2932 DEBUG_x(dump_eval());
2934 /* Register with debugger: */
2935 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2936 CV *cv = get_cv("DB::postponed", FALSE);
2940 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2942 call_sv((SV*)cv, G_DISCARD);
2946 /* compiled okay, so do it */
2948 CvDEPTH(PL_compcv) = 1;
2949 SP = PL_stack_base + POPMARK; /* pop original mark */
2950 PL_op = saveop; /* The caller may need it. */
2951 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2953 RETURNOP(PL_eval_start);
2957 S_doopen_pm(pTHX_ const char *name, const char *mode)
2959 #ifndef PERL_DISABLE_PMC
2960 STRLEN namelen = strlen(name);
2963 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2964 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2965 char *pmc = SvPV_nolen(pmcsv);
2968 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2969 fp = PerlIO_open(name, mode);
2972 if (PerlLIO_stat(name, &pmstat) < 0 ||
2973 pmstat.st_mtime < pmcstat.st_mtime)
2975 fp = PerlIO_open(pmc, mode);
2978 fp = PerlIO_open(name, mode);
2981 SvREFCNT_dec(pmcsv);
2984 fp = PerlIO_open(name, mode);
2988 return PerlIO_open(name, mode);
2989 #endif /* !PERL_DISABLE_PMC */
2995 register PERL_CONTEXT *cx;
2999 char *tryname = Nullch;
3000 SV *namesv = Nullsv;
3002 I32 gimme = GIMME_V;
3003 PerlIO *tryrsfp = 0;
3005 int filter_has_file = 0;
3006 GV *filter_child_proc = 0;
3007 SV *filter_state = 0;
3014 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
3015 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3016 UV rev = 0, ver = 0, sver = 0;
3018 U8 *s = (U8*)SvPVX(sv);
3019 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3021 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3024 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3027 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3030 if (PERL_REVISION < rev
3031 || (PERL_REVISION == rev
3032 && (PERL_VERSION < ver
3033 || (PERL_VERSION == ver
3034 && PERL_SUBVERSION < sver))))
3036 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3037 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3038 PERL_VERSION, PERL_SUBVERSION);
3040 if (ckWARN(WARN_PORTABLE))
3041 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3042 "v-string in use/require non-portable");
3045 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3046 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3047 + ((NV)PERL_SUBVERSION/(NV)1000000)
3048 + 0.00000099 < SvNV(sv))
3052 NV nver = (nrev - rev) * 1000;
3053 UV ver = (UV)(nver + 0.0009);
3054 NV nsver = (nver - ver) * 1000;
3055 UV sver = (UV)(nsver + 0.0009);
3057 /* help out with the "use 5.6" confusion */
3058 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3059 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3060 " (did you mean v%"UVuf".%03"UVuf"?)--"
3061 "this is only v%d.%d.%d, stopped",
3062 rev, ver, sver, rev, ver/100,
3063 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3066 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3067 "this is only v%d.%d.%d, stopped",
3068 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3075 name = SvPV(sv, len);
3076 if (!(name && len > 0 && *name))
3077 DIE(aTHX_ "Null filename used");
3078 TAINT_PROPER("require");
3079 if (PL_op->op_type == OP_REQUIRE &&
3080 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3081 if (*svp != &PL_sv_undef)
3084 DIE(aTHX_ "Compilation failed in require");
3087 /* prepare to compile file */
3089 if (path_is_absolute(name)) {
3091 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3093 #ifdef MACOS_TRADITIONAL
3097 MacPerl_CanonDir(name, newname, 1);
3098 if (path_is_absolute(newname)) {
3100 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3105 AV *ar = GvAVn(PL_incgv);
3109 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3112 namesv = NEWSV(806, 0);
3113 for (i = 0; i <= AvFILL(ar); i++) {
3114 SV *dirsv = *av_fetch(ar, i, TRUE);
3120 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3121 && !sv_isobject(loader))
3123 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3126 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3127 PTR2UV(SvRV(dirsv)), name);
3128 tryname = SvPVX(namesv);
3139 if (sv_isobject(loader))
3140 count = call_method("INC", G_ARRAY);
3142 count = call_sv(loader, G_ARRAY);
3152 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3156 if (SvTYPE(arg) == SVt_PVGV) {
3157 IO *io = GvIO((GV *)arg);
3162 tryrsfp = IoIFP(io);
3163 if (IoTYPE(io) == IoTYPE_PIPE) {
3164 /* reading from a child process doesn't
3165 nest -- when returning from reading
3166 the inner module, the outer one is
3167 unreadable (closed?) I've tried to
3168 save the gv to manage the lifespan of
3169 the pipe, but this didn't help. XXX */
3170 filter_child_proc = (GV *)arg;
3171 (void)SvREFCNT_inc(filter_child_proc);
3174 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3175 PerlIO_close(IoOFP(io));
3187 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3189 (void)SvREFCNT_inc(filter_sub);
3192 filter_state = SP[i];
3193 (void)SvREFCNT_inc(filter_state);
3197 tryrsfp = PerlIO_open("/dev/null",
3213 filter_has_file = 0;
3214 if (filter_child_proc) {
3215 SvREFCNT_dec(filter_child_proc);
3216 filter_child_proc = 0;
3219 SvREFCNT_dec(filter_state);
3223 SvREFCNT_dec(filter_sub);
3228 if (!path_is_absolute(name)
3229 #ifdef MACOS_TRADITIONAL
3230 /* We consider paths of the form :a:b ambiguous and interpret them first
3231 as global then as local
3233 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3236 char *dir = SvPVx(dirsv, n_a);
3237 #ifdef MACOS_TRADITIONAL
3241 MacPerl_CanonDir(name, buf2, 1);
3242 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3246 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3248 sv_setpv(namesv, unixdir);
3249 sv_catpv(namesv, unixname);
3251 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3254 TAINT_PROPER("require");
3255 tryname = SvPVX(namesv);
3256 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3258 if (tryname[0] == '.' && tryname[1] == '/')
3267 SAVECOPFILE_FREE(&PL_compiling);
3268 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3269 SvREFCNT_dec(namesv);
3271 if (PL_op->op_type == OP_REQUIRE) {
3272 char *msgstr = name;
3273 if (namesv) { /* did we lookup @INC? */
3274 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3275 SV *dirmsgsv = NEWSV(0, 0);
3276 AV *ar = GvAVn(PL_incgv);
3278 sv_catpvn(msg, " in @INC", 8);
3279 if (instr(SvPVX(msg), ".h "))
3280 sv_catpv(msg, " (change .h to .ph maybe?)");
3281 if (instr(SvPVX(msg), ".ph "))
3282 sv_catpv(msg, " (did you run h2ph?)");
3283 sv_catpv(msg, " (@INC contains:");
3284 for (i = 0; i <= AvFILL(ar); i++) {
3285 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3286 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3287 sv_catsv(msg, dirmsgsv);
3289 sv_catpvn(msg, ")", 1);
3290 SvREFCNT_dec(dirmsgsv);
3291 msgstr = SvPV_nolen(msg);
3293 DIE(aTHX_ "Can't locate %s", msgstr);
3299 SETERRNO(0, SS_NORMAL);
3301 /* Assume success here to prevent recursive requirement. */
3303 /* Check whether a hook in @INC has already filled %INC */
3304 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3305 (void)hv_store(GvHVn(PL_incgv), name, len,
3306 (hook_sv ? SvREFCNT_inc(hook_sv)
3307 : newSVpv(CopFILE(&PL_compiling), 0)),
3313 lex_start(sv_2mortal(newSVpvn("",0)));
3314 SAVEGENERICSV(PL_rsfp_filters);
3315 PL_rsfp_filters = Nullav;
3320 SAVESPTR(PL_compiling.cop_warnings);
3321 if (PL_dowarn & G_WARN_ALL_ON)
3322 PL_compiling.cop_warnings = pWARN_ALL ;
3323 else if (PL_dowarn & G_WARN_ALL_OFF)
3324 PL_compiling.cop_warnings = pWARN_NONE ;
3325 else if (PL_taint_warn)
3326 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3328 PL_compiling.cop_warnings = pWARN_STD ;
3329 SAVESPTR(PL_compiling.cop_io);
3330 PL_compiling.cop_io = Nullsv;
3332 if (filter_sub || filter_child_proc) {
3333 SV *datasv = filter_add(run_user_filter, Nullsv);
3334 IoLINES(datasv) = filter_has_file;
3335 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3336 IoTOP_GV(datasv) = (GV *)filter_state;
3337 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3340 /* switch to eval mode */
3341 push_return(PL_op->op_next);
3342 PUSHBLOCK(cx, CXt_EVAL, SP);
3343 PUSHEVAL(cx, name, Nullgv);
3345 SAVECOPLINE(&PL_compiling);
3346 CopLINE_set(&PL_compiling, 0);
3350 /* Store and reset encoding. */
3351 encoding = PL_encoding;
3352 PL_encoding = Nullsv;
3354 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3356 /* Restore encoding. */
3357 PL_encoding = encoding;
3364 return pp_require();
3370 register PERL_CONTEXT *cx;
3372 I32 gimme = GIMME_V, was = PL_sub_generation;
3373 char tbuf[TYPE_DIGITS(long) + 12];
3374 char *tmpbuf = tbuf;
3383 TAINT_PROPER("eval");
3389 /* switch to eval mode */
3391 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3392 SV *sv = sv_newmortal();
3393 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3394 (unsigned long)++PL_evalseq,
3395 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3399 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3400 SAVECOPFILE_FREE(&PL_compiling);
3401 CopFILE_set(&PL_compiling, tmpbuf+2);
3402 SAVECOPLINE(&PL_compiling);
3403 CopLINE_set(&PL_compiling, 1);
3404 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3405 deleting the eval's FILEGV from the stash before gv_check() runs
3406 (i.e. before run-time proper). To work around the coredump that
3407 ensues, we always turn GvMULTI_on for any globals that were
3408 introduced within evals. See force_ident(). GSAR 96-10-12 */
3409 safestr = savepv(tmpbuf);
3410 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3412 PL_hints = PL_op->op_targ;
3413 SAVESPTR(PL_compiling.cop_warnings);
3414 if (specialWARN(PL_curcop->cop_warnings))
3415 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3417 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3418 SAVEFREESV(PL_compiling.cop_warnings);
3420 SAVESPTR(PL_compiling.cop_io);
3421 if (specialCopIO(PL_curcop->cop_io))
3422 PL_compiling.cop_io = PL_curcop->cop_io;
3424 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3425 SAVEFREESV(PL_compiling.cop_io);
3427 /* special case: an eval '' executed within the DB package gets lexically
3428 * placed in the first non-DB CV rather than the current CV - this
3429 * allows the debugger to execute code, find lexicals etc, in the
3430 * scope of the code being debugged. Passing &seq gets find_runcv
3431 * to do the dirty work for us */
3432 runcv = find_runcv(&seq);
3434 push_return(PL_op->op_next);
3435 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3436 PUSHEVAL(cx, 0, Nullgv);
3438 /* prepare to compile string */
3440 if (PERLDB_LINE && PL_curstash != PL_debstash)
3441 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3443 ret = doeval(gimme, NULL, runcv, seq);
3444 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3445 && ret != PL_op->op_next) { /* Successive compilation. */
3446 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3448 return DOCATCH(ret);
3458 register PERL_CONTEXT *cx;
3460 U8 save_flags = PL_op -> op_flags;
3465 retop = pop_return();
3468 if (gimme == G_VOID)
3470 else if (gimme == G_SCALAR) {
3473 if (SvFLAGS(TOPs) & SVs_TEMP)
3476 *MARK = sv_mortalcopy(TOPs);
3480 *MARK = &PL_sv_undef;
3485 /* in case LEAVE wipes old return values */
3486 for (mark = newsp + 1; mark <= SP; mark++) {
3487 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3488 *mark = sv_mortalcopy(*mark);
3489 TAINT_NOT; /* Each item is independent */
3493 PL_curpm = newpm; /* Don't pop $1 et al till now */
3496 assert(CvDEPTH(PL_compcv) == 1);
3498 CvDEPTH(PL_compcv) = 0;
3501 if (optype == OP_REQUIRE &&
3502 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3504 /* Unassume the success we assumed earlier. */
3505 SV *nsv = cx->blk_eval.old_namesv;
3506 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3507 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3508 /* die_where() did LEAVE, or we won't be here */
3512 if (!(save_flags & OPf_SPECIAL))
3522 register PERL_CONTEXT *cx;
3523 I32 gimme = GIMME_V;
3528 push_return(cLOGOP->op_other->op_next);
3529 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3532 PL_in_eval = EVAL_INEVAL;
3535 return DOCATCH(PL_op->op_next);
3546 register PERL_CONTEXT *cx;
3551 retop = pop_return();
3554 if (gimme == G_VOID)
3556 else if (gimme == G_SCALAR) {
3559 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3562 *MARK = sv_mortalcopy(TOPs);
3566 *MARK = &PL_sv_undef;
3571 /* in case LEAVE wipes old return values */
3572 for (mark = newsp + 1; mark <= SP; mark++) {
3573 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3574 *mark = sv_mortalcopy(*mark);
3575 TAINT_NOT; /* Each item is independent */
3579 PL_curpm = newpm; /* Don't pop $1 et al till now */
3587 S_doparseform(pTHX_ SV *sv)
3590 register char *s = SvPV_force(sv, len);
3591 register char *send = s + len;
3592 register char *base = Nullch;
3593 register I32 skipspaces = 0;
3594 bool noblank = FALSE;
3595 bool repeat = FALSE;
3596 bool postspace = FALSE;
3602 bool unchopnum = FALSE;
3603 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3606 Perl_croak(aTHX_ "Null picture in formline");
3608 /* estimate the buffer size needed */
3609 for (base = s; s <= send; s++) {
3610 if (*s == '\n' || *s == '@' || *s == '^')
3616 New(804, fops, maxops, U32);
3621 *fpc++ = FF_LINEMARK;
3622 noblank = repeat = FALSE;
3640 case ' ': case '\t':
3647 } /* else FALL THROUGH */
3655 *fpc++ = FF_LITERAL;
3663 *fpc++ = (U16)skipspaces;
3667 *fpc++ = FF_NEWLINE;
3671 arg = fpc - linepc + 1;
3678 *fpc++ = FF_LINEMARK;
3679 noblank = repeat = FALSE;
3688 ischop = s[-1] == '^';
3694 arg = (s - base) - 1;
3696 *fpc++ = FF_LITERAL;
3704 *fpc++ = 2; /* skip the @* or ^* */
3706 *fpc++ = FF_LINESNGL;
3709 *fpc++ = FF_LINEGLOB;
3711 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3712 arg = ischop ? 512 : 0;
3722 arg |= 256 + (s - f);
3724 *fpc++ = s - base; /* fieldsize for FETCH */
3725 *fpc++ = FF_DECIMAL;
3727 unchopnum |= ! ischop;
3729 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3730 arg = ischop ? 512 : 0;
3732 s++; /* skip the '0' first */
3741 arg |= 256 + (s - f);
3743 *fpc++ = s - base; /* fieldsize for FETCH */
3744 *fpc++ = FF_0DECIMAL;
3746 unchopnum |= ! ischop;
3750 bool ismore = FALSE;
3753 while (*++s == '>') ;
3754 prespace = FF_SPACE;
3756 else if (*s == '|') {
3757 while (*++s == '|') ;
3758 prespace = FF_HALFSPACE;
3763 while (*++s == '<') ;
3766 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3770 *fpc++ = s - base; /* fieldsize for FETCH */
3772 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3775 *fpc++ = (U16)prespace;
3789 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3791 { /* need to jump to the next word */
3793 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3794 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3795 s = SvPVX(sv) + SvCUR(sv) + z;
3797 Copy(fops, s, arg, U32);
3799 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3802 if (unchopnum && repeat)
3803 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3809 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3811 /* Can value be printed in fldsize chars, using %*.*f ? */
3815 int intsize = fldsize - (value < 0 ? 1 : 0);
3822 while (intsize--) pwr *= 10.0;
3823 while (frcsize--) eps /= 10.0;
3826 if (value + eps >= pwr)
3829 if (value - eps <= -pwr)
3836 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3838 SV *datasv = FILTER_DATA(idx);
3839 int filter_has_file = IoLINES(datasv);
3840 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3841 SV *filter_state = (SV *)IoTOP_GV(datasv);
3842 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3845 /* I was having segfault trouble under Linux 2.2.5 after a
3846 parse error occured. (Had to hack around it with a test
3847 for PL_error_count == 0.) Solaris doesn't segfault --
3848 not sure where the trouble is yet. XXX */
3850 if (filter_has_file) {
3851 len = FILTER_READ(idx+1, buf_sv, maxlen);
3854 if (filter_sub && len >= 0) {
3865 PUSHs(sv_2mortal(newSViv(maxlen)));
3867 PUSHs(filter_state);
3870 count = call_sv(filter_sub, G_SCALAR);
3886 IoLINES(datasv) = 0;
3887 if (filter_child_proc) {
3888 SvREFCNT_dec(filter_child_proc);
3889 IoFMT_GV(datasv) = Nullgv;
3892 SvREFCNT_dec(filter_state);
3893 IoTOP_GV(datasv) = Nullgv;
3896 SvREFCNT_dec(filter_sub);
3897 IoBOTTOM_GV(datasv) = Nullgv;
3899 filter_del(run_user_filter);
3905 /* perhaps someone can come up with a better name for
3906 this? it is not really "absolute", per se ... */
3908 S_path_is_absolute(pTHX_ char *name)
3910 if (PERL_FILE_IS_ABSOLUTE(name)
3911 #ifdef MACOS_TRADITIONAL
3914 || (*name == '.' && (name[1] == '/' ||
3915 (name[1] == '.' && name[2] == '/'))))