3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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)) || ((!SvOK(left) || \
1062 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1063 && (!SvOK(right) || looks_like_number(right))))
1069 if (GIMME == G_ARRAY) {
1075 if (SvGMAGICAL(left))
1077 if (SvGMAGICAL(right))
1080 if (RANGE_IS_NUMERIC(left,right)) {
1081 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1082 (SvOK(right) && SvNV(right) > IV_MAX))
1083 DIE(aTHX_ "Range iterator outside integer range");
1094 sv = sv_2mortal(newSViv(i++));
1099 SV *final = sv_mortalcopy(right);
1101 char *tmps = SvPV(final, len);
1103 sv = sv_mortalcopy(left);
1105 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1107 if (strEQ(SvPVX(sv),tmps))
1109 sv = sv_2mortal(newSVsv(sv));
1116 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1120 if (PL_op->op_private & OPpFLIP_LINENUM) {
1121 if (GvIO(PL_last_in_gv)) {
1122 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1125 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1126 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1134 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1135 sv_catpv(targ, "E0");
1145 static char *context_name[] = {
1156 S_dopoptolabel(pTHX_ char *label)
1159 register PERL_CONTEXT *cx;
1161 for (i = cxstack_ix; i >= 0; i--) {
1163 switch (CxTYPE(cx)) {
1169 if (ckWARN(WARN_EXITING))
1170 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1171 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1172 if (CxTYPE(cx) == CXt_NULL)
1176 if (!cx->blk_loop.label ||
1177 strNE(label, cx->blk_loop.label) ) {
1178 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1179 (long)i, cx->blk_loop.label));
1182 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1190 Perl_dowantarray(pTHX)
1192 I32 gimme = block_gimme();
1193 return (gimme == G_VOID) ? G_SCALAR : gimme;
1197 Perl_block_gimme(pTHX)
1201 cxix = dopoptosub(cxstack_ix);
1205 switch (cxstack[cxix].blk_gimme) {
1213 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1220 Perl_is_lvalue_sub(pTHX)
1224 cxix = dopoptosub(cxstack_ix);
1225 assert(cxix >= 0); /* We should only be called from inside subs */
1227 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1228 return cxstack[cxix].blk_sub.lval;
1234 S_dopoptosub(pTHX_ I32 startingblock)
1236 return dopoptosub_at(cxstack, startingblock);
1240 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1243 register PERL_CONTEXT *cx;
1244 for (i = startingblock; i >= 0; i--) {
1246 switch (CxTYPE(cx)) {
1252 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1260 S_dopoptoeval(pTHX_ I32 startingblock)
1263 register PERL_CONTEXT *cx;
1264 for (i = startingblock; i >= 0; i--) {
1266 switch (CxTYPE(cx)) {
1270 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1278 S_dopoptoloop(pTHX_ I32 startingblock)
1281 register PERL_CONTEXT *cx;
1282 for (i = startingblock; i >= 0; i--) {
1284 switch (CxTYPE(cx)) {
1290 if (ckWARN(WARN_EXITING))
1291 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1292 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1293 if ((CxTYPE(cx)) == CXt_NULL)
1297 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1305 Perl_dounwind(pTHX_ I32 cxix)
1307 register PERL_CONTEXT *cx;
1310 while (cxstack_ix > cxix) {
1312 cx = &cxstack[cxstack_ix];
1313 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1314 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1315 /* Note: we don't need to restore the base context info till the end. */
1316 switch (CxTYPE(cx)) {
1319 continue; /* not break */
1341 Perl_qerror(pTHX_ SV *err)
1344 sv_catsv(ERRSV, err);
1346 sv_catsv(PL_errors, err);
1348 Perl_warn(aTHX_ "%"SVf, err);
1353 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1359 register PERL_CONTEXT *cx;
1364 if (PL_in_eval & EVAL_KEEPERR) {
1365 static char prefix[] = "\t(in cleanup) ";
1370 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1373 if (*e != *message || strNE(e,message))
1377 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1378 sv_catpvn(err, prefix, sizeof(prefix)-1);
1379 sv_catpvn(err, message, msglen);
1380 if (ckWARN(WARN_MISC)) {
1381 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1382 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1387 sv_setpvn(ERRSV, message, msglen);
1391 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1392 && PL_curstackinfo->si_prev)
1401 if (cxix < cxstack_ix)
1404 POPBLOCK(cx,PL_curpm);
1405 if (CxTYPE(cx) != CXt_EVAL) {
1407 message = SvPVx(ERRSV, msglen);
1408 PerlIO_write(Perl_error_log, "panic: die ", 11);
1409 PerlIO_write(Perl_error_log, message, msglen);
1414 if (gimme == G_SCALAR)
1415 *++newsp = &PL_sv_undef;
1416 PL_stack_sp = newsp;
1420 /* LEAVE could clobber PL_curcop (see save_re_context())
1421 * XXX it might be better to find a way to avoid messing with
1422 * PL_curcop in save_re_context() instead, but this is a more
1423 * minimal fix --GSAR */
1424 PL_curcop = cx->blk_oldcop;
1426 if (optype == OP_REQUIRE) {
1427 char* msg = SvPVx(ERRSV, n_a);
1428 SV *nsv = cx->blk_eval.old_namesv;
1429 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1431 DIE(aTHX_ "%sCompilation failed in require",
1432 *msg ? msg : "Unknown error\n");
1434 return pop_return();
1438 message = SvPVx(ERRSV, msglen);
1440 write_to_stderr(message, msglen);
1449 if (SvTRUE(left) != SvTRUE(right))
1461 RETURNOP(cLOGOP->op_other);
1470 RETURNOP(cLOGOP->op_other);
1479 if (!sv || !SvANY(sv)) {
1480 RETURNOP(cLOGOP->op_other);
1483 switch (SvTYPE(sv)) {
1485 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1489 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1493 if (CvROOT(sv) || CvXSUB(sv))
1503 RETURNOP(cLOGOP->op_other);
1509 register I32 cxix = dopoptosub(cxstack_ix);
1510 register PERL_CONTEXT *cx;
1511 register PERL_CONTEXT *ccstack = cxstack;
1512 PERL_SI *top_si = PL_curstackinfo;
1523 /* we may be in a higher stacklevel, so dig down deeper */
1524 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1525 top_si = top_si->si_prev;
1526 ccstack = top_si->si_cxstack;
1527 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1530 if (GIMME != G_ARRAY) {
1536 if (PL_DBsub && cxix >= 0 &&
1537 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1541 cxix = dopoptosub_at(ccstack, cxix - 1);
1544 cx = &ccstack[cxix];
1545 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1546 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1547 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1548 field below is defined for any cx. */
1549 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1550 cx = &ccstack[dbcxix];
1553 stashname = CopSTASHPV(cx->blk_oldcop);
1554 if (GIMME != G_ARRAY) {
1557 PUSHs(&PL_sv_undef);
1560 sv_setpv(TARG, stashname);
1569 PUSHs(&PL_sv_undef);
1571 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1572 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1573 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1576 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1577 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1578 /* So is ccstack[dbcxix]. */
1581 gv_efullname3(sv, cvgv, Nullch);
1582 PUSHs(sv_2mortal(sv));
1583 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1586 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1587 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1591 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1592 PUSHs(sv_2mortal(newSViv(0)));
1594 gimme = (I32)cx->blk_gimme;
1595 if (gimme == G_VOID)
1596 PUSHs(&PL_sv_undef);
1598 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1599 if (CxTYPE(cx) == CXt_EVAL) {
1601 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1602 PUSHs(cx->blk_eval.cur_text);
1606 else if (cx->blk_eval.old_namesv) {
1607 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1610 /* eval BLOCK (try blocks have old_namesv == 0) */
1612 PUSHs(&PL_sv_undef);
1613 PUSHs(&PL_sv_undef);
1617 PUSHs(&PL_sv_undef);
1618 PUSHs(&PL_sv_undef);
1620 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1621 && CopSTASH_eq(PL_curcop, PL_debstash))
1623 AV *ary = cx->blk_sub.argarray;
1624 int off = AvARRAY(ary) - AvALLOC(ary);
1628 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1631 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1634 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1635 av_extend(PL_dbargs, AvFILLp(ary) + off);
1636 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1637 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1639 /* XXX only hints propagated via op_private are currently
1640 * visible (others are not easily accessible, since they
1641 * use the global PL_hints) */
1642 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1643 HINT_PRIVATE_MASK)));
1646 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1648 if (old_warnings == pWARN_NONE ||
1649 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1650 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1651 else if (old_warnings == pWARN_ALL ||
1652 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1653 /* Get the bit mask for $warnings::Bits{all}, because
1654 * it could have been extended by warnings::register */
1656 HV *bits = get_hv("warnings::Bits", FALSE);
1657 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1658 mask = newSVsv(*bits_all);
1661 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1665 mask = newSVsv(old_warnings);
1666 PUSHs(sv_2mortal(mask));
1681 sv_reset(tmps, CopSTASH(PL_curcop));
1691 /* like pp_nextstate, but used instead when the debugger is active */
1695 PL_curcop = (COP*)PL_op;
1696 TAINT_NOT; /* Each statement is presumed innocent */
1697 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1700 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1701 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1705 register PERL_CONTEXT *cx;
1706 I32 gimme = G_ARRAY;
1713 DIE(aTHX_ "No DB::DB routine defined");
1715 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1716 /* don't do recursive DB::DB call */
1728 push_return(PL_op->op_next);
1729 PUSHBLOCK(cx, CXt_SUB, SP);
1732 PAD_SET_CUR(CvPADLIST(cv),1);
1733 RETURNOP(CvSTART(cv));
1747 register PERL_CONTEXT *cx;
1748 I32 gimme = GIMME_V;
1750 U32 cxtype = CXt_LOOP;
1758 if (PL_op->op_targ) {
1759 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1760 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1761 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1762 SVs_PADSTALE, SVs_PADSTALE);
1764 #ifndef USE_ITHREADS
1765 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1768 SAVEPADSV(PL_op->op_targ);
1769 iterdata = INT2PTR(void*, PL_op->op_targ);
1770 cxtype |= CXp_PADVAR;
1775 svp = &GvSV(gv); /* symbol table variable */
1776 SAVEGENERICSV(*svp);
1779 iterdata = (void*)gv;
1785 PUSHBLOCK(cx, cxtype, SP);
1787 PUSHLOOP(cx, iterdata, MARK);
1789 PUSHLOOP(cx, svp, MARK);
1791 if (PL_op->op_flags & OPf_STACKED) {
1792 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1793 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1795 SV *right = (SV*)cx->blk_loop.iterary;
1796 if (RANGE_IS_NUMERIC(sv,right)) {
1797 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1798 (SvOK(right) && SvNV(right) >= IV_MAX))
1799 DIE(aTHX_ "Range iterator outside integer range");
1800 cx->blk_loop.iterix = SvIV(sv);
1801 cx->blk_loop.itermax = SvIV(right);
1805 cx->blk_loop.iterlval = newSVsv(sv);
1806 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1807 (void) SvPV(right,n_a);
1812 cx->blk_loop.iterary = PL_curstack;
1813 AvFILLp(PL_curstack) = SP - PL_stack_base;
1814 cx->blk_loop.iterix = MARK - PL_stack_base;
1823 register PERL_CONTEXT *cx;
1824 I32 gimme = GIMME_V;
1830 PUSHBLOCK(cx, CXt_LOOP, SP);
1831 PUSHLOOP(cx, 0, SP);
1839 register PERL_CONTEXT *cx;
1847 newsp = PL_stack_base + cx->blk_loop.resetsp;
1850 if (gimme == G_VOID)
1852 else if (gimme == G_SCALAR) {
1854 *++newsp = sv_mortalcopy(*SP);
1856 *++newsp = &PL_sv_undef;
1860 *++newsp = sv_mortalcopy(*++mark);
1861 TAINT_NOT; /* Each item is independent */
1867 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1868 PL_curpm = newpm; /* ... and pop $1 et al */
1880 register PERL_CONTEXT *cx;
1881 bool popsub2 = FALSE;
1882 bool clear_errsv = FALSE;
1889 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1890 if (cxstack_ix == PL_sortcxix
1891 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1893 if (cxstack_ix > PL_sortcxix)
1894 dounwind(PL_sortcxix);
1895 AvARRAY(PL_curstack)[1] = *SP;
1896 PL_stack_sp = PL_stack_base + 1;
1901 cxix = dopoptosub(cxstack_ix);
1903 DIE(aTHX_ "Can't return outside a subroutine");
1904 if (cxix < cxstack_ix)
1908 switch (CxTYPE(cx)) {
1911 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1914 if (!(PL_in_eval & EVAL_KEEPERR))
1920 if (optype == OP_REQUIRE &&
1921 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1923 /* Unassume the success we assumed earlier. */
1924 SV *nsv = cx->blk_eval.old_namesv;
1925 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1926 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1933 DIE(aTHX_ "panic: return");
1937 if (gimme == G_SCALAR) {
1940 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1942 *++newsp = SvREFCNT_inc(*SP);
1947 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1949 *++newsp = sv_mortalcopy(sv);
1954 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1957 *++newsp = sv_mortalcopy(*SP);
1960 *++newsp = &PL_sv_undef;
1962 else if (gimme == G_ARRAY) {
1963 while (++MARK <= SP) {
1964 *++newsp = (popsub2 && SvTEMP(*MARK))
1965 ? *MARK : sv_mortalcopy(*MARK);
1966 TAINT_NOT; /* Each item is independent */
1969 PL_stack_sp = newsp;
1972 /* Stack values are safe: */
1975 POPSUB(cx,sv); /* release CV and @_ ... */
1979 PL_curpm = newpm; /* ... and pop $1 et al */
1984 return pop_return();
1991 register PERL_CONTEXT *cx;
2001 if (PL_op->op_flags & OPf_SPECIAL) {
2002 cxix = dopoptoloop(cxstack_ix);
2004 DIE(aTHX_ "Can't \"last\" outside a loop block");
2007 cxix = dopoptolabel(cPVOP->op_pv);
2009 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2011 if (cxix < cxstack_ix)
2015 cxstack_ix++; /* temporarily protect top context */
2017 switch (CxTYPE(cx)) {
2020 newsp = PL_stack_base + cx->blk_loop.resetsp;
2021 nextop = cx->blk_loop.last_op->op_next;
2025 nextop = pop_return();
2029 nextop = pop_return();
2033 nextop = pop_return();
2036 DIE(aTHX_ "panic: last");
2040 if (gimme == G_SCALAR) {
2042 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2043 ? *SP : sv_mortalcopy(*SP);
2045 *++newsp = &PL_sv_undef;
2047 else if (gimme == G_ARRAY) {
2048 while (++MARK <= SP) {
2049 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2050 ? *MARK : sv_mortalcopy(*MARK);
2051 TAINT_NOT; /* Each item is independent */
2059 /* Stack values are safe: */
2062 POPLOOP(cx); /* release loop vars ... */
2066 POPSUB(cx,sv); /* release CV and @_ ... */
2069 PL_curpm = newpm; /* ... and pop $1 et al */
2078 register PERL_CONTEXT *cx;
2081 if (PL_op->op_flags & OPf_SPECIAL) {
2082 cxix = dopoptoloop(cxstack_ix);
2084 DIE(aTHX_ "Can't \"next\" outside a loop block");
2087 cxix = dopoptolabel(cPVOP->op_pv);
2089 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2091 if (cxix < cxstack_ix)
2094 /* clear off anything above the scope we're re-entering, but
2095 * save the rest until after a possible continue block */
2096 inner = PL_scopestack_ix;
2098 if (PL_scopestack_ix < inner)
2099 leave_scope(PL_scopestack[PL_scopestack_ix]);
2100 return cx->blk_loop.next_op;
2106 register PERL_CONTEXT *cx;
2109 if (PL_op->op_flags & OPf_SPECIAL) {
2110 cxix = dopoptoloop(cxstack_ix);
2112 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2115 cxix = dopoptolabel(cPVOP->op_pv);
2117 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2119 if (cxix < cxstack_ix)
2123 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2124 LEAVE_SCOPE(oldsave);
2126 return cx->blk_loop.redo_op;
2130 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2134 static char too_deep[] = "Target of goto is too deeply nested";
2137 Perl_croak(aTHX_ too_deep);
2138 if (o->op_type == OP_LEAVE ||
2139 o->op_type == OP_SCOPE ||
2140 o->op_type == OP_LEAVELOOP ||
2141 o->op_type == OP_LEAVESUB ||
2142 o->op_type == OP_LEAVETRY)
2144 *ops++ = cUNOPo->op_first;
2146 Perl_croak(aTHX_ too_deep);
2149 if (o->op_flags & OPf_KIDS) {
2150 /* First try all the kids at this level, since that's likeliest. */
2151 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2152 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2153 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2156 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2157 if (kid == PL_lastgotoprobe)
2159 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2162 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2163 ops[-1]->op_type == OP_DBSTATE)
2168 if ((o = dofindlabel(kid, label, ops, oplimit)))
2187 register PERL_CONTEXT *cx;
2188 #define GOTO_DEPTH 64
2189 OP *enterops[GOTO_DEPTH];
2191 int do_dump = (PL_op->op_type == OP_DUMP);
2192 static char must_have_label[] = "goto must have label";
2196 if (PL_op->op_flags & OPf_STACKED) {
2200 /* This egregious kludge implements goto &subroutine */
2201 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2203 register PERL_CONTEXT *cx;
2204 CV* cv = (CV*)SvRV(sv);
2210 if (!CvROOT(cv) && !CvXSUB(cv)) {
2215 /* autoloaded stub? */
2216 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2218 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2219 GvNAMELEN(gv), FALSE);
2220 if (autogv && (cv = GvCV(autogv)))
2222 tmpstr = sv_newmortal();
2223 gv_efullname3(tmpstr, gv, Nullch);
2224 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2226 DIE(aTHX_ "Goto undefined subroutine");
2229 /* First do some returnish stuff. */
2230 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2232 cxix = dopoptosub(cxstack_ix);
2234 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2235 if (cxix < cxstack_ix)
2239 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2241 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2242 /* put @_ back onto stack */
2243 AV* av = cx->blk_sub.argarray;
2245 items = AvFILLp(av) + 1;
2247 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2248 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2249 PL_stack_sp += items;
2250 SvREFCNT_dec(GvAV(PL_defgv));
2251 GvAV(PL_defgv) = cx->blk_sub.savearray;
2252 /* abandon @_ if it got reified */
2254 oldav = av; /* delay until return */
2256 av_extend(av, items-1);
2257 AvFLAGS(av) = AVf_REIFY;
2258 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2263 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2265 av = GvAV(PL_defgv);
2266 items = AvFILLp(av) + 1;
2268 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2269 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2270 PL_stack_sp += items;
2272 if (CxTYPE(cx) == CXt_SUB &&
2273 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2274 SvREFCNT_dec(cx->blk_sub.cv);
2275 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2276 LEAVE_SCOPE(oldsave);
2278 /* Now do some callish stuff. */
2280 /* For reified @_, delay freeing till return from new sub */
2282 SAVEFREESV((SV*)oldav);
2283 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2285 #ifdef PERL_XSUB_OLDSTYLE
2286 if (CvOLDSTYLE(cv)) {
2287 I32 (*fp3)(int,int,int);
2292 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2293 items = (*fp3)(CvXSUBANY(cv).any_i32,
2294 mark - PL_stack_base + 1,
2296 SP = PL_stack_base + items;
2299 #endif /* PERL_XSUB_OLDSTYLE */
2304 PL_stack_sp--; /* There is no cv arg. */
2305 /* Push a mark for the start of arglist */
2307 (void)(*CvXSUB(cv))(aTHX_ cv);
2308 /* Pop the current context like a decent sub should */
2309 POPBLOCK(cx, PL_curpm);
2310 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2313 return pop_return();
2316 AV* padlist = CvPADLIST(cv);
2317 if (CxTYPE(cx) == CXt_EVAL) {
2318 PL_in_eval = cx->blk_eval.old_in_eval;
2319 PL_eval_root = cx->blk_eval.old_eval_root;
2320 cx->cx_type = CXt_SUB;
2321 cx->blk_sub.hasargs = 0;
2323 cx->blk_sub.cv = cv;
2324 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2327 if (CvDEPTH(cv) < 2)
2328 (void)SvREFCNT_inc(cv);
2330 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2331 sub_crush_depth(cv);
2332 pad_push(padlist, CvDEPTH(cv), 1);
2334 PAD_SET_CUR(padlist, CvDEPTH(cv));
2335 if (cx->blk_sub.hasargs)
2337 AV* av = (AV*)PAD_SVl(0);
2340 cx->blk_sub.savearray = GvAV(PL_defgv);
2341 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2342 CX_CURPAD_SAVE(cx->blk_sub);
2343 cx->blk_sub.argarray = av;
2346 if (items >= AvMAX(av) + 1) {
2348 if (AvARRAY(av) != ary) {
2349 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2350 SvPVX(av) = (char*)ary;
2352 if (items >= AvMAX(av) + 1) {
2353 AvMAX(av) = items - 1;
2354 Renew(ary,items+1,SV*);
2356 SvPVX(av) = (char*)ary;
2359 Copy(mark,AvARRAY(av),items,SV*);
2360 AvFILLp(av) = items - 1;
2361 assert(!AvREAL(av));
2368 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2370 * We do not care about using sv to call CV;
2371 * it's for informational purposes only.
2373 SV *sv = GvSV(PL_DBsub);
2376 if (PERLDB_SUB_NN) {
2377 (void)SvUPGRADE(sv, SVt_PVIV);
2380 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2383 gv_efullname3(sv, CvGV(cv), Nullch);
2386 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2387 PUSHMARK( PL_stack_sp );
2388 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2392 RETURNOP(CvSTART(cv));
2396 label = SvPV(sv,n_a);
2397 if (!(do_dump || *label))
2398 DIE(aTHX_ must_have_label);
2401 else if (PL_op->op_flags & OPf_SPECIAL) {
2403 DIE(aTHX_ must_have_label);
2406 label = cPVOP->op_pv;
2408 if (label && *label) {
2410 bool leaving_eval = FALSE;
2411 bool in_block = FALSE;
2412 PERL_CONTEXT *last_eval_cx = 0;
2416 PL_lastgotoprobe = 0;
2418 for (ix = cxstack_ix; ix >= 0; ix--) {
2420 switch (CxTYPE(cx)) {
2422 leaving_eval = TRUE;
2423 if (!CxTRYBLOCK(cx)) {
2424 gotoprobe = (last_eval_cx ?
2425 last_eval_cx->blk_eval.old_eval_root :
2430 /* else fall through */
2432 gotoprobe = cx->blk_oldcop->op_sibling;
2438 gotoprobe = cx->blk_oldcop->op_sibling;
2441 gotoprobe = PL_main_root;
2444 if (CvDEPTH(cx->blk_sub.cv)) {
2445 gotoprobe = CvROOT(cx->blk_sub.cv);
2451 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2454 DIE(aTHX_ "panic: goto");
2455 gotoprobe = PL_main_root;
2459 retop = dofindlabel(gotoprobe, label,
2460 enterops, enterops + GOTO_DEPTH);
2464 PL_lastgotoprobe = gotoprobe;
2467 DIE(aTHX_ "Can't find label %s", label);
2469 /* if we're leaving an eval, check before we pop any frames
2470 that we're not going to punt, otherwise the error
2473 if (leaving_eval && *enterops && enterops[1]) {
2475 for (i = 1; enterops[i]; i++)
2476 if (enterops[i]->op_type == OP_ENTERITER)
2477 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2480 /* pop unwanted frames */
2482 if (ix < cxstack_ix) {
2489 oldsave = PL_scopestack[PL_scopestack_ix];
2490 LEAVE_SCOPE(oldsave);
2493 /* push wanted frames */
2495 if (*enterops && enterops[1]) {
2497 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2498 for (; enterops[ix]; ix++) {
2499 PL_op = enterops[ix];
2500 /* Eventually we may want to stack the needed arguments
2501 * for each op. For now, we punt on the hard ones. */
2502 if (PL_op->op_type == OP_ENTERITER)
2503 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2504 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2512 if (!retop) retop = PL_main_start;
2514 PL_restartop = retop;
2515 PL_do_undump = TRUE;
2519 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2520 PL_do_undump = FALSE;
2536 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2538 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2541 PL_exit_flags |= PERL_EXIT_EXPECTED;
2543 PUSHs(&PL_sv_undef);
2551 NV value = SvNVx(GvSV(cCOP->cop_gv));
2552 register I32 match = I_32(value);
2555 if (((NV)match) > value)
2556 --match; /* was fractional--truncate other way */
2558 match -= cCOP->uop.scop.scop_offset;
2561 else if (match > cCOP->uop.scop.scop_max)
2562 match = cCOP->uop.scop.scop_max;
2563 PL_op = cCOP->uop.scop.scop_next[match];
2573 PL_op = PL_op->op_next; /* can't assume anything */
2576 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2577 match -= cCOP->uop.scop.scop_offset;
2580 else if (match > cCOP->uop.scop.scop_max)
2581 match = cCOP->uop.scop.scop_max;
2582 PL_op = cCOP->uop.scop.scop_next[match];
2591 S_save_lines(pTHX_ AV *array, SV *sv)
2593 register char *s = SvPVX(sv);
2594 register char *send = SvPVX(sv) + SvCUR(sv);
2596 register I32 line = 1;
2598 while (s && s < send) {
2599 SV *tmpstr = NEWSV(85,0);
2601 sv_upgrade(tmpstr, SVt_PVMG);
2602 t = strchr(s, '\n');
2608 sv_setpvn(tmpstr, s, t - s);
2609 av_store(array, line++, tmpstr);
2614 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2616 S_docatch_body(pTHX_ va_list args)
2618 return docatch_body();
2623 S_docatch_body(pTHX)
2630 S_docatch(pTHX_ OP *o)
2635 volatile PERL_SI *cursi = PL_curstackinfo;
2639 assert(CATCH_GET == TRUE);
2643 /* Normally, the leavetry at the end of this block of ops will
2644 * pop an op off the return stack and continue there. By setting
2645 * the op to Nullop, we force an exit from the inner runops()
2648 retop = pop_return();
2649 push_return(Nullop);
2651 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2653 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2659 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2665 /* die caught by an inner eval - continue inner loop */
2666 if (PL_restartop && cursi == PL_curstackinfo) {
2667 PL_op = PL_restartop;
2671 /* a die in this eval - continue in outer loop */
2687 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2688 /* sv Text to convert to OP tree. */
2689 /* startop op_free() this to undo. */
2690 /* code Short string id of the caller. */
2692 dSP; /* Make POPBLOCK work. */
2695 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2699 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2700 char *tmpbuf = tbuf;
2703 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2708 /* switch to eval mode */
2710 if (IN_PERL_COMPILETIME) {
2711 SAVECOPSTASH_FREE(&PL_compiling);
2712 CopSTASH_set(&PL_compiling, PL_curstash);
2714 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2715 SV *sv = sv_newmortal();
2716 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2717 code, (unsigned long)++PL_evalseq,
2718 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2722 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2723 SAVECOPFILE_FREE(&PL_compiling);
2724 CopFILE_set(&PL_compiling, tmpbuf+2);
2725 SAVECOPLINE(&PL_compiling);
2726 CopLINE_set(&PL_compiling, 1);
2727 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2728 deleting the eval's FILEGV from the stash before gv_check() runs
2729 (i.e. before run-time proper). To work around the coredump that
2730 ensues, we always turn GvMULTI_on for any globals that were
2731 introduced within evals. See force_ident(). GSAR 96-10-12 */
2732 safestr = savepv(tmpbuf);
2733 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2735 #ifdef OP_IN_REGISTER
2741 /* we get here either during compilation, or via pp_regcomp at runtime */
2742 runtime = IN_PERL_RUNTIME;
2744 runcv = find_runcv(NULL);
2747 PL_op->op_type = OP_ENTEREVAL;
2748 PL_op->op_flags = 0; /* Avoid uninit warning. */
2749 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2750 PUSHEVAL(cx, 0, Nullgv);
2753 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2755 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2756 POPBLOCK(cx,PL_curpm);
2759 (*startop)->op_type = OP_NULL;
2760 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2762 /* XXX DAPM do this properly one year */
2763 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2765 if (IN_PERL_COMPILETIME)
2766 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2767 #ifdef OP_IN_REGISTER
2775 =for apidoc find_runcv
2777 Locate the CV corresponding to the currently executing sub or eval.
2778 If db_seqp is non_null, skip CVs that are in the DB package and populate
2779 *db_seqp with the cop sequence number at the point that the DB:: code was
2780 entered. (allows debuggers to eval in the scope of the breakpoint rather
2781 than in in the scope of the debugger itself).
2787 Perl_find_runcv(pTHX_ U32 *db_seqp)
2794 *db_seqp = PL_curcop->cop_seq;
2795 for (si = PL_curstackinfo; si; si = si->si_prev) {
2796 for (ix = si->si_cxix; ix >= 0; ix--) {
2797 cx = &(si->si_cxstack[ix]);
2798 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2799 CV *cv = cx->blk_sub.cv;
2800 /* skip DB:: code */
2801 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2802 *db_seqp = cx->blk_oldcop->cop_seq;
2807 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2815 /* Compile a require/do, an eval '', or a /(?{...})/.
2816 * In the last case, startop is non-null, and contains the address of
2817 * a pointer that should be set to the just-compiled code.
2818 * outside is the lexically enclosing CV (if any) that invoked us.
2821 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2823 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2828 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2829 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2834 SAVESPTR(PL_compcv);
2835 PL_compcv = (CV*)NEWSV(1104,0);
2836 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2837 CvEVAL_on(PL_compcv);
2838 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2839 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2841 CvOUTSIDE_SEQ(PL_compcv) = seq;
2842 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2844 /* set up a scratch pad */
2846 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2849 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2851 /* make sure we compile in the right package */
2853 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2854 SAVESPTR(PL_curstash);
2855 PL_curstash = CopSTASH(PL_curcop);
2857 SAVESPTR(PL_beginav);
2858 PL_beginav = newAV();
2859 SAVEFREESV(PL_beginav);
2860 SAVEI32(PL_error_count);
2862 /* try to compile it */
2864 PL_eval_root = Nullop;
2866 PL_curcop = &PL_compiling;
2867 PL_curcop->cop_arybase = 0;
2868 if (saveop && saveop->op_flags & OPf_SPECIAL)
2869 PL_in_eval |= EVAL_KEEPERR;
2872 if (yyparse() || PL_error_count || !PL_eval_root) {
2873 SV **newsp; /* Used by POPBLOCK. */
2874 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2875 I32 optype = 0; /* Might be reset by POPEVAL. */
2880 op_free(PL_eval_root);
2881 PL_eval_root = Nullop;
2883 SP = PL_stack_base + POPMARK; /* pop original mark */
2885 POPBLOCK(cx,PL_curpm);
2891 if (optype == OP_REQUIRE) {
2892 char* msg = SvPVx(ERRSV, n_a);
2893 SV *nsv = cx->blk_eval.old_namesv;
2894 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2896 DIE(aTHX_ "%sCompilation failed in require",
2897 *msg ? msg : "Unknown error\n");
2900 char* msg = SvPVx(ERRSV, n_a);
2902 POPBLOCK(cx,PL_curpm);
2904 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2905 (*msg ? msg : "Unknown error\n"));
2908 char* msg = SvPVx(ERRSV, n_a);
2910 sv_setpv(ERRSV, "Compilation error");
2915 CopLINE_set(&PL_compiling, 0);
2917 *startop = PL_eval_root;
2919 SAVEFREEOP(PL_eval_root);
2921 /* Set the context for this new optree.
2922 * If the last op is an OP_REQUIRE, force scalar context.
2923 * Otherwise, propagate the context from the eval(). */
2924 if (PL_eval_root->op_type == OP_LEAVEEVAL
2925 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2926 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2928 scalar(PL_eval_root);
2929 else if (gimme & G_VOID)
2930 scalarvoid(PL_eval_root);
2931 else if (gimme & G_ARRAY)
2934 scalar(PL_eval_root);
2936 DEBUG_x(dump_eval());
2938 /* Register with debugger: */
2939 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2940 CV *cv = get_cv("DB::postponed", FALSE);
2944 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2946 call_sv((SV*)cv, G_DISCARD);
2950 /* compiled okay, so do it */
2952 CvDEPTH(PL_compcv) = 1;
2953 SP = PL_stack_base + POPMARK; /* pop original mark */
2954 PL_op = saveop; /* The caller may need it. */
2955 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2957 RETURNOP(PL_eval_start);
2961 S_doopen_pm(pTHX_ const char *name, const char *mode)
2963 #ifndef PERL_DISABLE_PMC
2964 STRLEN namelen = strlen(name);
2967 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2968 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2969 char *pmc = SvPV_nolen(pmcsv);
2972 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2973 fp = PerlIO_open(name, mode);
2976 if (PerlLIO_stat(name, &pmstat) < 0 ||
2977 pmstat.st_mtime < pmcstat.st_mtime)
2979 fp = PerlIO_open(pmc, mode);
2982 fp = PerlIO_open(name, mode);
2985 SvREFCNT_dec(pmcsv);
2988 fp = PerlIO_open(name, mode);
2992 return PerlIO_open(name, mode);
2993 #endif /* !PERL_DISABLE_PMC */
2999 register PERL_CONTEXT *cx;
3003 char *tryname = Nullch;
3004 SV *namesv = Nullsv;
3006 I32 gimme = GIMME_V;
3007 PerlIO *tryrsfp = 0;
3009 int filter_has_file = 0;
3010 GV *filter_child_proc = 0;
3011 SV *filter_state = 0;
3018 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
3019 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3020 UV rev = 0, ver = 0, sver = 0;
3022 U8 *s = (U8*)SvPVX(sv);
3023 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3025 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3028 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3031 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3034 if (PERL_REVISION < rev
3035 || (PERL_REVISION == rev
3036 && (PERL_VERSION < ver
3037 || (PERL_VERSION == ver
3038 && PERL_SUBVERSION < sver))))
3040 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3041 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3042 PERL_VERSION, PERL_SUBVERSION);
3044 if (ckWARN(WARN_PORTABLE))
3045 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3046 "v-string in use/require non-portable");
3049 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3050 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3051 + ((NV)PERL_SUBVERSION/(NV)1000000)
3052 + 0.00000099 < SvNV(sv))
3056 NV nver = (nrev - rev) * 1000;
3057 UV ver = (UV)(nver + 0.0009);
3058 NV nsver = (nver - ver) * 1000;
3059 UV sver = (UV)(nsver + 0.0009);
3061 /* help out with the "use 5.6" confusion */
3062 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3063 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3064 " (did you mean v%"UVuf".%03"UVuf"?)--"
3065 "this is only v%d.%d.%d, stopped",
3066 rev, ver, sver, rev, ver/100,
3067 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3070 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3071 "this is only v%d.%d.%d, stopped",
3072 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3079 name = SvPV(sv, len);
3080 if (!(name && len > 0 && *name))
3081 DIE(aTHX_ "Null filename used");
3082 TAINT_PROPER("require");
3083 if (PL_op->op_type == OP_REQUIRE &&
3084 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3085 if (*svp != &PL_sv_undef)
3088 DIE(aTHX_ "Compilation failed in require");
3091 /* prepare to compile file */
3093 if (path_is_absolute(name)) {
3095 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3097 #ifdef MACOS_TRADITIONAL
3101 MacPerl_CanonDir(name, newname, 1);
3102 if (path_is_absolute(newname)) {
3104 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3109 AV *ar = GvAVn(PL_incgv);
3113 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3116 namesv = NEWSV(806, 0);
3117 for (i = 0; i <= AvFILL(ar); i++) {
3118 SV *dirsv = *av_fetch(ar, i, TRUE);
3124 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3125 && !sv_isobject(loader))
3127 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3130 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3131 PTR2UV(SvRV(dirsv)), name);
3132 tryname = SvPVX(namesv);
3143 if (sv_isobject(loader))
3144 count = call_method("INC", G_ARRAY);
3146 count = call_sv(loader, G_ARRAY);
3156 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3160 if (SvTYPE(arg) == SVt_PVGV) {
3161 IO *io = GvIO((GV *)arg);
3166 tryrsfp = IoIFP(io);
3167 if (IoTYPE(io) == IoTYPE_PIPE) {
3168 /* reading from a child process doesn't
3169 nest -- when returning from reading
3170 the inner module, the outer one is
3171 unreadable (closed?) I've tried to
3172 save the gv to manage the lifespan of
3173 the pipe, but this didn't help. XXX */
3174 filter_child_proc = (GV *)arg;
3175 (void)SvREFCNT_inc(filter_child_proc);
3178 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3179 PerlIO_close(IoOFP(io));
3191 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3193 (void)SvREFCNT_inc(filter_sub);
3196 filter_state = SP[i];
3197 (void)SvREFCNT_inc(filter_state);
3201 tryrsfp = PerlIO_open("/dev/null",
3217 filter_has_file = 0;
3218 if (filter_child_proc) {
3219 SvREFCNT_dec(filter_child_proc);
3220 filter_child_proc = 0;
3223 SvREFCNT_dec(filter_state);
3227 SvREFCNT_dec(filter_sub);
3232 if (!path_is_absolute(name)
3233 #ifdef MACOS_TRADITIONAL
3234 /* We consider paths of the form :a:b ambiguous and interpret them first
3235 as global then as local
3237 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3240 char *dir = SvPVx(dirsv, n_a);
3241 #ifdef MACOS_TRADITIONAL
3245 MacPerl_CanonDir(name, buf2, 1);
3246 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3250 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3252 sv_setpv(namesv, unixdir);
3253 sv_catpv(namesv, unixname);
3255 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3258 TAINT_PROPER("require");
3259 tryname = SvPVX(namesv);
3260 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3262 if (tryname[0] == '.' && tryname[1] == '/')
3271 SAVECOPFILE_FREE(&PL_compiling);
3272 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3273 SvREFCNT_dec(namesv);
3275 if (PL_op->op_type == OP_REQUIRE) {
3276 char *msgstr = name;
3277 if (namesv) { /* did we lookup @INC? */
3278 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3279 SV *dirmsgsv = NEWSV(0, 0);
3280 AV *ar = GvAVn(PL_incgv);
3282 sv_catpvn(msg, " in @INC", 8);
3283 if (instr(SvPVX(msg), ".h "))
3284 sv_catpv(msg, " (change .h to .ph maybe?)");
3285 if (instr(SvPVX(msg), ".ph "))
3286 sv_catpv(msg, " (did you run h2ph?)");
3287 sv_catpv(msg, " (@INC contains:");
3288 for (i = 0; i <= AvFILL(ar); i++) {
3289 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3290 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3291 sv_catsv(msg, dirmsgsv);
3293 sv_catpvn(msg, ")", 1);
3294 SvREFCNT_dec(dirmsgsv);
3295 msgstr = SvPV_nolen(msg);
3297 DIE(aTHX_ "Can't locate %s", msgstr);
3303 SETERRNO(0, SS_NORMAL);
3305 /* Assume success here to prevent recursive requirement. */
3307 /* Check whether a hook in @INC has already filled %INC */
3308 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3309 (void)hv_store(GvHVn(PL_incgv), name, len,
3310 (hook_sv ? SvREFCNT_inc(hook_sv)
3311 : newSVpv(CopFILE(&PL_compiling), 0)),
3317 lex_start(sv_2mortal(newSVpvn("",0)));
3318 SAVEGENERICSV(PL_rsfp_filters);
3319 PL_rsfp_filters = Nullav;
3324 SAVESPTR(PL_compiling.cop_warnings);
3325 if (PL_dowarn & G_WARN_ALL_ON)
3326 PL_compiling.cop_warnings = pWARN_ALL ;
3327 else if (PL_dowarn & G_WARN_ALL_OFF)
3328 PL_compiling.cop_warnings = pWARN_NONE ;
3329 else if (PL_taint_warn)
3330 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3332 PL_compiling.cop_warnings = pWARN_STD ;
3333 SAVESPTR(PL_compiling.cop_io);
3334 PL_compiling.cop_io = Nullsv;
3336 if (filter_sub || filter_child_proc) {
3337 SV *datasv = filter_add(run_user_filter, Nullsv);
3338 IoLINES(datasv) = filter_has_file;
3339 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3340 IoTOP_GV(datasv) = (GV *)filter_state;
3341 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3344 /* switch to eval mode */
3345 push_return(PL_op->op_next);
3346 PUSHBLOCK(cx, CXt_EVAL, SP);
3347 PUSHEVAL(cx, name, Nullgv);
3349 SAVECOPLINE(&PL_compiling);
3350 CopLINE_set(&PL_compiling, 0);
3354 /* Store and reset encoding. */
3355 encoding = PL_encoding;
3356 PL_encoding = Nullsv;
3358 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3360 /* Restore encoding. */
3361 PL_encoding = encoding;
3368 return pp_require();
3374 register PERL_CONTEXT *cx;
3376 I32 gimme = GIMME_V, was = PL_sub_generation;
3377 char tbuf[TYPE_DIGITS(long) + 12];
3378 char *tmpbuf = tbuf;
3387 TAINT_PROPER("eval");
3393 /* switch to eval mode */
3395 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3396 SV *sv = sv_newmortal();
3397 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3398 (unsigned long)++PL_evalseq,
3399 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3403 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3404 SAVECOPFILE_FREE(&PL_compiling);
3405 CopFILE_set(&PL_compiling, tmpbuf+2);
3406 SAVECOPLINE(&PL_compiling);
3407 CopLINE_set(&PL_compiling, 1);
3408 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3409 deleting the eval's FILEGV from the stash before gv_check() runs
3410 (i.e. before run-time proper). To work around the coredump that
3411 ensues, we always turn GvMULTI_on for any globals that were
3412 introduced within evals. See force_ident(). GSAR 96-10-12 */
3413 safestr = savepv(tmpbuf);
3414 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3416 PL_hints = PL_op->op_targ;
3417 SAVESPTR(PL_compiling.cop_warnings);
3418 if (specialWARN(PL_curcop->cop_warnings))
3419 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3421 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3422 SAVEFREESV(PL_compiling.cop_warnings);
3424 SAVESPTR(PL_compiling.cop_io);
3425 if (specialCopIO(PL_curcop->cop_io))
3426 PL_compiling.cop_io = PL_curcop->cop_io;
3428 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3429 SAVEFREESV(PL_compiling.cop_io);
3431 /* special case: an eval '' executed within the DB package gets lexically
3432 * placed in the first non-DB CV rather than the current CV - this
3433 * allows the debugger to execute code, find lexicals etc, in the
3434 * scope of the code being debugged. Passing &seq gets find_runcv
3435 * to do the dirty work for us */
3436 runcv = find_runcv(&seq);
3438 push_return(PL_op->op_next);
3439 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3440 PUSHEVAL(cx, 0, Nullgv);
3442 /* prepare to compile string */
3444 if (PERLDB_LINE && PL_curstash != PL_debstash)
3445 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3447 ret = doeval(gimme, NULL, runcv, seq);
3448 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3449 && ret != PL_op->op_next) { /* Successive compilation. */
3450 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3452 return DOCATCH(ret);
3462 register PERL_CONTEXT *cx;
3464 U8 save_flags = PL_op -> op_flags;
3469 retop = pop_return();
3472 if (gimme == G_VOID)
3474 else if (gimme == G_SCALAR) {
3477 if (SvFLAGS(TOPs) & SVs_TEMP)
3480 *MARK = sv_mortalcopy(TOPs);
3484 *MARK = &PL_sv_undef;
3489 /* in case LEAVE wipes old return values */
3490 for (mark = newsp + 1; mark <= SP; mark++) {
3491 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3492 *mark = sv_mortalcopy(*mark);
3493 TAINT_NOT; /* Each item is independent */
3497 PL_curpm = newpm; /* Don't pop $1 et al till now */
3500 assert(CvDEPTH(PL_compcv) == 1);
3502 CvDEPTH(PL_compcv) = 0;
3505 if (optype == OP_REQUIRE &&
3506 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3508 /* Unassume the success we assumed earlier. */
3509 SV *nsv = cx->blk_eval.old_namesv;
3510 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3511 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3512 /* die_where() did LEAVE, or we won't be here */
3516 if (!(save_flags & OPf_SPECIAL))
3526 register PERL_CONTEXT *cx;
3527 I32 gimme = GIMME_V;
3532 push_return(cLOGOP->op_other->op_next);
3533 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3536 PL_in_eval = EVAL_INEVAL;
3539 return DOCATCH(PL_op->op_next);
3550 register PERL_CONTEXT *cx;
3555 retop = pop_return();
3558 if (gimme == G_VOID)
3560 else if (gimme == G_SCALAR) {
3563 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3566 *MARK = sv_mortalcopy(TOPs);
3570 *MARK = &PL_sv_undef;
3575 /* in case LEAVE wipes old return values */
3576 for (mark = newsp + 1; mark <= SP; mark++) {
3577 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3578 *mark = sv_mortalcopy(*mark);
3579 TAINT_NOT; /* Each item is independent */
3583 PL_curpm = newpm; /* Don't pop $1 et al till now */
3591 S_doparseform(pTHX_ SV *sv)
3594 register char *s = SvPV_force(sv, len);
3595 register char *send = s + len;
3596 register char *base = Nullch;
3597 register I32 skipspaces = 0;
3598 bool noblank = FALSE;
3599 bool repeat = FALSE;
3600 bool postspace = FALSE;
3606 bool unchopnum = FALSE;
3607 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3610 Perl_croak(aTHX_ "Null picture in formline");
3612 /* estimate the buffer size needed */
3613 for (base = s; s <= send; s++) {
3614 if (*s == '\n' || *s == '@' || *s == '^')
3620 New(804, fops, maxops, U32);
3625 *fpc++ = FF_LINEMARK;
3626 noblank = repeat = FALSE;
3644 case ' ': case '\t':
3651 } /* else FALL THROUGH */
3659 *fpc++ = FF_LITERAL;
3667 *fpc++ = (U16)skipspaces;
3671 *fpc++ = FF_NEWLINE;
3675 arg = fpc - linepc + 1;
3682 *fpc++ = FF_LINEMARK;
3683 noblank = repeat = FALSE;
3692 ischop = s[-1] == '^';
3698 arg = (s - base) - 1;
3700 *fpc++ = FF_LITERAL;
3708 *fpc++ = 2; /* skip the @* or ^* */
3710 *fpc++ = FF_LINESNGL;
3713 *fpc++ = FF_LINEGLOB;
3715 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3716 arg = ischop ? 512 : 0;
3726 arg |= 256 + (s - f);
3728 *fpc++ = s - base; /* fieldsize for FETCH */
3729 *fpc++ = FF_DECIMAL;
3731 unchopnum |= ! ischop;
3733 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3734 arg = ischop ? 512 : 0;
3736 s++; /* skip the '0' first */
3745 arg |= 256 + (s - f);
3747 *fpc++ = s - base; /* fieldsize for FETCH */
3748 *fpc++ = FF_0DECIMAL;
3750 unchopnum |= ! ischop;
3754 bool ismore = FALSE;
3757 while (*++s == '>') ;
3758 prespace = FF_SPACE;
3760 else if (*s == '|') {
3761 while (*++s == '|') ;
3762 prespace = FF_HALFSPACE;
3767 while (*++s == '<') ;
3770 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3774 *fpc++ = s - base; /* fieldsize for FETCH */
3776 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3779 *fpc++ = (U16)prespace;
3793 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3795 { /* need to jump to the next word */
3797 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3798 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3799 s = SvPVX(sv) + SvCUR(sv) + z;
3801 Copy(fops, s, arg, U32);
3803 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3806 if (unchopnum && repeat)
3807 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3813 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3815 /* Can value be printed in fldsize chars, using %*.*f ? */
3819 int intsize = fldsize - (value < 0 ? 1 : 0);
3826 while (intsize--) pwr *= 10.0;
3827 while (frcsize--) eps /= 10.0;
3830 if (value + eps >= pwr)
3833 if (value - eps <= -pwr)
3840 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3842 SV *datasv = FILTER_DATA(idx);
3843 int filter_has_file = IoLINES(datasv);
3844 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3845 SV *filter_state = (SV *)IoTOP_GV(datasv);
3846 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3849 /* I was having segfault trouble under Linux 2.2.5 after a
3850 parse error occured. (Had to hack around it with a test
3851 for PL_error_count == 0.) Solaris doesn't segfault --
3852 not sure where the trouble is yet. XXX */
3854 if (filter_has_file) {
3855 len = FILTER_READ(idx+1, buf_sv, maxlen);
3858 if (filter_sub && len >= 0) {
3869 PUSHs(sv_2mortal(newSViv(maxlen)));
3871 PUSHs(filter_state);
3874 count = call_sv(filter_sub, G_SCALAR);
3890 IoLINES(datasv) = 0;
3891 if (filter_child_proc) {
3892 SvREFCNT_dec(filter_child_proc);
3893 IoFMT_GV(datasv) = Nullgv;
3896 SvREFCNT_dec(filter_state);
3897 IoTOP_GV(datasv) = Nullgv;
3900 SvREFCNT_dec(filter_sub);
3901 IoBOTTOM_GV(datasv) = Nullgv;
3903 filter_del(run_user_filter);
3909 /* perhaps someone can come up with a better name for
3910 this? it is not really "absolute", per se ... */
3912 S_path_is_absolute(pTHX_ char *name)
3914 if (PERL_FILE_IS_ABSOLUTE(name)
3915 #ifdef MACOS_TRADITIONAL
3918 || (*name == '.' && (name[1] == '/' ||
3919 (name[1] == '.' && name[2] == '/'))))