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 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
868 ENTER; /* enter inner scope */
871 src = PL_stack_base[*PL_markstack_ptr];
876 if (PL_op->op_type == OP_MAPSTART)
877 pp_pushmark(); /* push top */
878 return ((LOGOP*)PL_op->op_next)->op_other;
883 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
890 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
896 /* first, move source pointer to the next item in the source list */
897 ++PL_markstack_ptr[-1];
899 /* if there are new items, push them into the destination list */
900 if (items && gimme != G_VOID) {
901 /* might need to make room back there first */
902 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
903 /* XXX this implementation is very pessimal because the stack
904 * is repeatedly extended for every set of items. Is possible
905 * to do this without any stack extension or copying at all
906 * by maintaining a separate list over which the map iterates
907 * (like foreach does). --gsar */
909 /* everything in the stack after the destination list moves
910 * towards the end the stack by the amount of room needed */
911 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
913 /* items to shift up (accounting for the moved source pointer) */
914 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
916 /* This optimization is by Ben Tilly and it does
917 * things differently from what Sarathy (gsar)
918 * is describing. The downside of this optimization is
919 * that leaves "holes" (uninitialized and hopefully unused areas)
920 * to the Perl stack, but on the other hand this
921 * shouldn't be a problem. If Sarathy's idea gets
922 * implemented, this optimization should become
923 * irrelevant. --jhi */
925 shift = count; /* Avoid shifting too often --Ben Tilly */
930 PL_markstack_ptr[-1] += shift;
931 *PL_markstack_ptr += shift;
935 /* copy the new items down to the destination list */
936 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
938 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
940 LEAVE; /* exit inner scope */
943 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
945 (void)POPMARK; /* pop top */
946 LEAVE; /* exit outer scope */
947 (void)POPMARK; /* pop src */
948 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
949 (void)POPMARK; /* pop dst */
950 SP = PL_stack_base + POPMARK; /* pop original mark */
951 if (gimme == G_SCALAR) {
955 else if (gimme == G_ARRAY)
962 ENTER; /* enter inner scope */
965 /* set $_ to the new source item */
966 src = PL_stack_base[PL_markstack_ptr[-1]];
970 RETURNOP(cLOGOP->op_other);
978 if (GIMME == G_ARRAY)
980 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
981 return cLOGOP->op_other;
990 if (GIMME == G_ARRAY) {
991 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
995 SV *targ = PAD_SV(PL_op->op_targ);
998 if (PL_op->op_private & OPpFLIP_LINENUM) {
999 if (GvIO(PL_last_in_gv)) {
1000 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1003 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1004 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1010 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1011 if (PL_op->op_flags & OPf_SPECIAL) {
1019 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1028 /* This code tries to decide if "$left .. $right" should use the
1029 magical string increment, or if the range is numeric (we make
1030 an exception for .."0" [#18165]). AMS 20021031. */
1032 #define RANGE_IS_NUMERIC(left,right) ( \
1033 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1034 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1035 (looks_like_number(left) && SvPOKp(left) && *SvPVX(left) != '0' && \
1036 looks_like_number(right)))
1042 if (GIMME == G_ARRAY) {
1048 if (SvGMAGICAL(left))
1050 if (SvGMAGICAL(right))
1053 if (RANGE_IS_NUMERIC(left,right)) {
1054 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1055 DIE(aTHX_ "Range iterator outside integer range");
1066 sv = sv_2mortal(newSViv(i++));
1071 SV *final = sv_mortalcopy(right);
1073 char *tmps = SvPV(final, len);
1075 sv = sv_mortalcopy(left);
1077 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1079 if (strEQ(SvPVX(sv),tmps))
1081 sv = sv_2mortal(newSVsv(sv));
1088 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1092 if (PL_op->op_private & OPpFLIP_LINENUM) {
1093 if (GvIO(PL_last_in_gv)) {
1094 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1097 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1098 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1106 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1107 sv_catpv(targ, "E0");
1117 static char *context_name[] = {
1128 S_dopoptolabel(pTHX_ char *label)
1131 register PERL_CONTEXT *cx;
1133 for (i = cxstack_ix; i >= 0; i--) {
1135 switch (CxTYPE(cx)) {
1141 if (ckWARN(WARN_EXITING))
1142 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1143 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1144 if (CxTYPE(cx) == CXt_NULL)
1148 if (!cx->blk_loop.label ||
1149 strNE(label, cx->blk_loop.label) ) {
1150 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1151 (long)i, cx->blk_loop.label));
1154 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1162 Perl_dowantarray(pTHX)
1164 I32 gimme = block_gimme();
1165 return (gimme == G_VOID) ? G_SCALAR : gimme;
1169 Perl_block_gimme(pTHX)
1173 cxix = dopoptosub(cxstack_ix);
1177 switch (cxstack[cxix].blk_gimme) {
1185 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1192 Perl_is_lvalue_sub(pTHX)
1196 cxix = dopoptosub(cxstack_ix);
1197 assert(cxix >= 0); /* We should only be called from inside subs */
1199 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1200 return cxstack[cxix].blk_sub.lval;
1206 S_dopoptosub(pTHX_ I32 startingblock)
1208 return dopoptosub_at(cxstack, startingblock);
1212 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1215 register PERL_CONTEXT *cx;
1216 for (i = startingblock; i >= 0; i--) {
1218 switch (CxTYPE(cx)) {
1224 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1232 S_dopoptoeval(pTHX_ I32 startingblock)
1235 register PERL_CONTEXT *cx;
1236 for (i = startingblock; i >= 0; i--) {
1238 switch (CxTYPE(cx)) {
1242 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1250 S_dopoptoloop(pTHX_ I32 startingblock)
1253 register PERL_CONTEXT *cx;
1254 for (i = startingblock; i >= 0; i--) {
1256 switch (CxTYPE(cx)) {
1262 if (ckWARN(WARN_EXITING))
1263 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1264 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1265 if ((CxTYPE(cx)) == CXt_NULL)
1269 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1277 Perl_dounwind(pTHX_ I32 cxix)
1279 register PERL_CONTEXT *cx;
1282 while (cxstack_ix > cxix) {
1284 cx = &cxstack[cxstack_ix];
1285 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1286 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1287 /* Note: we don't need to restore the base context info till the end. */
1288 switch (CxTYPE(cx)) {
1291 continue; /* not break */
1313 Perl_qerror(pTHX_ SV *err)
1316 sv_catsv(ERRSV, err);
1318 sv_catsv(PL_errors, err);
1320 Perl_warn(aTHX_ "%"SVf, err);
1325 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1331 register PERL_CONTEXT *cx;
1336 if (PL_in_eval & EVAL_KEEPERR) {
1337 static char prefix[] = "\t(in cleanup) ";
1342 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1345 if (*e != *message || strNE(e,message))
1349 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1350 sv_catpvn(err, prefix, sizeof(prefix)-1);
1351 sv_catpvn(err, message, msglen);
1352 if (ckWARN(WARN_MISC)) {
1353 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1354 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1359 sv_setpvn(ERRSV, message, msglen);
1363 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1364 && PL_curstackinfo->si_prev)
1373 if (cxix < cxstack_ix)
1376 POPBLOCK(cx,PL_curpm);
1377 if (CxTYPE(cx) != CXt_EVAL) {
1379 message = SvPVx(ERRSV, msglen);
1380 PerlIO_write(Perl_error_log, "panic: die ", 11);
1381 PerlIO_write(Perl_error_log, message, msglen);
1386 if (gimme == G_SCALAR)
1387 *++newsp = &PL_sv_undef;
1388 PL_stack_sp = newsp;
1392 /* LEAVE could clobber PL_curcop (see save_re_context())
1393 * XXX it might be better to find a way to avoid messing with
1394 * PL_curcop in save_re_context() instead, but this is a more
1395 * minimal fix --GSAR */
1396 PL_curcop = cx->blk_oldcop;
1398 if (optype == OP_REQUIRE) {
1399 char* msg = SvPVx(ERRSV, n_a);
1400 SV *nsv = cx->blk_eval.old_namesv;
1401 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1403 DIE(aTHX_ "%sCompilation failed in require",
1404 *msg ? msg : "Unknown error\n");
1406 return pop_return();
1410 message = SvPVx(ERRSV, msglen);
1412 write_to_stderr(message, msglen);
1421 if (SvTRUE(left) != SvTRUE(right))
1433 RETURNOP(cLOGOP->op_other);
1442 RETURNOP(cLOGOP->op_other);
1451 if (!sv || !SvANY(sv)) {
1452 RETURNOP(cLOGOP->op_other);
1455 switch (SvTYPE(sv)) {
1457 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1461 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1465 if (CvROOT(sv) || CvXSUB(sv))
1475 RETURNOP(cLOGOP->op_other);
1481 register I32 cxix = dopoptosub(cxstack_ix);
1482 register PERL_CONTEXT *cx;
1483 register PERL_CONTEXT *ccstack = cxstack;
1484 PERL_SI *top_si = PL_curstackinfo;
1495 /* we may be in a higher stacklevel, so dig down deeper */
1496 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1497 top_si = top_si->si_prev;
1498 ccstack = top_si->si_cxstack;
1499 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1502 if (GIMME != G_ARRAY) {
1508 if (PL_DBsub && cxix >= 0 &&
1509 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1513 cxix = dopoptosub_at(ccstack, cxix - 1);
1516 cx = &ccstack[cxix];
1517 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1518 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1519 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1520 field below is defined for any cx. */
1521 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1522 cx = &ccstack[dbcxix];
1525 stashname = CopSTASHPV(cx->blk_oldcop);
1526 if (GIMME != G_ARRAY) {
1529 PUSHs(&PL_sv_undef);
1532 sv_setpv(TARG, stashname);
1541 PUSHs(&PL_sv_undef);
1543 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1544 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1545 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1548 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1549 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1550 /* So is ccstack[dbcxix]. */
1553 gv_efullname3(sv, cvgv, Nullch);
1554 PUSHs(sv_2mortal(sv));
1555 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1558 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1559 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1563 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1564 PUSHs(sv_2mortal(newSViv(0)));
1566 gimme = (I32)cx->blk_gimme;
1567 if (gimme == G_VOID)
1568 PUSHs(&PL_sv_undef);
1570 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1571 if (CxTYPE(cx) == CXt_EVAL) {
1573 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1574 PUSHs(cx->blk_eval.cur_text);
1578 else if (cx->blk_eval.old_namesv) {
1579 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1582 /* eval BLOCK (try blocks have old_namesv == 0) */
1584 PUSHs(&PL_sv_undef);
1585 PUSHs(&PL_sv_undef);
1589 PUSHs(&PL_sv_undef);
1590 PUSHs(&PL_sv_undef);
1592 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1593 && CopSTASH_eq(PL_curcop, PL_debstash))
1595 AV *ary = cx->blk_sub.argarray;
1596 int off = AvARRAY(ary) - AvALLOC(ary);
1600 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1603 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1606 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1607 av_extend(PL_dbargs, AvFILLp(ary) + off);
1608 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1609 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1611 /* XXX only hints propagated via op_private are currently
1612 * visible (others are not easily accessible, since they
1613 * use the global PL_hints) */
1614 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1615 HINT_PRIVATE_MASK)));
1618 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1620 if (old_warnings == pWARN_NONE ||
1621 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1622 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1623 else if (old_warnings == pWARN_ALL ||
1624 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1625 /* Get the bit mask for $warnings::Bits{all}, because
1626 * it could have been extended by warnings::register */
1628 HV *bits = get_hv("warnings::Bits", FALSE);
1629 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1630 mask = newSVsv(*bits_all);
1633 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1637 mask = newSVsv(old_warnings);
1638 PUSHs(sv_2mortal(mask));
1653 sv_reset(tmps, CopSTASH(PL_curcop));
1663 /* like pp_nextstate, but used instead when the debugger is active */
1667 PL_curcop = (COP*)PL_op;
1668 TAINT_NOT; /* Each statement is presumed innocent */
1669 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1672 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1673 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1677 register PERL_CONTEXT *cx;
1678 I32 gimme = G_ARRAY;
1685 DIE(aTHX_ "No DB::DB routine defined");
1687 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1688 /* don't do recursive DB::DB call */
1700 push_return(PL_op->op_next);
1701 PUSHBLOCK(cx, CXt_SUB, SP);
1704 PAD_SET_CUR(CvPADLIST(cv),1);
1705 RETURNOP(CvSTART(cv));
1719 register PERL_CONTEXT *cx;
1720 I32 gimme = GIMME_V;
1722 U32 cxtype = CXt_LOOP;
1730 if (PL_op->op_targ) {
1731 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1732 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1733 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1734 SVs_PADSTALE, SVs_PADSTALE);
1736 #ifndef USE_ITHREADS
1737 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1740 SAVEPADSV(PL_op->op_targ);
1741 iterdata = INT2PTR(void*, PL_op->op_targ);
1742 cxtype |= CXp_PADVAR;
1747 svp = &GvSV(gv); /* symbol table variable */
1748 SAVEGENERICSV(*svp);
1751 iterdata = (void*)gv;
1757 PUSHBLOCK(cx, cxtype, SP);
1759 PUSHLOOP(cx, iterdata, MARK);
1761 PUSHLOOP(cx, svp, MARK);
1763 if (PL_op->op_flags & OPf_STACKED) {
1764 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1765 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1767 if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
1768 if (SvNV(sv) < IV_MIN ||
1769 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1770 DIE(aTHX_ "Range iterator outside integer range");
1771 cx->blk_loop.iterix = SvIV(sv);
1772 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1775 cx->blk_loop.iterlval = newSVsv(sv);
1779 cx->blk_loop.iterary = PL_curstack;
1780 AvFILLp(PL_curstack) = SP - PL_stack_base;
1781 cx->blk_loop.iterix = MARK - PL_stack_base;
1790 register PERL_CONTEXT *cx;
1791 I32 gimme = GIMME_V;
1797 PUSHBLOCK(cx, CXt_LOOP, SP);
1798 PUSHLOOP(cx, 0, SP);
1806 register PERL_CONTEXT *cx;
1814 newsp = PL_stack_base + cx->blk_loop.resetsp;
1817 if (gimme == G_VOID)
1819 else if (gimme == G_SCALAR) {
1821 *++newsp = sv_mortalcopy(*SP);
1823 *++newsp = &PL_sv_undef;
1827 *++newsp = sv_mortalcopy(*++mark);
1828 TAINT_NOT; /* Each item is independent */
1834 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1835 PL_curpm = newpm; /* ... and pop $1 et al */
1847 register PERL_CONTEXT *cx;
1848 bool popsub2 = FALSE;
1849 bool clear_errsv = FALSE;
1856 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1857 if (cxstack_ix == PL_sortcxix
1858 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1860 if (cxstack_ix > PL_sortcxix)
1861 dounwind(PL_sortcxix);
1862 AvARRAY(PL_curstack)[1] = *SP;
1863 PL_stack_sp = PL_stack_base + 1;
1868 cxix = dopoptosub(cxstack_ix);
1870 DIE(aTHX_ "Can't return outside a subroutine");
1871 if (cxix < cxstack_ix)
1875 switch (CxTYPE(cx)) {
1878 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1881 if (!(PL_in_eval & EVAL_KEEPERR))
1887 if (optype == OP_REQUIRE &&
1888 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1890 /* Unassume the success we assumed earlier. */
1891 SV *nsv = cx->blk_eval.old_namesv;
1892 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1893 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1900 DIE(aTHX_ "panic: return");
1904 if (gimme == G_SCALAR) {
1907 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1909 *++newsp = SvREFCNT_inc(*SP);
1914 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1916 *++newsp = sv_mortalcopy(sv);
1921 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1924 *++newsp = sv_mortalcopy(*SP);
1927 *++newsp = &PL_sv_undef;
1929 else if (gimme == G_ARRAY) {
1930 while (++MARK <= SP) {
1931 *++newsp = (popsub2 && SvTEMP(*MARK))
1932 ? *MARK : sv_mortalcopy(*MARK);
1933 TAINT_NOT; /* Each item is independent */
1936 PL_stack_sp = newsp;
1939 /* Stack values are safe: */
1942 POPSUB(cx,sv); /* release CV and @_ ... */
1946 PL_curpm = newpm; /* ... and pop $1 et al */
1951 return pop_return();
1958 register PERL_CONTEXT *cx;
1968 if (PL_op->op_flags & OPf_SPECIAL) {
1969 cxix = dopoptoloop(cxstack_ix);
1971 DIE(aTHX_ "Can't \"last\" outside a loop block");
1974 cxix = dopoptolabel(cPVOP->op_pv);
1976 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1978 if (cxix < cxstack_ix)
1982 cxstack_ix++; /* temporarily protect top context */
1984 switch (CxTYPE(cx)) {
1987 newsp = PL_stack_base + cx->blk_loop.resetsp;
1988 nextop = cx->blk_loop.last_op->op_next;
1992 nextop = pop_return();
1996 nextop = pop_return();
2000 nextop = pop_return();
2003 DIE(aTHX_ "panic: last");
2007 if (gimme == G_SCALAR) {
2009 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2010 ? *SP : sv_mortalcopy(*SP);
2012 *++newsp = &PL_sv_undef;
2014 else if (gimme == G_ARRAY) {
2015 while (++MARK <= SP) {
2016 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2017 ? *MARK : sv_mortalcopy(*MARK);
2018 TAINT_NOT; /* Each item is independent */
2026 /* Stack values are safe: */
2029 POPLOOP(cx); /* release loop vars ... */
2033 POPSUB(cx,sv); /* release CV and @_ ... */
2036 PL_curpm = newpm; /* ... and pop $1 et al */
2045 register PERL_CONTEXT *cx;
2048 if (PL_op->op_flags & OPf_SPECIAL) {
2049 cxix = dopoptoloop(cxstack_ix);
2051 DIE(aTHX_ "Can't \"next\" outside a loop block");
2054 cxix = dopoptolabel(cPVOP->op_pv);
2056 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2058 if (cxix < cxstack_ix)
2061 /* clear off anything above the scope we're re-entering, but
2062 * save the rest until after a possible continue block */
2063 inner = PL_scopestack_ix;
2065 if (PL_scopestack_ix < inner)
2066 leave_scope(PL_scopestack[PL_scopestack_ix]);
2067 return cx->blk_loop.next_op;
2073 register PERL_CONTEXT *cx;
2076 if (PL_op->op_flags & OPf_SPECIAL) {
2077 cxix = dopoptoloop(cxstack_ix);
2079 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2082 cxix = dopoptolabel(cPVOP->op_pv);
2084 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2086 if (cxix < cxstack_ix)
2090 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2091 LEAVE_SCOPE(oldsave);
2092 return cx->blk_loop.redo_op;
2096 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2100 static char too_deep[] = "Target of goto is too deeply nested";
2103 Perl_croak(aTHX_ too_deep);
2104 if (o->op_type == OP_LEAVE ||
2105 o->op_type == OP_SCOPE ||
2106 o->op_type == OP_LEAVELOOP ||
2107 o->op_type == OP_LEAVESUB ||
2108 o->op_type == OP_LEAVETRY)
2110 *ops++ = cUNOPo->op_first;
2112 Perl_croak(aTHX_ too_deep);
2115 if (o->op_flags & OPf_KIDS) {
2116 /* First try all the kids at this level, since that's likeliest. */
2117 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2118 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2119 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2122 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2123 if (kid == PL_lastgotoprobe)
2125 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2128 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2129 ops[-1]->op_type == OP_DBSTATE)
2134 if ((o = dofindlabel(kid, label, ops, oplimit)))
2153 register PERL_CONTEXT *cx;
2154 #define GOTO_DEPTH 64
2155 OP *enterops[GOTO_DEPTH];
2157 int do_dump = (PL_op->op_type == OP_DUMP);
2158 static char must_have_label[] = "goto must have label";
2161 if (PL_op->op_flags & OPf_STACKED) {
2165 /* This egregious kludge implements goto &subroutine */
2166 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2168 register PERL_CONTEXT *cx;
2169 CV* cv = (CV*)SvRV(sv);
2175 if (!CvROOT(cv) && !CvXSUB(cv)) {
2180 /* autoloaded stub? */
2181 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2183 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2184 GvNAMELEN(gv), FALSE);
2185 if (autogv && (cv = GvCV(autogv)))
2187 tmpstr = sv_newmortal();
2188 gv_efullname3(tmpstr, gv, Nullch);
2189 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2191 DIE(aTHX_ "Goto undefined subroutine");
2194 /* First do some returnish stuff. */
2195 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2197 cxix = dopoptosub(cxstack_ix);
2199 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2200 if (cxix < cxstack_ix)
2204 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2206 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2207 /* put @_ back onto stack */
2208 AV* av = cx->blk_sub.argarray;
2210 items = AvFILLp(av) + 1;
2212 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2213 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2214 PL_stack_sp += items;
2215 SvREFCNT_dec(GvAV(PL_defgv));
2216 GvAV(PL_defgv) = cx->blk_sub.savearray;
2217 /* abandon @_ if it got reified */
2219 (void)sv_2mortal((SV*)av); /* delay until return */
2221 av_extend(av, items-1);
2222 AvFLAGS(av) = AVf_REIFY;
2223 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2228 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2230 av = GvAV(PL_defgv);
2231 items = AvFILLp(av) + 1;
2233 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2234 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2235 PL_stack_sp += items;
2237 if (CxTYPE(cx) == CXt_SUB &&
2238 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2239 SvREFCNT_dec(cx->blk_sub.cv);
2240 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2241 LEAVE_SCOPE(oldsave);
2243 /* Now do some callish stuff. */
2245 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2247 #ifdef PERL_XSUB_OLDSTYLE
2248 if (CvOLDSTYLE(cv)) {
2249 I32 (*fp3)(int,int,int);
2254 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2255 items = (*fp3)(CvXSUBANY(cv).any_i32,
2256 mark - PL_stack_base + 1,
2258 SP = PL_stack_base + items;
2261 #endif /* PERL_XSUB_OLDSTYLE */
2266 PL_stack_sp--; /* There is no cv arg. */
2267 /* Push a mark for the start of arglist */
2269 (void)(*CvXSUB(cv))(aTHX_ cv);
2270 /* Pop the current context like a decent sub should */
2271 POPBLOCK(cx, PL_curpm);
2272 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2275 return pop_return();
2278 AV* padlist = CvPADLIST(cv);
2279 if (CxTYPE(cx) == CXt_EVAL) {
2280 PL_in_eval = cx->blk_eval.old_in_eval;
2281 PL_eval_root = cx->blk_eval.old_eval_root;
2282 cx->cx_type = CXt_SUB;
2283 cx->blk_sub.hasargs = 0;
2285 cx->blk_sub.cv = cv;
2286 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2289 if (CvDEPTH(cv) < 2)
2290 (void)SvREFCNT_inc(cv);
2292 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2293 sub_crush_depth(cv);
2294 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2296 PAD_SET_CUR(padlist, CvDEPTH(cv));
2297 if (cx->blk_sub.hasargs)
2299 AV* av = (AV*)PAD_SVl(0);
2302 cx->blk_sub.savearray = GvAV(PL_defgv);
2303 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2304 CX_CURPAD_SAVE(cx->blk_sub);
2305 cx->blk_sub.argarray = av;
2308 if (items >= AvMAX(av) + 1) {
2310 if (AvARRAY(av) != ary) {
2311 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2312 SvPVX(av) = (char*)ary;
2314 if (items >= AvMAX(av) + 1) {
2315 AvMAX(av) = items - 1;
2316 Renew(ary,items+1,SV*);
2318 SvPVX(av) = (char*)ary;
2321 Copy(mark,AvARRAY(av),items,SV*);
2322 AvFILLp(av) = items - 1;
2323 assert(!AvREAL(av));
2330 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2332 * We do not care about using sv to call CV;
2333 * it's for informational purposes only.
2335 SV *sv = GvSV(PL_DBsub);
2338 if (PERLDB_SUB_NN) {
2339 (void)SvUPGRADE(sv, SVt_PVIV);
2342 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2345 gv_efullname3(sv, CvGV(cv), Nullch);
2348 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2349 PUSHMARK( PL_stack_sp );
2350 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2354 RETURNOP(CvSTART(cv));
2358 label = SvPV(sv,n_a);
2359 if (!(do_dump || *label))
2360 DIE(aTHX_ must_have_label);
2363 else if (PL_op->op_flags & OPf_SPECIAL) {
2365 DIE(aTHX_ must_have_label);
2368 label = cPVOP->op_pv;
2370 if (label && *label) {
2372 bool leaving_eval = FALSE;
2373 bool in_block = FALSE;
2374 PERL_CONTEXT *last_eval_cx = 0;
2378 PL_lastgotoprobe = 0;
2380 for (ix = cxstack_ix; ix >= 0; ix--) {
2382 switch (CxTYPE(cx)) {
2384 leaving_eval = TRUE;
2385 if (!CxTRYBLOCK(cx)) {
2386 gotoprobe = (last_eval_cx ?
2387 last_eval_cx->blk_eval.old_eval_root :
2392 /* else fall through */
2394 gotoprobe = cx->blk_oldcop->op_sibling;
2400 gotoprobe = cx->blk_oldcop->op_sibling;
2403 gotoprobe = PL_main_root;
2406 if (CvDEPTH(cx->blk_sub.cv)) {
2407 gotoprobe = CvROOT(cx->blk_sub.cv);
2413 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2416 DIE(aTHX_ "panic: goto");
2417 gotoprobe = PL_main_root;
2421 retop = dofindlabel(gotoprobe, label,
2422 enterops, enterops + GOTO_DEPTH);
2426 PL_lastgotoprobe = gotoprobe;
2429 DIE(aTHX_ "Can't find label %s", label);
2431 /* if we're leaving an eval, check before we pop any frames
2432 that we're not going to punt, otherwise the error
2435 if (leaving_eval && *enterops && enterops[1]) {
2437 for (i = 1; enterops[i]; i++)
2438 if (enterops[i]->op_type == OP_ENTERITER)
2439 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2442 /* pop unwanted frames */
2444 if (ix < cxstack_ix) {
2451 oldsave = PL_scopestack[PL_scopestack_ix];
2452 LEAVE_SCOPE(oldsave);
2455 /* push wanted frames */
2457 if (*enterops && enterops[1]) {
2459 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2460 for (; enterops[ix]; ix++) {
2461 PL_op = enterops[ix];
2462 /* Eventually we may want to stack the needed arguments
2463 * for each op. For now, we punt on the hard ones. */
2464 if (PL_op->op_type == OP_ENTERITER)
2465 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2466 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2474 if (!retop) retop = PL_main_start;
2476 PL_restartop = retop;
2477 PL_do_undump = TRUE;
2481 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2482 PL_do_undump = FALSE;
2498 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2500 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2503 PL_exit_flags |= PERL_EXIT_EXPECTED;
2505 PUSHs(&PL_sv_undef);
2513 NV value = SvNVx(GvSV(cCOP->cop_gv));
2514 register I32 match = I_32(value);
2517 if (((NV)match) > value)
2518 --match; /* was fractional--truncate other way */
2520 match -= cCOP->uop.scop.scop_offset;
2523 else if (match > cCOP->uop.scop.scop_max)
2524 match = cCOP->uop.scop.scop_max;
2525 PL_op = cCOP->uop.scop.scop_next[match];
2535 PL_op = PL_op->op_next; /* can't assume anything */
2538 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2539 match -= cCOP->uop.scop.scop_offset;
2542 else if (match > cCOP->uop.scop.scop_max)
2543 match = cCOP->uop.scop.scop_max;
2544 PL_op = cCOP->uop.scop.scop_next[match];
2553 S_save_lines(pTHX_ AV *array, SV *sv)
2555 register char *s = SvPVX(sv);
2556 register char *send = SvPVX(sv) + SvCUR(sv);
2558 register I32 line = 1;
2560 while (s && s < send) {
2561 SV *tmpstr = NEWSV(85,0);
2563 sv_upgrade(tmpstr, SVt_PVMG);
2564 t = strchr(s, '\n');
2570 sv_setpvn(tmpstr, s, t - s);
2571 av_store(array, line++, tmpstr);
2576 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2578 S_docatch_body(pTHX_ va_list args)
2580 return docatch_body();
2585 S_docatch_body(pTHX)
2592 S_docatch(pTHX_ OP *o)
2597 volatile PERL_SI *cursi = PL_curstackinfo;
2601 assert(CATCH_GET == TRUE);
2605 /* Normally, the leavetry at the end of this block of ops will
2606 * pop an op off the return stack and continue there. By setting
2607 * the op to Nullop, we force an exit from the inner runops()
2610 retop = pop_return();
2611 push_return(Nullop);
2613 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2615 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2621 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2627 /* die caught by an inner eval - continue inner loop */
2628 if (PL_restartop && cursi == PL_curstackinfo) {
2629 PL_op = PL_restartop;
2633 /* a die in this eval - continue in outer loop */
2649 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2650 /* sv Text to convert to OP tree. */
2651 /* startop op_free() this to undo. */
2652 /* code Short string id of the caller. */
2654 dSP; /* Make POPBLOCK work. */
2657 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2661 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2662 char *tmpbuf = tbuf;
2665 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2670 /* switch to eval mode */
2672 if (IN_PERL_COMPILETIME) {
2673 SAVECOPSTASH_FREE(&PL_compiling);
2674 CopSTASH_set(&PL_compiling, PL_curstash);
2676 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2677 SV *sv = sv_newmortal();
2678 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2679 code, (unsigned long)++PL_evalseq,
2680 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2684 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2685 SAVECOPFILE_FREE(&PL_compiling);
2686 CopFILE_set(&PL_compiling, tmpbuf+2);
2687 SAVECOPLINE(&PL_compiling);
2688 CopLINE_set(&PL_compiling, 1);
2689 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2690 deleting the eval's FILEGV from the stash before gv_check() runs
2691 (i.e. before run-time proper). To work around the coredump that
2692 ensues, we always turn GvMULTI_on for any globals that were
2693 introduced within evals. See force_ident(). GSAR 96-10-12 */
2694 safestr = savepv(tmpbuf);
2695 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2697 #ifdef OP_IN_REGISTER
2702 PL_hints &= HINT_UTF8;
2704 /* we get here either during compilation, or via pp_regcomp at runtime */
2705 runtime = IN_PERL_RUNTIME;
2707 runcv = find_runcv(NULL);
2710 PL_op->op_type = OP_ENTEREVAL;
2711 PL_op->op_flags = 0; /* Avoid uninit warning. */
2712 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2713 PUSHEVAL(cx, 0, Nullgv);
2716 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2718 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2719 POPBLOCK(cx,PL_curpm);
2722 (*startop)->op_type = OP_NULL;
2723 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2725 /* XXX DAPM do this properly one year */
2726 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2728 if (IN_PERL_COMPILETIME)
2729 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2730 #ifdef OP_IN_REGISTER
2738 =for apidoc find_runcv
2740 Locate the CV corresponding to the currently executing sub or eval.
2741 If db_seqp is non_null, skip CVs that are in the DB package and populate
2742 *db_seqp with the cop sequence number at the point that the DB:: code was
2743 entered. (allows debuggers to eval in the scope of the breakpoint rather
2744 than in in the scope of the debuger itself).
2750 Perl_find_runcv(pTHX_ U32 *db_seqp)
2757 *db_seqp = PL_curcop->cop_seq;
2758 for (si = PL_curstackinfo; si; si = si->si_prev) {
2759 for (ix = si->si_cxix; ix >= 0; ix--) {
2760 cx = &(si->si_cxstack[ix]);
2761 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2762 CV *cv = cx->blk_sub.cv;
2763 /* skip DB:: code */
2764 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2765 *db_seqp = cx->blk_oldcop->cop_seq;
2770 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2778 /* Compile a require/do, an eval '', or a /(?{...})/.
2779 * In the last case, startop is non-null, and contains the address of
2780 * a pointer that should be set to the just-compiled code.
2781 * outside is the lexically enclosing CV (if any) that invoked us.
2784 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2786 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2791 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2792 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2797 SAVESPTR(PL_compcv);
2798 PL_compcv = (CV*)NEWSV(1104,0);
2799 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2800 CvEVAL_on(PL_compcv);
2801 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2802 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2804 CvOUTSIDE_SEQ(PL_compcv) = seq;
2805 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2807 /* set up a scratch pad */
2809 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2812 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2814 /* make sure we compile in the right package */
2816 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2817 SAVESPTR(PL_curstash);
2818 PL_curstash = CopSTASH(PL_curcop);
2820 SAVESPTR(PL_beginav);
2821 PL_beginav = newAV();
2822 SAVEFREESV(PL_beginav);
2823 SAVEI32(PL_error_count);
2825 /* try to compile it */
2827 PL_eval_root = Nullop;
2829 PL_curcop = &PL_compiling;
2830 PL_curcop->cop_arybase = 0;
2831 if (saveop && saveop->op_flags & OPf_SPECIAL)
2832 PL_in_eval |= EVAL_KEEPERR;
2835 if (yyparse() || PL_error_count || !PL_eval_root) {
2836 SV **newsp; /* Used by POPBLOCK. */
2837 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2838 I32 optype = 0; /* Might be reset by POPEVAL. */
2843 op_free(PL_eval_root);
2844 PL_eval_root = Nullop;
2846 SP = PL_stack_base + POPMARK; /* pop original mark */
2848 POPBLOCK(cx,PL_curpm);
2854 if (optype == OP_REQUIRE) {
2855 char* msg = SvPVx(ERRSV, n_a);
2856 SV *nsv = cx->blk_eval.old_namesv;
2857 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2859 DIE(aTHX_ "%sCompilation failed in require",
2860 *msg ? msg : "Unknown error\n");
2863 char* msg = SvPVx(ERRSV, n_a);
2865 POPBLOCK(cx,PL_curpm);
2867 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2868 (*msg ? msg : "Unknown error\n"));
2871 char* msg = SvPVx(ERRSV, n_a);
2873 sv_setpv(ERRSV, "Compilation error");
2878 CopLINE_set(&PL_compiling, 0);
2880 *startop = PL_eval_root;
2882 SAVEFREEOP(PL_eval_root);
2884 /* Set the context for this new optree.
2885 * If the last op is an OP_REQUIRE, force scalar context.
2886 * Otherwise, propagate the context from the eval(). */
2887 if (PL_eval_root->op_type == OP_LEAVEEVAL
2888 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2889 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2891 scalar(PL_eval_root);
2892 else if (gimme & G_VOID)
2893 scalarvoid(PL_eval_root);
2894 else if (gimme & G_ARRAY)
2897 scalar(PL_eval_root);
2899 DEBUG_x(dump_eval());
2901 /* Register with debugger: */
2902 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2903 CV *cv = get_cv("DB::postponed", FALSE);
2907 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2909 call_sv((SV*)cv, G_DISCARD);
2913 /* compiled okay, so do it */
2915 CvDEPTH(PL_compcv) = 1;
2916 SP = PL_stack_base + POPMARK; /* pop original mark */
2917 PL_op = saveop; /* The caller may need it. */
2918 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2920 RETURNOP(PL_eval_start);
2924 S_doopen_pm(pTHX_ const char *name, const char *mode)
2926 #ifndef PERL_DISABLE_PMC
2927 STRLEN namelen = strlen(name);
2930 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2931 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2932 char *pmc = SvPV_nolen(pmcsv);
2935 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2936 fp = PerlIO_open(name, mode);
2939 if (PerlLIO_stat(name, &pmstat) < 0 ||
2940 pmstat.st_mtime < pmcstat.st_mtime)
2942 fp = PerlIO_open(pmc, mode);
2945 fp = PerlIO_open(name, mode);
2948 SvREFCNT_dec(pmcsv);
2951 fp = PerlIO_open(name, mode);
2955 return PerlIO_open(name, mode);
2956 #endif /* !PERL_DISABLE_PMC */
2962 register PERL_CONTEXT *cx;
2966 char *tryname = Nullch;
2967 SV *namesv = Nullsv;
2969 I32 gimme = GIMME_V;
2970 PerlIO *tryrsfp = 0;
2972 int filter_has_file = 0;
2973 GV *filter_child_proc = 0;
2974 SV *filter_state = 0;
2981 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2982 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2983 UV rev = 0, ver = 0, sver = 0;
2985 U8 *s = (U8*)SvPVX(sv);
2986 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2988 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2991 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2994 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2997 if (PERL_REVISION < rev
2998 || (PERL_REVISION == rev
2999 && (PERL_VERSION < ver
3000 || (PERL_VERSION == ver
3001 && PERL_SUBVERSION < sver))))
3003 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3004 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3005 PERL_VERSION, PERL_SUBVERSION);
3007 if (ckWARN(WARN_PORTABLE))
3008 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3009 "v-string in use/require non-portable");
3012 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3013 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3014 + ((NV)PERL_SUBVERSION/(NV)1000000)
3015 + 0.00000099 < SvNV(sv))
3019 NV nver = (nrev - rev) * 1000;
3020 UV ver = (UV)(nver + 0.0009);
3021 NV nsver = (nver - ver) * 1000;
3022 UV sver = (UV)(nsver + 0.0009);
3024 /* help out with the "use 5.6" confusion */
3025 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3026 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3027 " (did you mean v%"UVuf".%03"UVuf"?)--"
3028 "this is only v%d.%d.%d, stopped",
3029 rev, ver, sver, rev, ver/100,
3030 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3033 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3034 "this is only v%d.%d.%d, stopped",
3035 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3042 name = SvPV(sv, len);
3043 if (!(name && len > 0 && *name))
3044 DIE(aTHX_ "Null filename used");
3045 TAINT_PROPER("require");
3046 if (PL_op->op_type == OP_REQUIRE &&
3047 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3048 if (*svp != &PL_sv_undef)
3051 DIE(aTHX_ "Compilation failed in require");
3054 /* prepare to compile file */
3056 if (path_is_absolute(name)) {
3058 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3060 #ifdef MACOS_TRADITIONAL
3064 MacPerl_CanonDir(name, newname, 1);
3065 if (path_is_absolute(newname)) {
3067 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3072 AV *ar = GvAVn(PL_incgv);
3076 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3079 namesv = NEWSV(806, 0);
3080 for (i = 0; i <= AvFILL(ar); i++) {
3081 SV *dirsv = *av_fetch(ar, i, TRUE);
3087 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3088 && !sv_isobject(loader))
3090 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3093 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3094 PTR2UV(SvRV(dirsv)), name);
3095 tryname = SvPVX(namesv);
3106 if (sv_isobject(loader))
3107 count = call_method("INC", G_ARRAY);
3109 count = call_sv(loader, G_ARRAY);
3119 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3123 if (SvTYPE(arg) == SVt_PVGV) {
3124 IO *io = GvIO((GV *)arg);
3129 tryrsfp = IoIFP(io);
3130 if (IoTYPE(io) == IoTYPE_PIPE) {
3131 /* reading from a child process doesn't
3132 nest -- when returning from reading
3133 the inner module, the outer one is
3134 unreadable (closed?) I've tried to
3135 save the gv to manage the lifespan of
3136 the pipe, but this didn't help. XXX */
3137 filter_child_proc = (GV *)arg;
3138 (void)SvREFCNT_inc(filter_child_proc);
3141 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3142 PerlIO_close(IoOFP(io));
3154 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3156 (void)SvREFCNT_inc(filter_sub);
3159 filter_state = SP[i];
3160 (void)SvREFCNT_inc(filter_state);
3164 tryrsfp = PerlIO_open("/dev/null",
3180 filter_has_file = 0;
3181 if (filter_child_proc) {
3182 SvREFCNT_dec(filter_child_proc);
3183 filter_child_proc = 0;
3186 SvREFCNT_dec(filter_state);
3190 SvREFCNT_dec(filter_sub);
3195 if (!path_is_absolute(name)
3196 #ifdef MACOS_TRADITIONAL
3197 /* We consider paths of the form :a:b ambiguous and interpret them first
3198 as global then as local
3200 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3203 char *dir = SvPVx(dirsv, n_a);
3204 #ifdef MACOS_TRADITIONAL
3208 MacPerl_CanonDir(name, buf2, 1);
3209 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3213 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3215 sv_setpv(namesv, unixdir);
3216 sv_catpv(namesv, unixname);
3218 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3221 TAINT_PROPER("require");
3222 tryname = SvPVX(namesv);
3223 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3225 if (tryname[0] == '.' && tryname[1] == '/')
3234 SAVECOPFILE_FREE(&PL_compiling);
3235 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3236 SvREFCNT_dec(namesv);
3238 if (PL_op->op_type == OP_REQUIRE) {
3239 char *msgstr = name;
3240 if (namesv) { /* did we lookup @INC? */
3241 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3242 SV *dirmsgsv = NEWSV(0, 0);
3243 AV *ar = GvAVn(PL_incgv);
3245 sv_catpvn(msg, " in @INC", 8);
3246 if (instr(SvPVX(msg), ".h "))
3247 sv_catpv(msg, " (change .h to .ph maybe?)");
3248 if (instr(SvPVX(msg), ".ph "))
3249 sv_catpv(msg, " (did you run h2ph?)");
3250 sv_catpv(msg, " (@INC contains:");
3251 for (i = 0; i <= AvFILL(ar); i++) {
3252 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3253 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3254 sv_catsv(msg, dirmsgsv);
3256 sv_catpvn(msg, ")", 1);
3257 SvREFCNT_dec(dirmsgsv);
3258 msgstr = SvPV_nolen(msg);
3260 DIE(aTHX_ "Can't locate %s", msgstr);
3266 SETERRNO(0, SS_NORMAL);
3268 /* Assume success here to prevent recursive requirement. */
3270 /* Check whether a hook in @INC has already filled %INC */
3271 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3272 (void)hv_store(GvHVn(PL_incgv), name, len,
3273 (hook_sv ? SvREFCNT_inc(hook_sv)
3274 : newSVpv(CopFILE(&PL_compiling), 0)),
3280 lex_start(sv_2mortal(newSVpvn("",0)));
3281 SAVEGENERICSV(PL_rsfp_filters);
3282 PL_rsfp_filters = Nullav;
3287 SAVESPTR(PL_compiling.cop_warnings);
3288 if (PL_dowarn & G_WARN_ALL_ON)
3289 PL_compiling.cop_warnings = pWARN_ALL ;
3290 else if (PL_dowarn & G_WARN_ALL_OFF)
3291 PL_compiling.cop_warnings = pWARN_NONE ;
3292 else if (PL_taint_warn)
3293 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3295 PL_compiling.cop_warnings = pWARN_STD ;
3296 SAVESPTR(PL_compiling.cop_io);
3297 PL_compiling.cop_io = Nullsv;
3299 if (filter_sub || filter_child_proc) {
3300 SV *datasv = filter_add(run_user_filter, Nullsv);
3301 IoLINES(datasv) = filter_has_file;
3302 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3303 IoTOP_GV(datasv) = (GV *)filter_state;
3304 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3307 /* switch to eval mode */
3308 push_return(PL_op->op_next);
3309 PUSHBLOCK(cx, CXt_EVAL, SP);
3310 PUSHEVAL(cx, name, Nullgv);
3312 SAVECOPLINE(&PL_compiling);
3313 CopLINE_set(&PL_compiling, 0);
3317 /* Store and reset encoding. */
3318 encoding = PL_encoding;
3319 PL_encoding = Nullsv;
3321 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3323 /* Restore encoding. */
3324 PL_encoding = encoding;
3331 return pp_require();
3337 register PERL_CONTEXT *cx;
3339 I32 gimme = GIMME_V, was = PL_sub_generation;
3340 char tbuf[TYPE_DIGITS(long) + 12];
3341 char *tmpbuf = tbuf;
3350 TAINT_PROPER("eval");
3356 /* switch to eval mode */
3358 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3359 SV *sv = sv_newmortal();
3360 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3361 (unsigned long)++PL_evalseq,
3362 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3366 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3367 SAVECOPFILE_FREE(&PL_compiling);
3368 CopFILE_set(&PL_compiling, tmpbuf+2);
3369 SAVECOPLINE(&PL_compiling);
3370 CopLINE_set(&PL_compiling, 1);
3371 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3372 deleting the eval's FILEGV from the stash before gv_check() runs
3373 (i.e. before run-time proper). To work around the coredump that
3374 ensues, we always turn GvMULTI_on for any globals that were
3375 introduced within evals. See force_ident(). GSAR 96-10-12 */
3376 safestr = savepv(tmpbuf);
3377 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3379 PL_hints = PL_op->op_targ;
3380 SAVESPTR(PL_compiling.cop_warnings);
3381 if (specialWARN(PL_curcop->cop_warnings))
3382 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3384 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3385 SAVEFREESV(PL_compiling.cop_warnings);
3387 SAVESPTR(PL_compiling.cop_io);
3388 if (specialCopIO(PL_curcop->cop_io))
3389 PL_compiling.cop_io = PL_curcop->cop_io;
3391 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3392 SAVEFREESV(PL_compiling.cop_io);
3394 /* special case: an eval '' executed within the DB package gets lexically
3395 * placed in the first non-DB CV rather than the current CV - this
3396 * allows the debugger to execute code, find lexicals etc, in the
3397 * scope of the code being debugged. Passing &seq gets find_runcv
3398 * to do the dirty work for us */
3399 runcv = find_runcv(&seq);
3401 push_return(PL_op->op_next);
3402 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3403 PUSHEVAL(cx, 0, Nullgv);
3405 /* prepare to compile string */
3407 if (PERLDB_LINE && PL_curstash != PL_debstash)
3408 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3410 ret = doeval(gimme, NULL, runcv, seq);
3411 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3412 && ret != PL_op->op_next) { /* Successive compilation. */
3413 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3415 return DOCATCH(ret);
3425 register PERL_CONTEXT *cx;
3427 U8 save_flags = PL_op -> op_flags;
3432 retop = pop_return();
3435 if (gimme == G_VOID)
3437 else if (gimme == G_SCALAR) {
3440 if (SvFLAGS(TOPs) & SVs_TEMP)
3443 *MARK = sv_mortalcopy(TOPs);
3447 *MARK = &PL_sv_undef;
3452 /* in case LEAVE wipes old return values */
3453 for (mark = newsp + 1; mark <= SP; mark++) {
3454 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3455 *mark = sv_mortalcopy(*mark);
3456 TAINT_NOT; /* Each item is independent */
3460 PL_curpm = newpm; /* Don't pop $1 et al till now */
3463 assert(CvDEPTH(PL_compcv) == 1);
3465 CvDEPTH(PL_compcv) = 0;
3468 if (optype == OP_REQUIRE &&
3469 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3471 /* Unassume the success we assumed earlier. */
3472 SV *nsv = cx->blk_eval.old_namesv;
3473 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3474 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3475 /* die_where() did LEAVE, or we won't be here */
3479 if (!(save_flags & OPf_SPECIAL))
3489 register PERL_CONTEXT *cx;
3490 I32 gimme = GIMME_V;
3495 push_return(cLOGOP->op_other->op_next);
3496 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3499 PL_in_eval = EVAL_INEVAL;
3502 return DOCATCH(PL_op->op_next);
3513 register PERL_CONTEXT *cx;
3518 retop = pop_return();
3521 if (gimme == G_VOID)
3523 else if (gimme == G_SCALAR) {
3526 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3529 *MARK = sv_mortalcopy(TOPs);
3533 *MARK = &PL_sv_undef;
3538 /* in case LEAVE wipes old return values */
3539 for (mark = newsp + 1; mark <= SP; mark++) {
3540 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3541 *mark = sv_mortalcopy(*mark);
3542 TAINT_NOT; /* Each item is independent */
3546 PL_curpm = newpm; /* Don't pop $1 et al till now */
3554 S_doparseform(pTHX_ SV *sv)
3557 register char *s = SvPV_force(sv, len);
3558 register char *send = s + len;
3559 register char *base = Nullch;
3560 register I32 skipspaces = 0;
3561 bool noblank = FALSE;
3562 bool repeat = FALSE;
3563 bool postspace = FALSE;
3569 bool unchopnum = FALSE;
3570 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3573 Perl_croak(aTHX_ "Null picture in formline");
3575 /* estimate the buffer size needed */
3576 for (base = s; s <= send; s++) {
3577 if (*s == '\n' || *s == '@' || *s == '^')
3583 New(804, fops, maxops, U32);
3588 *fpc++ = FF_LINEMARK;
3589 noblank = repeat = FALSE;
3607 case ' ': case '\t':
3614 } /* else FALL THROUGH */
3622 *fpc++ = FF_LITERAL;
3630 *fpc++ = (U16)skipspaces;
3634 *fpc++ = FF_NEWLINE;
3638 arg = fpc - linepc + 1;
3645 *fpc++ = FF_LINEMARK;
3646 noblank = repeat = FALSE;
3655 ischop = s[-1] == '^';
3661 arg = (s - base) - 1;
3663 *fpc++ = FF_LITERAL;
3671 *fpc++ = 2; /* skip the @* or ^* */
3673 *fpc++ = FF_LINESNGL;
3676 *fpc++ = FF_LINEGLOB;
3678 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3679 arg = ischop ? 512 : 0;
3689 arg |= 256 + (s - f);
3691 *fpc++ = s - base; /* fieldsize for FETCH */
3692 *fpc++ = FF_DECIMAL;
3694 unchopnum |= ! ischop;
3696 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3697 arg = ischop ? 512 : 0;
3699 s++; /* skip the '0' first */
3708 arg |= 256 + (s - f);
3710 *fpc++ = s - base; /* fieldsize for FETCH */
3711 *fpc++ = FF_0DECIMAL;
3713 unchopnum |= ! ischop;
3717 bool ismore = FALSE;
3720 while (*++s == '>') ;
3721 prespace = FF_SPACE;
3723 else if (*s == '|') {
3724 while (*++s == '|') ;
3725 prespace = FF_HALFSPACE;
3730 while (*++s == '<') ;
3733 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3737 *fpc++ = s - base; /* fieldsize for FETCH */
3739 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3742 *fpc++ = (U16)prespace;
3756 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3758 { /* need to jump to the next word */
3760 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3761 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3762 s = SvPVX(sv) + SvCUR(sv) + z;
3764 Copy(fops, s, arg, U32);
3766 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3769 if (unchopnum && repeat)
3770 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3776 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3778 /* Can value be printed in fldsize chars, using %*.*f ? */
3782 int intsize = fldsize - (value < 0 ? 1 : 0);
3789 while (intsize--) pwr *= 10.0;
3790 while (frcsize--) eps /= 10.0;
3793 if (value + eps >= pwr)
3796 if (value - eps <= -pwr)
3803 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3805 SV *datasv = FILTER_DATA(idx);
3806 int filter_has_file = IoLINES(datasv);
3807 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3808 SV *filter_state = (SV *)IoTOP_GV(datasv);
3809 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3812 /* I was having segfault trouble under Linux 2.2.5 after a
3813 parse error occured. (Had to hack around it with a test
3814 for PL_error_count == 0.) Solaris doesn't segfault --
3815 not sure where the trouble is yet. XXX */
3817 if (filter_has_file) {
3818 len = FILTER_READ(idx+1, buf_sv, maxlen);
3821 if (filter_sub && len >= 0) {
3832 PUSHs(sv_2mortal(newSViv(maxlen)));
3834 PUSHs(filter_state);
3837 count = call_sv(filter_sub, G_SCALAR);
3853 IoLINES(datasv) = 0;
3854 if (filter_child_proc) {
3855 SvREFCNT_dec(filter_child_proc);
3856 IoFMT_GV(datasv) = Nullgv;
3859 SvREFCNT_dec(filter_state);
3860 IoTOP_GV(datasv) = Nullgv;
3863 SvREFCNT_dec(filter_sub);
3864 IoBOTTOM_GV(datasv) = Nullgv;
3866 filter_del(run_user_filter);
3872 /* perhaps someone can come up with a better name for
3873 this? it is not really "absolute", per se ... */
3875 S_path_is_absolute(pTHX_ char *name)
3877 if (PERL_FILE_IS_ABSOLUTE(name)
3878 #ifdef MACOS_TRADITIONAL
3881 || (*name == '.' && (name[1] == '/' ||
3882 (name[1] == '.' && name[2] == '/'))))