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
2717 PL_hints &= HINT_UTF8;
2719 /* we get here either during compilation, or via pp_regcomp at runtime */
2720 runtime = IN_PERL_RUNTIME;
2722 runcv = find_runcv(NULL);
2725 PL_op->op_type = OP_ENTEREVAL;
2726 PL_op->op_flags = 0; /* Avoid uninit warning. */
2727 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2728 PUSHEVAL(cx, 0, Nullgv);
2731 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2733 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2734 POPBLOCK(cx,PL_curpm);
2737 (*startop)->op_type = OP_NULL;
2738 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2740 /* XXX DAPM do this properly one year */
2741 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2743 if (IN_PERL_COMPILETIME)
2744 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2745 #ifdef OP_IN_REGISTER
2753 =for apidoc find_runcv
2755 Locate the CV corresponding to the currently executing sub or eval.
2756 If db_seqp is non_null, skip CVs that are in the DB package and populate
2757 *db_seqp with the cop sequence number at the point that the DB:: code was
2758 entered. (allows debuggers to eval in the scope of the breakpoint rather
2759 than in in the scope of the debuger itself).
2765 Perl_find_runcv(pTHX_ U32 *db_seqp)
2772 *db_seqp = PL_curcop->cop_seq;
2773 for (si = PL_curstackinfo; si; si = si->si_prev) {
2774 for (ix = si->si_cxix; ix >= 0; ix--) {
2775 cx = &(si->si_cxstack[ix]);
2776 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2777 CV *cv = cx->blk_sub.cv;
2778 /* skip DB:: code */
2779 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2780 *db_seqp = cx->blk_oldcop->cop_seq;
2785 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2793 /* Compile a require/do, an eval '', or a /(?{...})/.
2794 * In the last case, startop is non-null, and contains the address of
2795 * a pointer that should be set to the just-compiled code.
2796 * outside is the lexically enclosing CV (if any) that invoked us.
2799 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2801 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2806 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2807 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2812 SAVESPTR(PL_compcv);
2813 PL_compcv = (CV*)NEWSV(1104,0);
2814 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2815 CvEVAL_on(PL_compcv);
2816 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2817 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2819 CvOUTSIDE_SEQ(PL_compcv) = seq;
2820 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2822 /* set up a scratch pad */
2824 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2827 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2829 /* make sure we compile in the right package */
2831 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2832 SAVESPTR(PL_curstash);
2833 PL_curstash = CopSTASH(PL_curcop);
2835 SAVESPTR(PL_beginav);
2836 PL_beginav = newAV();
2837 SAVEFREESV(PL_beginav);
2838 SAVEI32(PL_error_count);
2840 /* try to compile it */
2842 PL_eval_root = Nullop;
2844 PL_curcop = &PL_compiling;
2845 PL_curcop->cop_arybase = 0;
2846 if (saveop && saveop->op_flags & OPf_SPECIAL)
2847 PL_in_eval |= EVAL_KEEPERR;
2850 if (yyparse() || PL_error_count || !PL_eval_root) {
2851 SV **newsp; /* Used by POPBLOCK. */
2852 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2853 I32 optype = 0; /* Might be reset by POPEVAL. */
2858 op_free(PL_eval_root);
2859 PL_eval_root = Nullop;
2861 SP = PL_stack_base + POPMARK; /* pop original mark */
2863 POPBLOCK(cx,PL_curpm);
2869 if (optype == OP_REQUIRE) {
2870 char* msg = SvPVx(ERRSV, n_a);
2871 SV *nsv = cx->blk_eval.old_namesv;
2872 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2874 DIE(aTHX_ "%sCompilation failed in require",
2875 *msg ? msg : "Unknown error\n");
2878 char* msg = SvPVx(ERRSV, n_a);
2880 POPBLOCK(cx,PL_curpm);
2882 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2883 (*msg ? msg : "Unknown error\n"));
2886 char* msg = SvPVx(ERRSV, n_a);
2888 sv_setpv(ERRSV, "Compilation error");
2893 CopLINE_set(&PL_compiling, 0);
2895 *startop = PL_eval_root;
2897 SAVEFREEOP(PL_eval_root);
2899 /* Set the context for this new optree.
2900 * If the last op is an OP_REQUIRE, force scalar context.
2901 * Otherwise, propagate the context from the eval(). */
2902 if (PL_eval_root->op_type == OP_LEAVEEVAL
2903 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2904 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2906 scalar(PL_eval_root);
2907 else if (gimme & G_VOID)
2908 scalarvoid(PL_eval_root);
2909 else if (gimme & G_ARRAY)
2912 scalar(PL_eval_root);
2914 DEBUG_x(dump_eval());
2916 /* Register with debugger: */
2917 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2918 CV *cv = get_cv("DB::postponed", FALSE);
2922 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2924 call_sv((SV*)cv, G_DISCARD);
2928 /* compiled okay, so do it */
2930 CvDEPTH(PL_compcv) = 1;
2931 SP = PL_stack_base + POPMARK; /* pop original mark */
2932 PL_op = saveop; /* The caller may need it. */
2933 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2935 RETURNOP(PL_eval_start);
2939 S_doopen_pm(pTHX_ const char *name, const char *mode)
2941 #ifndef PERL_DISABLE_PMC
2942 STRLEN namelen = strlen(name);
2945 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2946 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2947 char *pmc = SvPV_nolen(pmcsv);
2950 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2951 fp = PerlIO_open(name, mode);
2954 if (PerlLIO_stat(name, &pmstat) < 0 ||
2955 pmstat.st_mtime < pmcstat.st_mtime)
2957 fp = PerlIO_open(pmc, mode);
2960 fp = PerlIO_open(name, mode);
2963 SvREFCNT_dec(pmcsv);
2966 fp = PerlIO_open(name, mode);
2970 return PerlIO_open(name, mode);
2971 #endif /* !PERL_DISABLE_PMC */
2977 register PERL_CONTEXT *cx;
2981 char *tryname = Nullch;
2982 SV *namesv = Nullsv;
2984 I32 gimme = GIMME_V;
2985 PerlIO *tryrsfp = 0;
2987 int filter_has_file = 0;
2988 GV *filter_child_proc = 0;
2989 SV *filter_state = 0;
2996 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2997 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2998 UV rev = 0, ver = 0, sver = 0;
3000 U8 *s = (U8*)SvPVX(sv);
3001 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3003 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3006 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3009 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3012 if (PERL_REVISION < rev
3013 || (PERL_REVISION == rev
3014 && (PERL_VERSION < ver
3015 || (PERL_VERSION == ver
3016 && PERL_SUBVERSION < sver))))
3018 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3019 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3020 PERL_VERSION, PERL_SUBVERSION);
3022 if (ckWARN(WARN_PORTABLE))
3023 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3024 "v-string in use/require non-portable");
3027 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3028 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3029 + ((NV)PERL_SUBVERSION/(NV)1000000)
3030 + 0.00000099 < SvNV(sv))
3034 NV nver = (nrev - rev) * 1000;
3035 UV ver = (UV)(nver + 0.0009);
3036 NV nsver = (nver - ver) * 1000;
3037 UV sver = (UV)(nsver + 0.0009);
3039 /* help out with the "use 5.6" confusion */
3040 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3041 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3042 " (did you mean v%"UVuf".%03"UVuf"?)--"
3043 "this is only v%d.%d.%d, stopped",
3044 rev, ver, sver, rev, ver/100,
3045 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3048 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3049 "this is only v%d.%d.%d, stopped",
3050 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3057 name = SvPV(sv, len);
3058 if (!(name && len > 0 && *name))
3059 DIE(aTHX_ "Null filename used");
3060 TAINT_PROPER("require");
3061 if (PL_op->op_type == OP_REQUIRE &&
3062 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3063 if (*svp != &PL_sv_undef)
3066 DIE(aTHX_ "Compilation failed in require");
3069 /* prepare to compile file */
3071 if (path_is_absolute(name)) {
3073 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3075 #ifdef MACOS_TRADITIONAL
3079 MacPerl_CanonDir(name, newname, 1);
3080 if (path_is_absolute(newname)) {
3082 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3087 AV *ar = GvAVn(PL_incgv);
3091 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3094 namesv = NEWSV(806, 0);
3095 for (i = 0; i <= AvFILL(ar); i++) {
3096 SV *dirsv = *av_fetch(ar, i, TRUE);
3102 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3103 && !sv_isobject(loader))
3105 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3108 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3109 PTR2UV(SvRV(dirsv)), name);
3110 tryname = SvPVX(namesv);
3121 if (sv_isobject(loader))
3122 count = call_method("INC", G_ARRAY);
3124 count = call_sv(loader, G_ARRAY);
3134 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3138 if (SvTYPE(arg) == SVt_PVGV) {
3139 IO *io = GvIO((GV *)arg);
3144 tryrsfp = IoIFP(io);
3145 if (IoTYPE(io) == IoTYPE_PIPE) {
3146 /* reading from a child process doesn't
3147 nest -- when returning from reading
3148 the inner module, the outer one is
3149 unreadable (closed?) I've tried to
3150 save the gv to manage the lifespan of
3151 the pipe, but this didn't help. XXX */
3152 filter_child_proc = (GV *)arg;
3153 (void)SvREFCNT_inc(filter_child_proc);
3156 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3157 PerlIO_close(IoOFP(io));
3169 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3171 (void)SvREFCNT_inc(filter_sub);
3174 filter_state = SP[i];
3175 (void)SvREFCNT_inc(filter_state);
3179 tryrsfp = PerlIO_open("/dev/null",
3195 filter_has_file = 0;
3196 if (filter_child_proc) {
3197 SvREFCNT_dec(filter_child_proc);
3198 filter_child_proc = 0;
3201 SvREFCNT_dec(filter_state);
3205 SvREFCNT_dec(filter_sub);
3210 if (!path_is_absolute(name)
3211 #ifdef MACOS_TRADITIONAL
3212 /* We consider paths of the form :a:b ambiguous and interpret them first
3213 as global then as local
3215 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3218 char *dir = SvPVx(dirsv, n_a);
3219 #ifdef MACOS_TRADITIONAL
3223 MacPerl_CanonDir(name, buf2, 1);
3224 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3228 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3230 sv_setpv(namesv, unixdir);
3231 sv_catpv(namesv, unixname);
3233 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3236 TAINT_PROPER("require");
3237 tryname = SvPVX(namesv);
3238 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3240 if (tryname[0] == '.' && tryname[1] == '/')
3249 SAVECOPFILE_FREE(&PL_compiling);
3250 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3251 SvREFCNT_dec(namesv);
3253 if (PL_op->op_type == OP_REQUIRE) {
3254 char *msgstr = name;
3255 if (namesv) { /* did we lookup @INC? */
3256 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3257 SV *dirmsgsv = NEWSV(0, 0);
3258 AV *ar = GvAVn(PL_incgv);
3260 sv_catpvn(msg, " in @INC", 8);
3261 if (instr(SvPVX(msg), ".h "))
3262 sv_catpv(msg, " (change .h to .ph maybe?)");
3263 if (instr(SvPVX(msg), ".ph "))
3264 sv_catpv(msg, " (did you run h2ph?)");
3265 sv_catpv(msg, " (@INC contains:");
3266 for (i = 0; i <= AvFILL(ar); i++) {
3267 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3268 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3269 sv_catsv(msg, dirmsgsv);
3271 sv_catpvn(msg, ")", 1);
3272 SvREFCNT_dec(dirmsgsv);
3273 msgstr = SvPV_nolen(msg);
3275 DIE(aTHX_ "Can't locate %s", msgstr);
3281 SETERRNO(0, SS_NORMAL);
3283 /* Assume success here to prevent recursive requirement. */
3285 /* Check whether a hook in @INC has already filled %INC */
3286 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3287 (void)hv_store(GvHVn(PL_incgv), name, len,
3288 (hook_sv ? SvREFCNT_inc(hook_sv)
3289 : newSVpv(CopFILE(&PL_compiling), 0)),
3295 lex_start(sv_2mortal(newSVpvn("",0)));
3296 SAVEGENERICSV(PL_rsfp_filters);
3297 PL_rsfp_filters = Nullav;
3302 SAVESPTR(PL_compiling.cop_warnings);
3303 if (PL_dowarn & G_WARN_ALL_ON)
3304 PL_compiling.cop_warnings = pWARN_ALL ;
3305 else if (PL_dowarn & G_WARN_ALL_OFF)
3306 PL_compiling.cop_warnings = pWARN_NONE ;
3307 else if (PL_taint_warn)
3308 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3310 PL_compiling.cop_warnings = pWARN_STD ;
3311 SAVESPTR(PL_compiling.cop_io);
3312 PL_compiling.cop_io = Nullsv;
3314 if (filter_sub || filter_child_proc) {
3315 SV *datasv = filter_add(run_user_filter, Nullsv);
3316 IoLINES(datasv) = filter_has_file;
3317 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3318 IoTOP_GV(datasv) = (GV *)filter_state;
3319 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3322 /* switch to eval mode */
3323 push_return(PL_op->op_next);
3324 PUSHBLOCK(cx, CXt_EVAL, SP);
3325 PUSHEVAL(cx, name, Nullgv);
3327 SAVECOPLINE(&PL_compiling);
3328 CopLINE_set(&PL_compiling, 0);
3332 /* Store and reset encoding. */
3333 encoding = PL_encoding;
3334 PL_encoding = Nullsv;
3336 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3338 /* Restore encoding. */
3339 PL_encoding = encoding;
3346 return pp_require();
3352 register PERL_CONTEXT *cx;
3354 I32 gimme = GIMME_V, was = PL_sub_generation;
3355 char tbuf[TYPE_DIGITS(long) + 12];
3356 char *tmpbuf = tbuf;
3365 TAINT_PROPER("eval");
3371 /* switch to eval mode */
3373 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3374 SV *sv = sv_newmortal();
3375 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3376 (unsigned long)++PL_evalseq,
3377 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3381 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3382 SAVECOPFILE_FREE(&PL_compiling);
3383 CopFILE_set(&PL_compiling, tmpbuf+2);
3384 SAVECOPLINE(&PL_compiling);
3385 CopLINE_set(&PL_compiling, 1);
3386 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3387 deleting the eval's FILEGV from the stash before gv_check() runs
3388 (i.e. before run-time proper). To work around the coredump that
3389 ensues, we always turn GvMULTI_on for any globals that were
3390 introduced within evals. See force_ident(). GSAR 96-10-12 */
3391 safestr = savepv(tmpbuf);
3392 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3394 PL_hints = PL_op->op_targ;
3395 SAVESPTR(PL_compiling.cop_warnings);
3396 if (specialWARN(PL_curcop->cop_warnings))
3397 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3399 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3400 SAVEFREESV(PL_compiling.cop_warnings);
3402 SAVESPTR(PL_compiling.cop_io);
3403 if (specialCopIO(PL_curcop->cop_io))
3404 PL_compiling.cop_io = PL_curcop->cop_io;
3406 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3407 SAVEFREESV(PL_compiling.cop_io);
3409 /* special case: an eval '' executed within the DB package gets lexically
3410 * placed in the first non-DB CV rather than the current CV - this
3411 * allows the debugger to execute code, find lexicals etc, in the
3412 * scope of the code being debugged. Passing &seq gets find_runcv
3413 * to do the dirty work for us */
3414 runcv = find_runcv(&seq);
3416 push_return(PL_op->op_next);
3417 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3418 PUSHEVAL(cx, 0, Nullgv);
3420 /* prepare to compile string */
3422 if (PERLDB_LINE && PL_curstash != PL_debstash)
3423 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3425 ret = doeval(gimme, NULL, runcv, seq);
3426 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3427 && ret != PL_op->op_next) { /* Successive compilation. */
3428 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3430 return DOCATCH(ret);
3440 register PERL_CONTEXT *cx;
3442 U8 save_flags = PL_op -> op_flags;
3447 retop = pop_return();
3450 if (gimme == G_VOID)
3452 else if (gimme == G_SCALAR) {
3455 if (SvFLAGS(TOPs) & SVs_TEMP)
3458 *MARK = sv_mortalcopy(TOPs);
3462 *MARK = &PL_sv_undef;
3467 /* in case LEAVE wipes old return values */
3468 for (mark = newsp + 1; mark <= SP; mark++) {
3469 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3470 *mark = sv_mortalcopy(*mark);
3471 TAINT_NOT; /* Each item is independent */
3475 PL_curpm = newpm; /* Don't pop $1 et al till now */
3478 assert(CvDEPTH(PL_compcv) == 1);
3480 CvDEPTH(PL_compcv) = 0;
3483 if (optype == OP_REQUIRE &&
3484 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3486 /* Unassume the success we assumed earlier. */
3487 SV *nsv = cx->blk_eval.old_namesv;
3488 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3489 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3490 /* die_where() did LEAVE, or we won't be here */
3494 if (!(save_flags & OPf_SPECIAL))
3504 register PERL_CONTEXT *cx;
3505 I32 gimme = GIMME_V;
3510 push_return(cLOGOP->op_other->op_next);
3511 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3514 PL_in_eval = EVAL_INEVAL;
3517 return DOCATCH(PL_op->op_next);
3528 register PERL_CONTEXT *cx;
3533 retop = pop_return();
3536 if (gimme == G_VOID)
3538 else if (gimme == G_SCALAR) {
3541 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3544 *MARK = sv_mortalcopy(TOPs);
3548 *MARK = &PL_sv_undef;
3553 /* in case LEAVE wipes old return values */
3554 for (mark = newsp + 1; mark <= SP; mark++) {
3555 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3556 *mark = sv_mortalcopy(*mark);
3557 TAINT_NOT; /* Each item is independent */
3561 PL_curpm = newpm; /* Don't pop $1 et al till now */
3569 S_doparseform(pTHX_ SV *sv)
3572 register char *s = SvPV_force(sv, len);
3573 register char *send = s + len;
3574 register char *base = Nullch;
3575 register I32 skipspaces = 0;
3576 bool noblank = FALSE;
3577 bool repeat = FALSE;
3578 bool postspace = FALSE;
3584 bool unchopnum = FALSE;
3585 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3588 Perl_croak(aTHX_ "Null picture in formline");
3590 /* estimate the buffer size needed */
3591 for (base = s; s <= send; s++) {
3592 if (*s == '\n' || *s == '@' || *s == '^')
3598 New(804, fops, maxops, U32);
3603 *fpc++ = FF_LINEMARK;
3604 noblank = repeat = FALSE;
3622 case ' ': case '\t':
3629 } /* else FALL THROUGH */
3637 *fpc++ = FF_LITERAL;
3645 *fpc++ = (U16)skipspaces;
3649 *fpc++ = FF_NEWLINE;
3653 arg = fpc - linepc + 1;
3660 *fpc++ = FF_LINEMARK;
3661 noblank = repeat = FALSE;
3670 ischop = s[-1] == '^';
3676 arg = (s - base) - 1;
3678 *fpc++ = FF_LITERAL;
3686 *fpc++ = 2; /* skip the @* or ^* */
3688 *fpc++ = FF_LINESNGL;
3691 *fpc++ = FF_LINEGLOB;
3693 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3694 arg = ischop ? 512 : 0;
3704 arg |= 256 + (s - f);
3706 *fpc++ = s - base; /* fieldsize for FETCH */
3707 *fpc++ = FF_DECIMAL;
3709 unchopnum |= ! ischop;
3711 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3712 arg = ischop ? 512 : 0;
3714 s++; /* skip the '0' first */
3723 arg |= 256 + (s - f);
3725 *fpc++ = s - base; /* fieldsize for FETCH */
3726 *fpc++ = FF_0DECIMAL;
3728 unchopnum |= ! ischop;
3732 bool ismore = FALSE;
3735 while (*++s == '>') ;
3736 prespace = FF_SPACE;
3738 else if (*s == '|') {
3739 while (*++s == '|') ;
3740 prespace = FF_HALFSPACE;
3745 while (*++s == '<') ;
3748 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3752 *fpc++ = s - base; /* fieldsize for FETCH */
3754 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3757 *fpc++ = (U16)prespace;
3771 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3773 { /* need to jump to the next word */
3775 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3776 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3777 s = SvPVX(sv) + SvCUR(sv) + z;
3779 Copy(fops, s, arg, U32);
3781 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3784 if (unchopnum && repeat)
3785 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3791 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3793 /* Can value be printed in fldsize chars, using %*.*f ? */
3797 int intsize = fldsize - (value < 0 ? 1 : 0);
3804 while (intsize--) pwr *= 10.0;
3805 while (frcsize--) eps /= 10.0;
3808 if (value + eps >= pwr)
3811 if (value - eps <= -pwr)
3818 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3820 SV *datasv = FILTER_DATA(idx);
3821 int filter_has_file = IoLINES(datasv);
3822 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3823 SV *filter_state = (SV *)IoTOP_GV(datasv);
3824 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3827 /* I was having segfault trouble under Linux 2.2.5 after a
3828 parse error occured. (Had to hack around it with a test
3829 for PL_error_count == 0.) Solaris doesn't segfault --
3830 not sure where the trouble is yet. XXX */
3832 if (filter_has_file) {
3833 len = FILTER_READ(idx+1, buf_sv, maxlen);
3836 if (filter_sub && len >= 0) {
3847 PUSHs(sv_2mortal(newSViv(maxlen)));
3849 PUSHs(filter_state);
3852 count = call_sv(filter_sub, G_SCALAR);
3868 IoLINES(datasv) = 0;
3869 if (filter_child_proc) {
3870 SvREFCNT_dec(filter_child_proc);
3871 IoFMT_GV(datasv) = Nullgv;
3874 SvREFCNT_dec(filter_state);
3875 IoTOP_GV(datasv) = Nullgv;
3878 SvREFCNT_dec(filter_sub);
3879 IoBOTTOM_GV(datasv) = Nullgv;
3881 filter_del(run_user_filter);
3887 /* perhaps someone can come up with a better name for
3888 this? it is not really "absolute", per se ... */
3890 S_path_is_absolute(pTHX_ char *name)
3892 if (PERL_FILE_IS_ABSOLUTE(name)
3893 #ifdef MACOS_TRADITIONAL
3896 || (*name == '.' && (name[1] == '/' ||
3897 (name[1] == '.' && name[2] == '/'))))