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;
943 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
945 LEAVE; /* exit inner scope */
948 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
950 (void)POPMARK; /* pop top */
951 LEAVE; /* exit outer scope */
952 (void)POPMARK; /* pop src */
953 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
954 (void)POPMARK; /* pop dst */
955 SP = PL_stack_base + POPMARK; /* pop original mark */
956 if (gimme == G_SCALAR) {
957 if (PL_op->op_private & OPpGREP_LEX) {
958 SV* sv = sv_newmortal();
967 else if (gimme == G_ARRAY)
974 ENTER; /* enter inner scope */
977 /* set $_ to the new source item */
978 src = PL_stack_base[PL_markstack_ptr[-1]];
980 if (PL_op->op_private & OPpGREP_LEX)
981 PAD_SVl(PL_op->op_targ) = src;
985 RETURNOP(cLOGOP->op_other);
993 if (GIMME == G_ARRAY)
995 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
996 return cLOGOP->op_other;
1005 if (GIMME == G_ARRAY) {
1006 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1010 SV *targ = PAD_SV(PL_op->op_targ);
1013 if (PL_op->op_private & OPpFLIP_LINENUM) {
1014 if (GvIO(PL_last_in_gv)) {
1015 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1018 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1019 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1025 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1026 if (PL_op->op_flags & OPf_SPECIAL) {
1034 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1043 /* This code tries to decide if "$left .. $right" should use the
1044 magical string increment, or if the range is numeric (we make
1045 an exception for .."0" [#18165]). AMS 20021031. */
1047 #define RANGE_IS_NUMERIC(left,right) ( \
1048 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1049 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1050 (looks_like_number(left) && SvPOKp(left) && *SvPVX(left) != '0' && \
1051 looks_like_number(right)))
1057 if (GIMME == G_ARRAY) {
1063 if (SvGMAGICAL(left))
1065 if (SvGMAGICAL(right))
1068 if (RANGE_IS_NUMERIC(left,right)) {
1069 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1070 DIE(aTHX_ "Range iterator outside integer range");
1081 sv = sv_2mortal(newSViv(i++));
1086 SV *final = sv_mortalcopy(right);
1088 char *tmps = SvPV(final, len);
1090 sv = sv_mortalcopy(left);
1092 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1094 if (strEQ(SvPVX(sv),tmps))
1096 sv = sv_2mortal(newSVsv(sv));
1103 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1107 if (PL_op->op_private & OPpFLIP_LINENUM) {
1108 if (GvIO(PL_last_in_gv)) {
1109 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1112 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1113 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1121 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1122 sv_catpv(targ, "E0");
1132 static char *context_name[] = {
1143 S_dopoptolabel(pTHX_ char *label)
1146 register PERL_CONTEXT *cx;
1148 for (i = cxstack_ix; i >= 0; i--) {
1150 switch (CxTYPE(cx)) {
1156 if (ckWARN(WARN_EXITING))
1157 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1158 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1159 if (CxTYPE(cx) == CXt_NULL)
1163 if (!cx->blk_loop.label ||
1164 strNE(label, cx->blk_loop.label) ) {
1165 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1166 (long)i, cx->blk_loop.label));
1169 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1177 Perl_dowantarray(pTHX)
1179 I32 gimme = block_gimme();
1180 return (gimme == G_VOID) ? G_SCALAR : gimme;
1184 Perl_block_gimme(pTHX)
1188 cxix = dopoptosub(cxstack_ix);
1192 switch (cxstack[cxix].blk_gimme) {
1200 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1207 Perl_is_lvalue_sub(pTHX)
1211 cxix = dopoptosub(cxstack_ix);
1212 assert(cxix >= 0); /* We should only be called from inside subs */
1214 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1215 return cxstack[cxix].blk_sub.lval;
1221 S_dopoptosub(pTHX_ I32 startingblock)
1223 return dopoptosub_at(cxstack, startingblock);
1227 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1230 register PERL_CONTEXT *cx;
1231 for (i = startingblock; i >= 0; i--) {
1233 switch (CxTYPE(cx)) {
1239 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1247 S_dopoptoeval(pTHX_ I32 startingblock)
1250 register PERL_CONTEXT *cx;
1251 for (i = startingblock; i >= 0; i--) {
1253 switch (CxTYPE(cx)) {
1257 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1265 S_dopoptoloop(pTHX_ I32 startingblock)
1268 register PERL_CONTEXT *cx;
1269 for (i = startingblock; i >= 0; i--) {
1271 switch (CxTYPE(cx)) {
1277 if (ckWARN(WARN_EXITING))
1278 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1279 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1280 if ((CxTYPE(cx)) == CXt_NULL)
1284 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1292 Perl_dounwind(pTHX_ I32 cxix)
1294 register PERL_CONTEXT *cx;
1297 while (cxstack_ix > cxix) {
1299 cx = &cxstack[cxstack_ix];
1300 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1301 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1302 /* Note: we don't need to restore the base context info till the end. */
1303 switch (CxTYPE(cx)) {
1306 continue; /* not break */
1328 Perl_qerror(pTHX_ SV *err)
1331 sv_catsv(ERRSV, err);
1333 sv_catsv(PL_errors, err);
1335 Perl_warn(aTHX_ "%"SVf, err);
1340 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1346 register PERL_CONTEXT *cx;
1351 if (PL_in_eval & EVAL_KEEPERR) {
1352 static char prefix[] = "\t(in cleanup) ";
1357 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1360 if (*e != *message || strNE(e,message))
1364 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1365 sv_catpvn(err, prefix, sizeof(prefix)-1);
1366 sv_catpvn(err, message, msglen);
1367 if (ckWARN(WARN_MISC)) {
1368 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1369 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1374 sv_setpvn(ERRSV, message, msglen);
1378 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1379 && PL_curstackinfo->si_prev)
1388 if (cxix < cxstack_ix)
1391 POPBLOCK(cx,PL_curpm);
1392 if (CxTYPE(cx) != CXt_EVAL) {
1394 message = SvPVx(ERRSV, msglen);
1395 PerlIO_write(Perl_error_log, "panic: die ", 11);
1396 PerlIO_write(Perl_error_log, message, msglen);
1401 if (gimme == G_SCALAR)
1402 *++newsp = &PL_sv_undef;
1403 PL_stack_sp = newsp;
1407 /* LEAVE could clobber PL_curcop (see save_re_context())
1408 * XXX it might be better to find a way to avoid messing with
1409 * PL_curcop in save_re_context() instead, but this is a more
1410 * minimal fix --GSAR */
1411 PL_curcop = cx->blk_oldcop;
1413 if (optype == OP_REQUIRE) {
1414 char* msg = SvPVx(ERRSV, n_a);
1415 SV *nsv = cx->blk_eval.old_namesv;
1416 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1418 DIE(aTHX_ "%sCompilation failed in require",
1419 *msg ? msg : "Unknown error\n");
1421 return pop_return();
1425 message = SvPVx(ERRSV, msglen);
1427 write_to_stderr(message, msglen);
1436 if (SvTRUE(left) != SvTRUE(right))
1448 RETURNOP(cLOGOP->op_other);
1457 RETURNOP(cLOGOP->op_other);
1466 if (!sv || !SvANY(sv)) {
1467 RETURNOP(cLOGOP->op_other);
1470 switch (SvTYPE(sv)) {
1472 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1476 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1480 if (CvROOT(sv) || CvXSUB(sv))
1490 RETURNOP(cLOGOP->op_other);
1496 register I32 cxix = dopoptosub(cxstack_ix);
1497 register PERL_CONTEXT *cx;
1498 register PERL_CONTEXT *ccstack = cxstack;
1499 PERL_SI *top_si = PL_curstackinfo;
1510 /* we may be in a higher stacklevel, so dig down deeper */
1511 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1512 top_si = top_si->si_prev;
1513 ccstack = top_si->si_cxstack;
1514 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1517 if (GIMME != G_ARRAY) {
1523 if (PL_DBsub && cxix >= 0 &&
1524 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1528 cxix = dopoptosub_at(ccstack, cxix - 1);
1531 cx = &ccstack[cxix];
1532 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1533 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1534 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1535 field below is defined for any cx. */
1536 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1537 cx = &ccstack[dbcxix];
1540 stashname = CopSTASHPV(cx->blk_oldcop);
1541 if (GIMME != G_ARRAY) {
1544 PUSHs(&PL_sv_undef);
1547 sv_setpv(TARG, stashname);
1556 PUSHs(&PL_sv_undef);
1558 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1559 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1560 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1563 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1565 /* So is ccstack[dbcxix]. */
1568 gv_efullname3(sv, cvgv, Nullch);
1569 PUSHs(sv_2mortal(sv));
1570 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1573 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1574 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1578 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1579 PUSHs(sv_2mortal(newSViv(0)));
1581 gimme = (I32)cx->blk_gimme;
1582 if (gimme == G_VOID)
1583 PUSHs(&PL_sv_undef);
1585 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1586 if (CxTYPE(cx) == CXt_EVAL) {
1588 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1589 PUSHs(cx->blk_eval.cur_text);
1593 else if (cx->blk_eval.old_namesv) {
1594 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1597 /* eval BLOCK (try blocks have old_namesv == 0) */
1599 PUSHs(&PL_sv_undef);
1600 PUSHs(&PL_sv_undef);
1604 PUSHs(&PL_sv_undef);
1605 PUSHs(&PL_sv_undef);
1607 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1608 && CopSTASH_eq(PL_curcop, PL_debstash))
1610 AV *ary = cx->blk_sub.argarray;
1611 int off = AvARRAY(ary) - AvALLOC(ary);
1615 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1618 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1621 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1622 av_extend(PL_dbargs, AvFILLp(ary) + off);
1623 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1624 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1626 /* XXX only hints propagated via op_private are currently
1627 * visible (others are not easily accessible, since they
1628 * use the global PL_hints) */
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1630 HINT_PRIVATE_MASK)));
1633 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1635 if (old_warnings == pWARN_NONE ||
1636 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1637 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1638 else if (old_warnings == pWARN_ALL ||
1639 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1640 /* Get the bit mask for $warnings::Bits{all}, because
1641 * it could have been extended by warnings::register */
1643 HV *bits = get_hv("warnings::Bits", FALSE);
1644 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1645 mask = newSVsv(*bits_all);
1648 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1652 mask = newSVsv(old_warnings);
1653 PUSHs(sv_2mortal(mask));
1668 sv_reset(tmps, CopSTASH(PL_curcop));
1678 /* like pp_nextstate, but used instead when the debugger is active */
1682 PL_curcop = (COP*)PL_op;
1683 TAINT_NOT; /* Each statement is presumed innocent */
1684 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1687 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1688 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1692 register PERL_CONTEXT *cx;
1693 I32 gimme = G_ARRAY;
1700 DIE(aTHX_ "No DB::DB routine defined");
1702 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1703 /* don't do recursive DB::DB call */
1715 push_return(PL_op->op_next);
1716 PUSHBLOCK(cx, CXt_SUB, SP);
1719 PAD_SET_CUR(CvPADLIST(cv),1);
1720 RETURNOP(CvSTART(cv));
1734 register PERL_CONTEXT *cx;
1735 I32 gimme = GIMME_V;
1737 U32 cxtype = CXt_LOOP;
1745 if (PL_op->op_targ) {
1746 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1747 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1748 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1749 SVs_PADSTALE, SVs_PADSTALE);
1751 #ifndef USE_ITHREADS
1752 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1755 SAVEPADSV(PL_op->op_targ);
1756 iterdata = INT2PTR(void*, PL_op->op_targ);
1757 cxtype |= CXp_PADVAR;
1762 svp = &GvSV(gv); /* symbol table variable */
1763 SAVEGENERICSV(*svp);
1766 iterdata = (void*)gv;
1772 PUSHBLOCK(cx, cxtype, SP);
1774 PUSHLOOP(cx, iterdata, MARK);
1776 PUSHLOOP(cx, svp, MARK);
1778 if (PL_op->op_flags & OPf_STACKED) {
1779 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1780 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1782 if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
1783 if (SvNV(sv) < IV_MIN ||
1784 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1785 DIE(aTHX_ "Range iterator outside integer range");
1786 cx->blk_loop.iterix = SvIV(sv);
1787 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1790 cx->blk_loop.iterlval = newSVsv(sv);
1794 cx->blk_loop.iterary = PL_curstack;
1795 AvFILLp(PL_curstack) = SP - PL_stack_base;
1796 cx->blk_loop.iterix = MARK - PL_stack_base;
1805 register PERL_CONTEXT *cx;
1806 I32 gimme = GIMME_V;
1812 PUSHBLOCK(cx, CXt_LOOP, SP);
1813 PUSHLOOP(cx, 0, SP);
1821 register PERL_CONTEXT *cx;
1829 newsp = PL_stack_base + cx->blk_loop.resetsp;
1832 if (gimme == G_VOID)
1834 else if (gimme == G_SCALAR) {
1836 *++newsp = sv_mortalcopy(*SP);
1838 *++newsp = &PL_sv_undef;
1842 *++newsp = sv_mortalcopy(*++mark);
1843 TAINT_NOT; /* Each item is independent */
1849 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1850 PL_curpm = newpm; /* ... and pop $1 et al */
1862 register PERL_CONTEXT *cx;
1863 bool popsub2 = FALSE;
1864 bool clear_errsv = FALSE;
1871 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1872 if (cxstack_ix == PL_sortcxix
1873 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1875 if (cxstack_ix > PL_sortcxix)
1876 dounwind(PL_sortcxix);
1877 AvARRAY(PL_curstack)[1] = *SP;
1878 PL_stack_sp = PL_stack_base + 1;
1883 cxix = dopoptosub(cxstack_ix);
1885 DIE(aTHX_ "Can't return outside a subroutine");
1886 if (cxix < cxstack_ix)
1890 switch (CxTYPE(cx)) {
1893 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1896 if (!(PL_in_eval & EVAL_KEEPERR))
1902 if (optype == OP_REQUIRE &&
1903 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1905 /* Unassume the success we assumed earlier. */
1906 SV *nsv = cx->blk_eval.old_namesv;
1907 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1908 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1915 DIE(aTHX_ "panic: return");
1919 if (gimme == G_SCALAR) {
1922 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1924 *++newsp = SvREFCNT_inc(*SP);
1929 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1931 *++newsp = sv_mortalcopy(sv);
1936 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1939 *++newsp = sv_mortalcopy(*SP);
1942 *++newsp = &PL_sv_undef;
1944 else if (gimme == G_ARRAY) {
1945 while (++MARK <= SP) {
1946 *++newsp = (popsub2 && SvTEMP(*MARK))
1947 ? *MARK : sv_mortalcopy(*MARK);
1948 TAINT_NOT; /* Each item is independent */
1951 PL_stack_sp = newsp;
1954 /* Stack values are safe: */
1957 POPSUB(cx,sv); /* release CV and @_ ... */
1961 PL_curpm = newpm; /* ... and pop $1 et al */
1966 return pop_return();
1973 register PERL_CONTEXT *cx;
1983 if (PL_op->op_flags & OPf_SPECIAL) {
1984 cxix = dopoptoloop(cxstack_ix);
1986 DIE(aTHX_ "Can't \"last\" outside a loop block");
1989 cxix = dopoptolabel(cPVOP->op_pv);
1991 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1993 if (cxix < cxstack_ix)
1997 cxstack_ix++; /* temporarily protect top context */
1999 switch (CxTYPE(cx)) {
2002 newsp = PL_stack_base + cx->blk_loop.resetsp;
2003 nextop = cx->blk_loop.last_op->op_next;
2007 nextop = pop_return();
2011 nextop = pop_return();
2015 nextop = pop_return();
2018 DIE(aTHX_ "panic: last");
2022 if (gimme == G_SCALAR) {
2024 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2025 ? *SP : sv_mortalcopy(*SP);
2027 *++newsp = &PL_sv_undef;
2029 else if (gimme == G_ARRAY) {
2030 while (++MARK <= SP) {
2031 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2032 ? *MARK : sv_mortalcopy(*MARK);
2033 TAINT_NOT; /* Each item is independent */
2041 /* Stack values are safe: */
2044 POPLOOP(cx); /* release loop vars ... */
2048 POPSUB(cx,sv); /* release CV and @_ ... */
2051 PL_curpm = newpm; /* ... and pop $1 et al */
2060 register PERL_CONTEXT *cx;
2063 if (PL_op->op_flags & OPf_SPECIAL) {
2064 cxix = dopoptoloop(cxstack_ix);
2066 DIE(aTHX_ "Can't \"next\" outside a loop block");
2069 cxix = dopoptolabel(cPVOP->op_pv);
2071 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2073 if (cxix < cxstack_ix)
2076 /* clear off anything above the scope we're re-entering, but
2077 * save the rest until after a possible continue block */
2078 inner = PL_scopestack_ix;
2080 if (PL_scopestack_ix < inner)
2081 leave_scope(PL_scopestack[PL_scopestack_ix]);
2082 return cx->blk_loop.next_op;
2088 register PERL_CONTEXT *cx;
2091 if (PL_op->op_flags & OPf_SPECIAL) {
2092 cxix = dopoptoloop(cxstack_ix);
2094 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2097 cxix = dopoptolabel(cPVOP->op_pv);
2099 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2101 if (cxix < cxstack_ix)
2105 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2106 LEAVE_SCOPE(oldsave);
2107 return cx->blk_loop.redo_op;
2111 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2115 static char too_deep[] = "Target of goto is too deeply nested";
2118 Perl_croak(aTHX_ too_deep);
2119 if (o->op_type == OP_LEAVE ||
2120 o->op_type == OP_SCOPE ||
2121 o->op_type == OP_LEAVELOOP ||
2122 o->op_type == OP_LEAVESUB ||
2123 o->op_type == OP_LEAVETRY)
2125 *ops++ = cUNOPo->op_first;
2127 Perl_croak(aTHX_ too_deep);
2130 if (o->op_flags & OPf_KIDS) {
2131 /* First try all the kids at this level, since that's likeliest. */
2132 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2133 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2134 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2137 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2138 if (kid == PL_lastgotoprobe)
2140 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2143 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2144 ops[-1]->op_type == OP_DBSTATE)
2149 if ((o = dofindlabel(kid, label, ops, oplimit)))
2168 register PERL_CONTEXT *cx;
2169 #define GOTO_DEPTH 64
2170 OP *enterops[GOTO_DEPTH];
2172 int do_dump = (PL_op->op_type == OP_DUMP);
2173 static char must_have_label[] = "goto must have label";
2176 if (PL_op->op_flags & OPf_STACKED) {
2180 /* This egregious kludge implements goto &subroutine */
2181 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2183 register PERL_CONTEXT *cx;
2184 CV* cv = (CV*)SvRV(sv);
2190 if (!CvROOT(cv) && !CvXSUB(cv)) {
2195 /* autoloaded stub? */
2196 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2198 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2199 GvNAMELEN(gv), FALSE);
2200 if (autogv && (cv = GvCV(autogv)))
2202 tmpstr = sv_newmortal();
2203 gv_efullname3(tmpstr, gv, Nullch);
2204 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2206 DIE(aTHX_ "Goto undefined subroutine");
2209 /* First do some returnish stuff. */
2210 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2212 cxix = dopoptosub(cxstack_ix);
2214 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2215 if (cxix < cxstack_ix)
2219 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2221 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2222 /* put @_ back onto stack */
2223 AV* av = cx->blk_sub.argarray;
2225 items = AvFILLp(av) + 1;
2227 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2228 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2229 PL_stack_sp += items;
2230 SvREFCNT_dec(GvAV(PL_defgv));
2231 GvAV(PL_defgv) = cx->blk_sub.savearray;
2232 /* abandon @_ if it got reified */
2234 (void)sv_2mortal((SV*)av); /* delay until return */
2236 av_extend(av, items-1);
2237 AvFLAGS(av) = AVf_REIFY;
2238 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2243 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2245 av = GvAV(PL_defgv);
2246 items = AvFILLp(av) + 1;
2248 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2249 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2250 PL_stack_sp += items;
2252 if (CxTYPE(cx) == CXt_SUB &&
2253 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2254 SvREFCNT_dec(cx->blk_sub.cv);
2255 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2256 LEAVE_SCOPE(oldsave);
2258 /* Now do some callish stuff. */
2260 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2262 #ifdef PERL_XSUB_OLDSTYLE
2263 if (CvOLDSTYLE(cv)) {
2264 I32 (*fp3)(int,int,int);
2269 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2270 items = (*fp3)(CvXSUBANY(cv).any_i32,
2271 mark - PL_stack_base + 1,
2273 SP = PL_stack_base + items;
2276 #endif /* PERL_XSUB_OLDSTYLE */
2281 PL_stack_sp--; /* There is no cv arg. */
2282 /* Push a mark for the start of arglist */
2284 (void)(*CvXSUB(cv))(aTHX_ cv);
2285 /* Pop the current context like a decent sub should */
2286 POPBLOCK(cx, PL_curpm);
2287 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2290 return pop_return();
2293 AV* padlist = CvPADLIST(cv);
2294 if (CxTYPE(cx) == CXt_EVAL) {
2295 PL_in_eval = cx->blk_eval.old_in_eval;
2296 PL_eval_root = cx->blk_eval.old_eval_root;
2297 cx->cx_type = CXt_SUB;
2298 cx->blk_sub.hasargs = 0;
2300 cx->blk_sub.cv = cv;
2301 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2304 if (CvDEPTH(cv) < 2)
2305 (void)SvREFCNT_inc(cv);
2307 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2308 sub_crush_depth(cv);
2309 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2311 PAD_SET_CUR(padlist, CvDEPTH(cv));
2312 if (cx->blk_sub.hasargs)
2314 AV* av = (AV*)PAD_SVl(0);
2317 cx->blk_sub.savearray = GvAV(PL_defgv);
2318 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2319 CX_CURPAD_SAVE(cx->blk_sub);
2320 cx->blk_sub.argarray = av;
2323 if (items >= AvMAX(av) + 1) {
2325 if (AvARRAY(av) != ary) {
2326 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2327 SvPVX(av) = (char*)ary;
2329 if (items >= AvMAX(av) + 1) {
2330 AvMAX(av) = items - 1;
2331 Renew(ary,items+1,SV*);
2333 SvPVX(av) = (char*)ary;
2336 Copy(mark,AvARRAY(av),items,SV*);
2337 AvFILLp(av) = items - 1;
2338 assert(!AvREAL(av));
2345 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2347 * We do not care about using sv to call CV;
2348 * it's for informational purposes only.
2350 SV *sv = GvSV(PL_DBsub);
2353 if (PERLDB_SUB_NN) {
2354 (void)SvUPGRADE(sv, SVt_PVIV);
2357 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2360 gv_efullname3(sv, CvGV(cv), Nullch);
2363 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2364 PUSHMARK( PL_stack_sp );
2365 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2369 RETURNOP(CvSTART(cv));
2373 label = SvPV(sv,n_a);
2374 if (!(do_dump || *label))
2375 DIE(aTHX_ must_have_label);
2378 else if (PL_op->op_flags & OPf_SPECIAL) {
2380 DIE(aTHX_ must_have_label);
2383 label = cPVOP->op_pv;
2385 if (label && *label) {
2387 bool leaving_eval = FALSE;
2388 bool in_block = FALSE;
2389 PERL_CONTEXT *last_eval_cx = 0;
2393 PL_lastgotoprobe = 0;
2395 for (ix = cxstack_ix; ix >= 0; ix--) {
2397 switch (CxTYPE(cx)) {
2399 leaving_eval = TRUE;
2400 if (!CxTRYBLOCK(cx)) {
2401 gotoprobe = (last_eval_cx ?
2402 last_eval_cx->blk_eval.old_eval_root :
2407 /* else fall through */
2409 gotoprobe = cx->blk_oldcop->op_sibling;
2415 gotoprobe = cx->blk_oldcop->op_sibling;
2418 gotoprobe = PL_main_root;
2421 if (CvDEPTH(cx->blk_sub.cv)) {
2422 gotoprobe = CvROOT(cx->blk_sub.cv);
2428 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2431 DIE(aTHX_ "panic: goto");
2432 gotoprobe = PL_main_root;
2436 retop = dofindlabel(gotoprobe, label,
2437 enterops, enterops + GOTO_DEPTH);
2441 PL_lastgotoprobe = gotoprobe;
2444 DIE(aTHX_ "Can't find label %s", label);
2446 /* if we're leaving an eval, check before we pop any frames
2447 that we're not going to punt, otherwise the error
2450 if (leaving_eval && *enterops && enterops[1]) {
2452 for (i = 1; enterops[i]; i++)
2453 if (enterops[i]->op_type == OP_ENTERITER)
2454 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2457 /* pop unwanted frames */
2459 if (ix < cxstack_ix) {
2466 oldsave = PL_scopestack[PL_scopestack_ix];
2467 LEAVE_SCOPE(oldsave);
2470 /* push wanted frames */
2472 if (*enterops && enterops[1]) {
2474 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2475 for (; enterops[ix]; ix++) {
2476 PL_op = enterops[ix];
2477 /* Eventually we may want to stack the needed arguments
2478 * for each op. For now, we punt on the hard ones. */
2479 if (PL_op->op_type == OP_ENTERITER)
2480 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2481 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2489 if (!retop) retop = PL_main_start;
2491 PL_restartop = retop;
2492 PL_do_undump = TRUE;
2496 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2497 PL_do_undump = FALSE;
2513 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2515 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2518 PL_exit_flags |= PERL_EXIT_EXPECTED;
2520 PUSHs(&PL_sv_undef);
2528 NV value = SvNVx(GvSV(cCOP->cop_gv));
2529 register I32 match = I_32(value);
2532 if (((NV)match) > value)
2533 --match; /* was fractional--truncate other way */
2535 match -= cCOP->uop.scop.scop_offset;
2538 else if (match > cCOP->uop.scop.scop_max)
2539 match = cCOP->uop.scop.scop_max;
2540 PL_op = cCOP->uop.scop.scop_next[match];
2550 PL_op = PL_op->op_next; /* can't assume anything */
2553 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
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];
2568 S_save_lines(pTHX_ AV *array, SV *sv)
2570 register char *s = SvPVX(sv);
2571 register char *send = SvPVX(sv) + SvCUR(sv);
2573 register I32 line = 1;
2575 while (s && s < send) {
2576 SV *tmpstr = NEWSV(85,0);
2578 sv_upgrade(tmpstr, SVt_PVMG);
2579 t = strchr(s, '\n');
2585 sv_setpvn(tmpstr, s, t - s);
2586 av_store(array, line++, tmpstr);
2591 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2593 S_docatch_body(pTHX_ va_list args)
2595 return docatch_body();
2600 S_docatch_body(pTHX)
2607 S_docatch(pTHX_ OP *o)
2612 volatile PERL_SI *cursi = PL_curstackinfo;
2616 assert(CATCH_GET == TRUE);
2620 /* Normally, the leavetry at the end of this block of ops will
2621 * pop an op off the return stack and continue there. By setting
2622 * the op to Nullop, we force an exit from the inner runops()
2625 retop = pop_return();
2626 push_return(Nullop);
2628 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2630 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2636 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2642 /* die caught by an inner eval - continue inner loop */
2643 if (PL_restartop && cursi == PL_curstackinfo) {
2644 PL_op = PL_restartop;
2648 /* a die in this eval - continue in outer loop */
2664 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2665 /* sv Text to convert to OP tree. */
2666 /* startop op_free() this to undo. */
2667 /* code Short string id of the caller. */
2669 dSP; /* Make POPBLOCK work. */
2672 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2676 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2677 char *tmpbuf = tbuf;
2680 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2685 /* switch to eval mode */
2687 if (IN_PERL_COMPILETIME) {
2688 SAVECOPSTASH_FREE(&PL_compiling);
2689 CopSTASH_set(&PL_compiling, PL_curstash);
2691 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2692 SV *sv = sv_newmortal();
2693 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2694 code, (unsigned long)++PL_evalseq,
2695 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2699 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2700 SAVECOPFILE_FREE(&PL_compiling);
2701 CopFILE_set(&PL_compiling, tmpbuf+2);
2702 SAVECOPLINE(&PL_compiling);
2703 CopLINE_set(&PL_compiling, 1);
2704 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2705 deleting the eval's FILEGV from the stash before gv_check() runs
2706 (i.e. before run-time proper). To work around the coredump that
2707 ensues, we always turn GvMULTI_on for any globals that were
2708 introduced within evals. See force_ident(). GSAR 96-10-12 */
2709 safestr = savepv(tmpbuf);
2710 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2712 #ifdef OP_IN_REGISTER
2718 /* we get here either during compilation, or via pp_regcomp at runtime */
2719 runtime = IN_PERL_RUNTIME;
2721 runcv = find_runcv(NULL);
2724 PL_op->op_type = OP_ENTEREVAL;
2725 PL_op->op_flags = 0; /* Avoid uninit warning. */
2726 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2727 PUSHEVAL(cx, 0, Nullgv);
2730 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2732 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2733 POPBLOCK(cx,PL_curpm);
2736 (*startop)->op_type = OP_NULL;
2737 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2739 /* XXX DAPM do this properly one year */
2740 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2742 if (IN_PERL_COMPILETIME)
2743 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2744 #ifdef OP_IN_REGISTER
2752 =for apidoc find_runcv
2754 Locate the CV corresponding to the currently executing sub or eval.
2755 If db_seqp is non_null, skip CVs that are in the DB package and populate
2756 *db_seqp with the cop sequence number at the point that the DB:: code was
2757 entered. (allows debuggers to eval in the scope of the breakpoint rather
2758 than in in the scope of the debuger itself).
2764 Perl_find_runcv(pTHX_ U32 *db_seqp)
2771 *db_seqp = PL_curcop->cop_seq;
2772 for (si = PL_curstackinfo; si; si = si->si_prev) {
2773 for (ix = si->si_cxix; ix >= 0; ix--) {
2774 cx = &(si->si_cxstack[ix]);
2775 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2776 CV *cv = cx->blk_sub.cv;
2777 /* skip DB:: code */
2778 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2779 *db_seqp = cx->blk_oldcop->cop_seq;
2784 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2792 /* Compile a require/do, an eval '', or a /(?{...})/.
2793 * In the last case, startop is non-null, and contains the address of
2794 * a pointer that should be set to the just-compiled code.
2795 * outside is the lexically enclosing CV (if any) that invoked us.
2798 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2800 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2805 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2806 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2811 SAVESPTR(PL_compcv);
2812 PL_compcv = (CV*)NEWSV(1104,0);
2813 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2814 CvEVAL_on(PL_compcv);
2815 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2816 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2818 CvOUTSIDE_SEQ(PL_compcv) = seq;
2819 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2821 /* set up a scratch pad */
2823 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2826 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2828 /* make sure we compile in the right package */
2830 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2831 SAVESPTR(PL_curstash);
2832 PL_curstash = CopSTASH(PL_curcop);
2834 SAVESPTR(PL_beginav);
2835 PL_beginav = newAV();
2836 SAVEFREESV(PL_beginav);
2837 SAVEI32(PL_error_count);
2839 /* try to compile it */
2841 PL_eval_root = Nullop;
2843 PL_curcop = &PL_compiling;
2844 PL_curcop->cop_arybase = 0;
2845 if (saveop && saveop->op_flags & OPf_SPECIAL)
2846 PL_in_eval |= EVAL_KEEPERR;
2849 if (yyparse() || PL_error_count || !PL_eval_root) {
2850 SV **newsp; /* Used by POPBLOCK. */
2851 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2852 I32 optype = 0; /* Might be reset by POPEVAL. */
2857 op_free(PL_eval_root);
2858 PL_eval_root = Nullop;
2860 SP = PL_stack_base + POPMARK; /* pop original mark */
2862 POPBLOCK(cx,PL_curpm);
2868 if (optype == OP_REQUIRE) {
2869 char* msg = SvPVx(ERRSV, n_a);
2870 SV *nsv = cx->blk_eval.old_namesv;
2871 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2873 DIE(aTHX_ "%sCompilation failed in require",
2874 *msg ? msg : "Unknown error\n");
2877 char* msg = SvPVx(ERRSV, n_a);
2879 POPBLOCK(cx,PL_curpm);
2881 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2882 (*msg ? msg : "Unknown error\n"));
2885 char* msg = SvPVx(ERRSV, n_a);
2887 sv_setpv(ERRSV, "Compilation error");
2892 CopLINE_set(&PL_compiling, 0);
2894 *startop = PL_eval_root;
2896 SAVEFREEOP(PL_eval_root);
2898 /* Set the context for this new optree.
2899 * If the last op is an OP_REQUIRE, force scalar context.
2900 * Otherwise, propagate the context from the eval(). */
2901 if (PL_eval_root->op_type == OP_LEAVEEVAL
2902 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2903 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2905 scalar(PL_eval_root);
2906 else if (gimme & G_VOID)
2907 scalarvoid(PL_eval_root);
2908 else if (gimme & G_ARRAY)
2911 scalar(PL_eval_root);
2913 DEBUG_x(dump_eval());
2915 /* Register with debugger: */
2916 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2917 CV *cv = get_cv("DB::postponed", FALSE);
2921 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2923 call_sv((SV*)cv, G_DISCARD);
2927 /* compiled okay, so do it */
2929 CvDEPTH(PL_compcv) = 1;
2930 SP = PL_stack_base + POPMARK; /* pop original mark */
2931 PL_op = saveop; /* The caller may need it. */
2932 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2934 RETURNOP(PL_eval_start);
2938 S_doopen_pm(pTHX_ const char *name, const char *mode)
2940 #ifndef PERL_DISABLE_PMC
2941 STRLEN namelen = strlen(name);
2944 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2945 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2946 char *pmc = SvPV_nolen(pmcsv);
2949 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2950 fp = PerlIO_open(name, mode);
2953 if (PerlLIO_stat(name, &pmstat) < 0 ||
2954 pmstat.st_mtime < pmcstat.st_mtime)
2956 fp = PerlIO_open(pmc, mode);
2959 fp = PerlIO_open(name, mode);
2962 SvREFCNT_dec(pmcsv);
2965 fp = PerlIO_open(name, mode);
2969 return PerlIO_open(name, mode);
2970 #endif /* !PERL_DISABLE_PMC */
2976 register PERL_CONTEXT *cx;
2980 char *tryname = Nullch;
2981 SV *namesv = Nullsv;
2983 I32 gimme = GIMME_V;
2984 PerlIO *tryrsfp = 0;
2986 int filter_has_file = 0;
2987 GV *filter_child_proc = 0;
2988 SV *filter_state = 0;
2995 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2996 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2997 UV rev = 0, ver = 0, sver = 0;
2999 U8 *s = (U8*)SvPVX(sv);
3000 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3002 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3005 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3008 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3011 if (PERL_REVISION < rev
3012 || (PERL_REVISION == rev
3013 && (PERL_VERSION < ver
3014 || (PERL_VERSION == ver
3015 && PERL_SUBVERSION < sver))))
3017 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3018 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3019 PERL_VERSION, PERL_SUBVERSION);
3021 if (ckWARN(WARN_PORTABLE))
3022 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3023 "v-string in use/require non-portable");
3026 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3027 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3028 + ((NV)PERL_SUBVERSION/(NV)1000000)
3029 + 0.00000099 < SvNV(sv))
3033 NV nver = (nrev - rev) * 1000;
3034 UV ver = (UV)(nver + 0.0009);
3035 NV nsver = (nver - ver) * 1000;
3036 UV sver = (UV)(nsver + 0.0009);
3038 /* help out with the "use 5.6" confusion */
3039 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3040 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3041 " (did you mean v%"UVuf".%03"UVuf"?)--"
3042 "this is only v%d.%d.%d, stopped",
3043 rev, ver, sver, rev, ver/100,
3044 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3047 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3048 "this is only v%d.%d.%d, stopped",
3049 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3056 name = SvPV(sv, len);
3057 if (!(name && len > 0 && *name))
3058 DIE(aTHX_ "Null filename used");
3059 TAINT_PROPER("require");
3060 if (PL_op->op_type == OP_REQUIRE &&
3061 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3062 if (*svp != &PL_sv_undef)
3065 DIE(aTHX_ "Compilation failed in require");
3068 /* prepare to compile file */
3070 if (path_is_absolute(name)) {
3072 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3074 #ifdef MACOS_TRADITIONAL
3078 MacPerl_CanonDir(name, newname, 1);
3079 if (path_is_absolute(newname)) {
3081 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3086 AV *ar = GvAVn(PL_incgv);
3090 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3093 namesv = NEWSV(806, 0);
3094 for (i = 0; i <= AvFILL(ar); i++) {
3095 SV *dirsv = *av_fetch(ar, i, TRUE);
3101 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3102 && !sv_isobject(loader))
3104 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3107 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3108 PTR2UV(SvRV(dirsv)), name);
3109 tryname = SvPVX(namesv);
3120 if (sv_isobject(loader))
3121 count = call_method("INC", G_ARRAY);
3123 count = call_sv(loader, G_ARRAY);
3133 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3137 if (SvTYPE(arg) == SVt_PVGV) {
3138 IO *io = GvIO((GV *)arg);
3143 tryrsfp = IoIFP(io);
3144 if (IoTYPE(io) == IoTYPE_PIPE) {
3145 /* reading from a child process doesn't
3146 nest -- when returning from reading
3147 the inner module, the outer one is
3148 unreadable (closed?) I've tried to
3149 save the gv to manage the lifespan of
3150 the pipe, but this didn't help. XXX */
3151 filter_child_proc = (GV *)arg;
3152 (void)SvREFCNT_inc(filter_child_proc);
3155 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3156 PerlIO_close(IoOFP(io));
3168 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3170 (void)SvREFCNT_inc(filter_sub);
3173 filter_state = SP[i];
3174 (void)SvREFCNT_inc(filter_state);
3178 tryrsfp = PerlIO_open("/dev/null",
3194 filter_has_file = 0;
3195 if (filter_child_proc) {
3196 SvREFCNT_dec(filter_child_proc);
3197 filter_child_proc = 0;
3200 SvREFCNT_dec(filter_state);
3204 SvREFCNT_dec(filter_sub);
3209 if (!path_is_absolute(name)
3210 #ifdef MACOS_TRADITIONAL
3211 /* We consider paths of the form :a:b ambiguous and interpret them first
3212 as global then as local
3214 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3217 char *dir = SvPVx(dirsv, n_a);
3218 #ifdef MACOS_TRADITIONAL
3222 MacPerl_CanonDir(name, buf2, 1);
3223 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3227 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3229 sv_setpv(namesv, unixdir);
3230 sv_catpv(namesv, unixname);
3232 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3235 TAINT_PROPER("require");
3236 tryname = SvPVX(namesv);
3237 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3239 if (tryname[0] == '.' && tryname[1] == '/')
3248 SAVECOPFILE_FREE(&PL_compiling);
3249 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3250 SvREFCNT_dec(namesv);
3252 if (PL_op->op_type == OP_REQUIRE) {
3253 char *msgstr = name;
3254 if (namesv) { /* did we lookup @INC? */
3255 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3256 SV *dirmsgsv = NEWSV(0, 0);
3257 AV *ar = GvAVn(PL_incgv);
3259 sv_catpvn(msg, " in @INC", 8);
3260 if (instr(SvPVX(msg), ".h "))
3261 sv_catpv(msg, " (change .h to .ph maybe?)");
3262 if (instr(SvPVX(msg), ".ph "))
3263 sv_catpv(msg, " (did you run h2ph?)");
3264 sv_catpv(msg, " (@INC contains:");
3265 for (i = 0; i <= AvFILL(ar); i++) {
3266 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3267 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3268 sv_catsv(msg, dirmsgsv);
3270 sv_catpvn(msg, ")", 1);
3271 SvREFCNT_dec(dirmsgsv);
3272 msgstr = SvPV_nolen(msg);
3274 DIE(aTHX_ "Can't locate %s", msgstr);
3280 SETERRNO(0, SS_NORMAL);
3282 /* Assume success here to prevent recursive requirement. */
3284 /* Check whether a hook in @INC has already filled %INC */
3285 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3286 (void)hv_store(GvHVn(PL_incgv), name, len,
3287 (hook_sv ? SvREFCNT_inc(hook_sv)
3288 : newSVpv(CopFILE(&PL_compiling), 0)),
3294 lex_start(sv_2mortal(newSVpvn("",0)));
3295 SAVEGENERICSV(PL_rsfp_filters);
3296 PL_rsfp_filters = Nullav;
3301 SAVESPTR(PL_compiling.cop_warnings);
3302 if (PL_dowarn & G_WARN_ALL_ON)
3303 PL_compiling.cop_warnings = pWARN_ALL ;
3304 else if (PL_dowarn & G_WARN_ALL_OFF)
3305 PL_compiling.cop_warnings = pWARN_NONE ;
3306 else if (PL_taint_warn)
3307 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3309 PL_compiling.cop_warnings = pWARN_STD ;
3310 SAVESPTR(PL_compiling.cop_io);
3311 PL_compiling.cop_io = Nullsv;
3313 if (filter_sub || filter_child_proc) {
3314 SV *datasv = filter_add(run_user_filter, Nullsv);
3315 IoLINES(datasv) = filter_has_file;
3316 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3317 IoTOP_GV(datasv) = (GV *)filter_state;
3318 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3321 /* switch to eval mode */
3322 push_return(PL_op->op_next);
3323 PUSHBLOCK(cx, CXt_EVAL, SP);
3324 PUSHEVAL(cx, name, Nullgv);
3326 SAVECOPLINE(&PL_compiling);
3327 CopLINE_set(&PL_compiling, 0);
3331 /* Store and reset encoding. */
3332 encoding = PL_encoding;
3333 PL_encoding = Nullsv;
3335 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3337 /* Restore encoding. */
3338 PL_encoding = encoding;
3345 return pp_require();
3351 register PERL_CONTEXT *cx;
3353 I32 gimme = GIMME_V, was = PL_sub_generation;
3354 char tbuf[TYPE_DIGITS(long) + 12];
3355 char *tmpbuf = tbuf;
3364 TAINT_PROPER("eval");
3370 /* switch to eval mode */
3372 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3373 SV *sv = sv_newmortal();
3374 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3375 (unsigned long)++PL_evalseq,
3376 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3380 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3381 SAVECOPFILE_FREE(&PL_compiling);
3382 CopFILE_set(&PL_compiling, tmpbuf+2);
3383 SAVECOPLINE(&PL_compiling);
3384 CopLINE_set(&PL_compiling, 1);
3385 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3386 deleting the eval's FILEGV from the stash before gv_check() runs
3387 (i.e. before run-time proper). To work around the coredump that
3388 ensues, we always turn GvMULTI_on for any globals that were
3389 introduced within evals. See force_ident(). GSAR 96-10-12 */
3390 safestr = savepv(tmpbuf);
3391 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3393 PL_hints = PL_op->op_targ;
3394 SAVESPTR(PL_compiling.cop_warnings);
3395 if (specialWARN(PL_curcop->cop_warnings))
3396 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3398 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3399 SAVEFREESV(PL_compiling.cop_warnings);
3401 SAVESPTR(PL_compiling.cop_io);
3402 if (specialCopIO(PL_curcop->cop_io))
3403 PL_compiling.cop_io = PL_curcop->cop_io;
3405 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3406 SAVEFREESV(PL_compiling.cop_io);
3408 /* special case: an eval '' executed within the DB package gets lexically
3409 * placed in the first non-DB CV rather than the current CV - this
3410 * allows the debugger to execute code, find lexicals etc, in the
3411 * scope of the code being debugged. Passing &seq gets find_runcv
3412 * to do the dirty work for us */
3413 runcv = find_runcv(&seq);
3415 push_return(PL_op->op_next);
3416 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3417 PUSHEVAL(cx, 0, Nullgv);
3419 /* prepare to compile string */
3421 if (PERLDB_LINE && PL_curstash != PL_debstash)
3422 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3424 ret = doeval(gimme, NULL, runcv, seq);
3425 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3426 && ret != PL_op->op_next) { /* Successive compilation. */
3427 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3429 return DOCATCH(ret);
3439 register PERL_CONTEXT *cx;
3441 U8 save_flags = PL_op -> op_flags;
3446 retop = pop_return();
3449 if (gimme == G_VOID)
3451 else if (gimme == G_SCALAR) {
3454 if (SvFLAGS(TOPs) & SVs_TEMP)
3457 *MARK = sv_mortalcopy(TOPs);
3461 *MARK = &PL_sv_undef;
3466 /* in case LEAVE wipes old return values */
3467 for (mark = newsp + 1; mark <= SP; mark++) {
3468 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3469 *mark = sv_mortalcopy(*mark);
3470 TAINT_NOT; /* Each item is independent */
3474 PL_curpm = newpm; /* Don't pop $1 et al till now */
3477 assert(CvDEPTH(PL_compcv) == 1);
3479 CvDEPTH(PL_compcv) = 0;
3482 if (optype == OP_REQUIRE &&
3483 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3485 /* Unassume the success we assumed earlier. */
3486 SV *nsv = cx->blk_eval.old_namesv;
3487 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3488 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3489 /* die_where() did LEAVE, or we won't be here */
3493 if (!(save_flags & OPf_SPECIAL))
3503 register PERL_CONTEXT *cx;
3504 I32 gimme = GIMME_V;
3509 push_return(cLOGOP->op_other->op_next);
3510 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3513 PL_in_eval = EVAL_INEVAL;
3516 return DOCATCH(PL_op->op_next);
3527 register PERL_CONTEXT *cx;
3532 retop = pop_return();
3535 if (gimme == G_VOID)
3537 else if (gimme == G_SCALAR) {
3540 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3543 *MARK = sv_mortalcopy(TOPs);
3547 *MARK = &PL_sv_undef;
3552 /* in case LEAVE wipes old return values */
3553 for (mark = newsp + 1; mark <= SP; mark++) {
3554 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3555 *mark = sv_mortalcopy(*mark);
3556 TAINT_NOT; /* Each item is independent */
3560 PL_curpm = newpm; /* Don't pop $1 et al till now */
3568 S_doparseform(pTHX_ SV *sv)
3571 register char *s = SvPV_force(sv, len);
3572 register char *send = s + len;
3573 register char *base = Nullch;
3574 register I32 skipspaces = 0;
3575 bool noblank = FALSE;
3576 bool repeat = FALSE;
3577 bool postspace = FALSE;
3583 bool unchopnum = FALSE;
3584 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3587 Perl_croak(aTHX_ "Null picture in formline");
3589 /* estimate the buffer size needed */
3590 for (base = s; s <= send; s++) {
3591 if (*s == '\n' || *s == '@' || *s == '^')
3597 New(804, fops, maxops, U32);
3602 *fpc++ = FF_LINEMARK;
3603 noblank = repeat = FALSE;
3621 case ' ': case '\t':
3628 } /* else FALL THROUGH */
3636 *fpc++ = FF_LITERAL;
3644 *fpc++ = (U16)skipspaces;
3648 *fpc++ = FF_NEWLINE;
3652 arg = fpc - linepc + 1;
3659 *fpc++ = FF_LINEMARK;
3660 noblank = repeat = FALSE;
3669 ischop = s[-1] == '^';
3675 arg = (s - base) - 1;
3677 *fpc++ = FF_LITERAL;
3685 *fpc++ = 2; /* skip the @* or ^* */
3687 *fpc++ = FF_LINESNGL;
3690 *fpc++ = FF_LINEGLOB;
3692 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3693 arg = ischop ? 512 : 0;
3703 arg |= 256 + (s - f);
3705 *fpc++ = s - base; /* fieldsize for FETCH */
3706 *fpc++ = FF_DECIMAL;
3708 unchopnum |= ! ischop;
3710 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3711 arg = ischop ? 512 : 0;
3713 s++; /* skip the '0' first */
3722 arg |= 256 + (s - f);
3724 *fpc++ = s - base; /* fieldsize for FETCH */
3725 *fpc++ = FF_0DECIMAL;
3727 unchopnum |= ! ischop;
3731 bool ismore = FALSE;
3734 while (*++s == '>') ;
3735 prespace = FF_SPACE;
3737 else if (*s == '|') {
3738 while (*++s == '|') ;
3739 prespace = FF_HALFSPACE;
3744 while (*++s == '<') ;
3747 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3751 *fpc++ = s - base; /* fieldsize for FETCH */
3753 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3756 *fpc++ = (U16)prespace;
3770 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3772 { /* need to jump to the next word */
3774 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3775 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3776 s = SvPVX(sv) + SvCUR(sv) + z;
3778 Copy(fops, s, arg, U32);
3780 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3783 if (unchopnum && repeat)
3784 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3790 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3792 /* Can value be printed in fldsize chars, using %*.*f ? */
3796 int intsize = fldsize - (value < 0 ? 1 : 0);
3803 while (intsize--) pwr *= 10.0;
3804 while (frcsize--) eps /= 10.0;
3807 if (value + eps >= pwr)
3810 if (value - eps <= -pwr)
3817 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3819 SV *datasv = FILTER_DATA(idx);
3820 int filter_has_file = IoLINES(datasv);
3821 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3822 SV *filter_state = (SV *)IoTOP_GV(datasv);
3823 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3826 /* I was having segfault trouble under Linux 2.2.5 after a
3827 parse error occured. (Had to hack around it with a test
3828 for PL_error_count == 0.) Solaris doesn't segfault --
3829 not sure where the trouble is yet. XXX */
3831 if (filter_has_file) {
3832 len = FILTER_READ(idx+1, buf_sv, maxlen);
3835 if (filter_sub && len >= 0) {
3846 PUSHs(sv_2mortal(newSViv(maxlen)));
3848 PUSHs(filter_state);
3851 count = call_sv(filter_sub, G_SCALAR);
3867 IoLINES(datasv) = 0;
3868 if (filter_child_proc) {
3869 SvREFCNT_dec(filter_child_proc);
3870 IoFMT_GV(datasv) = Nullgv;
3873 SvREFCNT_dec(filter_state);
3874 IoTOP_GV(datasv) = Nullgv;
3877 SvREFCNT_dec(filter_sub);
3878 IoBOTTOM_GV(datasv) = Nullgv;
3880 filter_del(run_user_filter);
3886 /* perhaps someone can come up with a better name for
3887 this? it is not really "absolute", per se ... */
3889 S_path_is_absolute(pTHX_ char *name)
3891 if (PERL_FILE_IS_ABSOLUTE(name)
3892 #ifdef MACOS_TRADITIONAL
3895 || (*name == '.' && (name[1] == '/' ||
3896 (name[1] == '.' && name[2] == '/'))))