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 (void)SvREFCNT_inc(cv);
1705 PAD_SET_CUR(CvPADLIST(cv),1);
1706 RETURNOP(CvSTART(cv));
1720 register PERL_CONTEXT *cx;
1721 I32 gimme = GIMME_V;
1723 U32 cxtype = CXt_LOOP;
1731 if (PL_op->op_targ) {
1732 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1733 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1734 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1735 SVs_PADSTALE, SVs_PADSTALE);
1737 #ifndef USE_ITHREADS
1738 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1741 SAVEPADSV(PL_op->op_targ);
1742 iterdata = INT2PTR(void*, PL_op->op_targ);
1743 cxtype |= CXp_PADVAR;
1748 svp = &GvSV(gv); /* symbol table variable */
1749 SAVEGENERICSV(*svp);
1752 iterdata = (void*)gv;
1758 PUSHBLOCK(cx, cxtype, SP);
1760 PUSHLOOP(cx, iterdata, MARK);
1762 PUSHLOOP(cx, svp, MARK);
1764 if (PL_op->op_flags & OPf_STACKED) {
1765 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1766 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1768 if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
1769 if (SvNV(sv) < IV_MIN ||
1770 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1771 DIE(aTHX_ "Range iterator outside integer range");
1772 cx->blk_loop.iterix = SvIV(sv);
1773 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1776 cx->blk_loop.iterlval = newSVsv(sv);
1780 cx->blk_loop.iterary = PL_curstack;
1781 AvFILLp(PL_curstack) = SP - PL_stack_base;
1782 cx->blk_loop.iterix = MARK - PL_stack_base;
1791 register PERL_CONTEXT *cx;
1792 I32 gimme = GIMME_V;
1798 PUSHBLOCK(cx, CXt_LOOP, SP);
1799 PUSHLOOP(cx, 0, SP);
1807 register PERL_CONTEXT *cx;
1815 newsp = PL_stack_base + cx->blk_loop.resetsp;
1818 if (gimme == G_VOID)
1820 else if (gimme == G_SCALAR) {
1822 *++newsp = sv_mortalcopy(*SP);
1824 *++newsp = &PL_sv_undef;
1828 *++newsp = sv_mortalcopy(*++mark);
1829 TAINT_NOT; /* Each item is independent */
1835 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1836 PL_curpm = newpm; /* ... and pop $1 et al */
1848 register PERL_CONTEXT *cx;
1849 bool popsub2 = FALSE;
1850 bool clear_errsv = FALSE;
1857 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1858 if (cxstack_ix == PL_sortcxix
1859 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1861 if (cxstack_ix > PL_sortcxix)
1862 dounwind(PL_sortcxix);
1863 AvARRAY(PL_curstack)[1] = *SP;
1864 PL_stack_sp = PL_stack_base + 1;
1869 cxix = dopoptosub(cxstack_ix);
1871 DIE(aTHX_ "Can't return outside a subroutine");
1872 if (cxix < cxstack_ix)
1876 switch (CxTYPE(cx)) {
1879 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1882 if (!(PL_in_eval & EVAL_KEEPERR))
1888 if (optype == OP_REQUIRE &&
1889 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1891 /* Unassume the success we assumed earlier. */
1892 SV *nsv = cx->blk_eval.old_namesv;
1893 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1894 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1901 DIE(aTHX_ "panic: return");
1905 if (gimme == G_SCALAR) {
1908 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1910 *++newsp = SvREFCNT_inc(*SP);
1915 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1917 *++newsp = sv_mortalcopy(sv);
1922 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1925 *++newsp = sv_mortalcopy(*SP);
1928 *++newsp = &PL_sv_undef;
1930 else if (gimme == G_ARRAY) {
1931 while (++MARK <= SP) {
1932 *++newsp = (popsub2 && SvTEMP(*MARK))
1933 ? *MARK : sv_mortalcopy(*MARK);
1934 TAINT_NOT; /* Each item is independent */
1937 PL_stack_sp = newsp;
1940 /* Stack values are safe: */
1943 POPSUB(cx,sv); /* release CV and @_ ... */
1947 PL_curpm = newpm; /* ... and pop $1 et al */
1952 return pop_return();
1959 register PERL_CONTEXT *cx;
1969 if (PL_op->op_flags & OPf_SPECIAL) {
1970 cxix = dopoptoloop(cxstack_ix);
1972 DIE(aTHX_ "Can't \"last\" outside a loop block");
1975 cxix = dopoptolabel(cPVOP->op_pv);
1977 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1979 if (cxix < cxstack_ix)
1983 cxstack_ix++; /* temporarily protect top context */
1985 switch (CxTYPE(cx)) {
1988 newsp = PL_stack_base + cx->blk_loop.resetsp;
1989 nextop = cx->blk_loop.last_op->op_next;
1993 nextop = pop_return();
1997 nextop = pop_return();
2001 nextop = pop_return();
2004 DIE(aTHX_ "panic: last");
2008 if (gimme == G_SCALAR) {
2010 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2011 ? *SP : sv_mortalcopy(*SP);
2013 *++newsp = &PL_sv_undef;
2015 else if (gimme == G_ARRAY) {
2016 while (++MARK <= SP) {
2017 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2018 ? *MARK : sv_mortalcopy(*MARK);
2019 TAINT_NOT; /* Each item is independent */
2027 /* Stack values are safe: */
2030 POPLOOP(cx); /* release loop vars ... */
2034 POPSUB(cx,sv); /* release CV and @_ ... */
2037 PL_curpm = newpm; /* ... and pop $1 et al */
2046 register PERL_CONTEXT *cx;
2049 if (PL_op->op_flags & OPf_SPECIAL) {
2050 cxix = dopoptoloop(cxstack_ix);
2052 DIE(aTHX_ "Can't \"next\" outside a loop block");
2055 cxix = dopoptolabel(cPVOP->op_pv);
2057 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2059 if (cxix < cxstack_ix)
2062 /* clear off anything above the scope we're re-entering, but
2063 * save the rest until after a possible continue block */
2064 inner = PL_scopestack_ix;
2066 if (PL_scopestack_ix < inner)
2067 leave_scope(PL_scopestack[PL_scopestack_ix]);
2068 return cx->blk_loop.next_op;
2074 register PERL_CONTEXT *cx;
2077 if (PL_op->op_flags & OPf_SPECIAL) {
2078 cxix = dopoptoloop(cxstack_ix);
2080 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2083 cxix = dopoptolabel(cPVOP->op_pv);
2085 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2087 if (cxix < cxstack_ix)
2091 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2092 LEAVE_SCOPE(oldsave);
2093 return cx->blk_loop.redo_op;
2097 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2101 static char too_deep[] = "Target of goto is too deeply nested";
2104 Perl_croak(aTHX_ too_deep);
2105 if (o->op_type == OP_LEAVE ||
2106 o->op_type == OP_SCOPE ||
2107 o->op_type == OP_LEAVELOOP ||
2108 o->op_type == OP_LEAVESUB ||
2109 o->op_type == OP_LEAVETRY)
2111 *ops++ = cUNOPo->op_first;
2113 Perl_croak(aTHX_ too_deep);
2116 if (o->op_flags & OPf_KIDS) {
2117 /* First try all the kids at this level, since that's likeliest. */
2118 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2119 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2120 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2123 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2124 if (kid == PL_lastgotoprobe)
2126 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2129 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2130 ops[-1]->op_type == OP_DBSTATE)
2135 if ((o = dofindlabel(kid, label, ops, oplimit)))
2154 register PERL_CONTEXT *cx;
2155 #define GOTO_DEPTH 64
2156 OP *enterops[GOTO_DEPTH];
2158 int do_dump = (PL_op->op_type == OP_DUMP);
2159 static char must_have_label[] = "goto must have label";
2162 if (PL_op->op_flags & OPf_STACKED) {
2166 /* This egregious kludge implements goto &subroutine */
2167 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2169 register PERL_CONTEXT *cx;
2170 CV* cv = (CV*)SvRV(sv);
2176 if (!CvROOT(cv) && !CvXSUB(cv)) {
2181 /* autoloaded stub? */
2182 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2184 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2185 GvNAMELEN(gv), FALSE);
2186 if (autogv && (cv = GvCV(autogv)))
2188 tmpstr = sv_newmortal();
2189 gv_efullname3(tmpstr, gv, Nullch);
2190 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2192 DIE(aTHX_ "Goto undefined subroutine");
2195 /* First do some returnish stuff. */
2196 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2198 cxix = dopoptosub(cxstack_ix);
2200 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2201 if (cxix < cxstack_ix)
2205 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2207 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2208 /* put @_ back onto stack */
2209 AV* av = cx->blk_sub.argarray;
2211 items = AvFILLp(av) + 1;
2213 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2214 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2215 PL_stack_sp += items;
2216 SvREFCNT_dec(GvAV(PL_defgv));
2217 GvAV(PL_defgv) = cx->blk_sub.savearray;
2218 /* abandon @_ if it got reified */
2220 (void)sv_2mortal((SV*)av); /* delay until return */
2222 av_extend(av, items-1);
2223 AvFLAGS(av) = AVf_REIFY;
2224 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2229 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2231 av = GvAV(PL_defgv);
2232 items = AvFILLp(av) + 1;
2234 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2235 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2236 PL_stack_sp += items;
2238 if (CxTYPE(cx) == CXt_SUB &&
2239 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2240 SvREFCNT_dec(cx->blk_sub.cv);
2241 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2242 LEAVE_SCOPE(oldsave);
2244 /* Now do some callish stuff. */
2246 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2248 #ifdef PERL_XSUB_OLDSTYLE
2249 if (CvOLDSTYLE(cv)) {
2250 I32 (*fp3)(int,int,int);
2255 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2256 items = (*fp3)(CvXSUBANY(cv).any_i32,
2257 mark - PL_stack_base + 1,
2259 SP = PL_stack_base + items;
2262 #endif /* PERL_XSUB_OLDSTYLE */
2267 PL_stack_sp--; /* There is no cv arg. */
2268 /* Push a mark for the start of arglist */
2270 (void)(*CvXSUB(cv))(aTHX_ cv);
2271 /* Pop the current context like a decent sub should */
2272 POPBLOCK(cx, PL_curpm);
2273 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2276 return pop_return();
2279 AV* padlist = CvPADLIST(cv);
2280 if (CxTYPE(cx) == CXt_EVAL) {
2281 PL_in_eval = cx->blk_eval.old_in_eval;
2282 PL_eval_root = cx->blk_eval.old_eval_root;
2283 cx->cx_type = CXt_SUB;
2284 cx->blk_sub.hasargs = 0;
2286 cx->blk_sub.cv = cv;
2287 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2290 if (CvDEPTH(cv) < 2)
2291 (void)SvREFCNT_inc(cv);
2293 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2294 sub_crush_depth(cv);
2295 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2297 PAD_SET_CUR(padlist, CvDEPTH(cv));
2298 if (cx->blk_sub.hasargs)
2300 AV* av = (AV*)PAD_SVl(0);
2303 cx->blk_sub.savearray = GvAV(PL_defgv);
2304 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2305 CX_CURPAD_SAVE(cx->blk_sub);
2306 cx->blk_sub.argarray = av;
2309 if (items >= AvMAX(av) + 1) {
2311 if (AvARRAY(av) != ary) {
2312 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2313 SvPVX(av) = (char*)ary;
2315 if (items >= AvMAX(av) + 1) {
2316 AvMAX(av) = items - 1;
2317 Renew(ary,items+1,SV*);
2319 SvPVX(av) = (char*)ary;
2322 Copy(mark,AvARRAY(av),items,SV*);
2323 AvFILLp(av) = items - 1;
2324 assert(!AvREAL(av));
2331 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2333 * We do not care about using sv to call CV;
2334 * it's for informational purposes only.
2336 SV *sv = GvSV(PL_DBsub);
2339 if (PERLDB_SUB_NN) {
2340 (void)SvUPGRADE(sv, SVt_PVIV);
2343 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2346 gv_efullname3(sv, CvGV(cv), Nullch);
2349 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2350 PUSHMARK( PL_stack_sp );
2351 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2355 RETURNOP(CvSTART(cv));
2359 label = SvPV(sv,n_a);
2360 if (!(do_dump || *label))
2361 DIE(aTHX_ must_have_label);
2364 else if (PL_op->op_flags & OPf_SPECIAL) {
2366 DIE(aTHX_ must_have_label);
2369 label = cPVOP->op_pv;
2371 if (label && *label) {
2373 bool leaving_eval = FALSE;
2374 bool in_block = FALSE;
2375 PERL_CONTEXT *last_eval_cx = 0;
2379 PL_lastgotoprobe = 0;
2381 for (ix = cxstack_ix; ix >= 0; ix--) {
2383 switch (CxTYPE(cx)) {
2385 leaving_eval = TRUE;
2386 if (!CxTRYBLOCK(cx)) {
2387 gotoprobe = (last_eval_cx ?
2388 last_eval_cx->blk_eval.old_eval_root :
2393 /* else fall through */
2395 gotoprobe = cx->blk_oldcop->op_sibling;
2401 gotoprobe = cx->blk_oldcop->op_sibling;
2404 gotoprobe = PL_main_root;
2407 if (CvDEPTH(cx->blk_sub.cv)) {
2408 gotoprobe = CvROOT(cx->blk_sub.cv);
2414 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2417 DIE(aTHX_ "panic: goto");
2418 gotoprobe = PL_main_root;
2422 retop = dofindlabel(gotoprobe, label,
2423 enterops, enterops + GOTO_DEPTH);
2427 PL_lastgotoprobe = gotoprobe;
2430 DIE(aTHX_ "Can't find label %s", label);
2432 /* if we're leaving an eval, check before we pop any frames
2433 that we're not going to punt, otherwise the error
2436 if (leaving_eval && *enterops && enterops[1]) {
2438 for (i = 1; enterops[i]; i++)
2439 if (enterops[i]->op_type == OP_ENTERITER)
2440 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2443 /* pop unwanted frames */
2445 if (ix < cxstack_ix) {
2452 oldsave = PL_scopestack[PL_scopestack_ix];
2453 LEAVE_SCOPE(oldsave);
2456 /* push wanted frames */
2458 if (*enterops && enterops[1]) {
2460 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2461 for (; enterops[ix]; ix++) {
2462 PL_op = enterops[ix];
2463 /* Eventually we may want to stack the needed arguments
2464 * for each op. For now, we punt on the hard ones. */
2465 if (PL_op->op_type == OP_ENTERITER)
2466 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2467 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2475 if (!retop) retop = PL_main_start;
2477 PL_restartop = retop;
2478 PL_do_undump = TRUE;
2482 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2483 PL_do_undump = FALSE;
2499 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2501 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2504 PL_exit_flags |= PERL_EXIT_EXPECTED;
2506 PUSHs(&PL_sv_undef);
2514 NV value = SvNVx(GvSV(cCOP->cop_gv));
2515 register I32 match = I_32(value);
2518 if (((NV)match) > value)
2519 --match; /* was fractional--truncate other way */
2521 match -= cCOP->uop.scop.scop_offset;
2524 else if (match > cCOP->uop.scop.scop_max)
2525 match = cCOP->uop.scop.scop_max;
2526 PL_op = cCOP->uop.scop.scop_next[match];
2536 PL_op = PL_op->op_next; /* can't assume anything */
2539 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2540 match -= cCOP->uop.scop.scop_offset;
2543 else if (match > cCOP->uop.scop.scop_max)
2544 match = cCOP->uop.scop.scop_max;
2545 PL_op = cCOP->uop.scop.scop_next[match];
2554 S_save_lines(pTHX_ AV *array, SV *sv)
2556 register char *s = SvPVX(sv);
2557 register char *send = SvPVX(sv) + SvCUR(sv);
2559 register I32 line = 1;
2561 while (s && s < send) {
2562 SV *tmpstr = NEWSV(85,0);
2564 sv_upgrade(tmpstr, SVt_PVMG);
2565 t = strchr(s, '\n');
2571 sv_setpvn(tmpstr, s, t - s);
2572 av_store(array, line++, tmpstr);
2577 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2579 S_docatch_body(pTHX_ va_list args)
2581 return docatch_body();
2586 S_docatch_body(pTHX)
2593 S_docatch(pTHX_ OP *o)
2598 volatile PERL_SI *cursi = PL_curstackinfo;
2602 assert(CATCH_GET == TRUE);
2606 /* Normally, the leavetry at the end of this block of ops will
2607 * pop an op off the return stack and continue there. By setting
2608 * the op to Nullop, we force an exit from the inner runops()
2611 retop = pop_return();
2612 push_return(Nullop);
2614 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2616 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2622 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2628 /* die caught by an inner eval - continue inner loop */
2629 if (PL_restartop && cursi == PL_curstackinfo) {
2630 PL_op = PL_restartop;
2634 /* a die in this eval - continue in outer loop */
2650 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2651 /* sv Text to convert to OP tree. */
2652 /* startop op_free() this to undo. */
2653 /* code Short string id of the caller. */
2655 dSP; /* Make POPBLOCK work. */
2658 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2662 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2663 char *tmpbuf = tbuf;
2666 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2671 /* switch to eval mode */
2673 if (IN_PERL_COMPILETIME) {
2674 SAVECOPSTASH_FREE(&PL_compiling);
2675 CopSTASH_set(&PL_compiling, PL_curstash);
2677 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2678 SV *sv = sv_newmortal();
2679 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2680 code, (unsigned long)++PL_evalseq,
2681 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2685 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2686 SAVECOPFILE_FREE(&PL_compiling);
2687 CopFILE_set(&PL_compiling, tmpbuf+2);
2688 SAVECOPLINE(&PL_compiling);
2689 CopLINE_set(&PL_compiling, 1);
2690 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2691 deleting the eval's FILEGV from the stash before gv_check() runs
2692 (i.e. before run-time proper). To work around the coredump that
2693 ensues, we always turn GvMULTI_on for any globals that were
2694 introduced within evals. See force_ident(). GSAR 96-10-12 */
2695 safestr = savepv(tmpbuf);
2696 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2698 #ifdef OP_IN_REGISTER
2703 PL_hints &= HINT_UTF8;
2705 /* we get here either during compilation, or via pp_regcomp at runtime */
2706 runtime = IN_PERL_RUNTIME;
2708 runcv = find_runcv(NULL);
2711 PL_op->op_type = OP_ENTEREVAL;
2712 PL_op->op_flags = 0; /* Avoid uninit warning. */
2713 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2714 PUSHEVAL(cx, 0, Nullgv);
2717 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2719 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2720 POPBLOCK(cx,PL_curpm);
2723 (*startop)->op_type = OP_NULL;
2724 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2726 /* XXX DAPM do this properly one year */
2727 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2729 if (IN_PERL_COMPILETIME)
2730 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2731 #ifdef OP_IN_REGISTER
2739 =for apidoc find_runcv
2741 Locate the CV corresponding to the currently executing sub or eval.
2742 If db_seqp is non_null, skip CVs that are in the DB package and populate
2743 *db_seqp with the cop sequence number at the point that the DB:: code was
2744 entered. (allows debuggers to eval in the scope of the breakpoint rather
2745 than in in the scope of the debuger itself).
2751 Perl_find_runcv(pTHX_ U32 *db_seqp)
2758 *db_seqp = PL_curcop->cop_seq;
2759 for (si = PL_curstackinfo; si; si = si->si_prev) {
2760 for (ix = si->si_cxix; ix >= 0; ix--) {
2761 cx = &(si->si_cxstack[ix]);
2762 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2763 CV *cv = cx->blk_sub.cv;
2764 /* skip DB:: code */
2765 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2766 *db_seqp = cx->blk_oldcop->cop_seq;
2771 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2779 /* Compile a require/do, an eval '', or a /(?{...})/.
2780 * In the last case, startop is non-null, and contains the address of
2781 * a pointer that should be set to the just-compiled code.
2782 * outside is the lexically enclosing CV (if any) that invoked us.
2785 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2787 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2792 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2793 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2798 SAVESPTR(PL_compcv);
2799 PL_compcv = (CV*)NEWSV(1104,0);
2800 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2801 CvEVAL_on(PL_compcv);
2802 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2803 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2805 CvOUTSIDE_SEQ(PL_compcv) = seq;
2806 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2808 /* set up a scratch pad */
2810 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2813 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2815 /* make sure we compile in the right package */
2817 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2818 SAVESPTR(PL_curstash);
2819 PL_curstash = CopSTASH(PL_curcop);
2821 SAVESPTR(PL_beginav);
2822 PL_beginav = newAV();
2823 SAVEFREESV(PL_beginav);
2824 SAVEI32(PL_error_count);
2826 /* try to compile it */
2828 PL_eval_root = Nullop;
2830 PL_curcop = &PL_compiling;
2831 PL_curcop->cop_arybase = 0;
2832 if (saveop && saveop->op_flags & OPf_SPECIAL)
2833 PL_in_eval |= EVAL_KEEPERR;
2836 if (yyparse() || PL_error_count || !PL_eval_root) {
2837 SV **newsp; /* Used by POPBLOCK. */
2838 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2839 I32 optype = 0; /* Might be reset by POPEVAL. */
2844 op_free(PL_eval_root);
2845 PL_eval_root = Nullop;
2847 SP = PL_stack_base + POPMARK; /* pop original mark */
2849 POPBLOCK(cx,PL_curpm);
2855 if (optype == OP_REQUIRE) {
2856 char* msg = SvPVx(ERRSV, n_a);
2857 SV *nsv = cx->blk_eval.old_namesv;
2858 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2860 DIE(aTHX_ "%sCompilation failed in require",
2861 *msg ? msg : "Unknown error\n");
2864 char* msg = SvPVx(ERRSV, n_a);
2866 POPBLOCK(cx,PL_curpm);
2868 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2869 (*msg ? msg : "Unknown error\n"));
2872 char* msg = SvPVx(ERRSV, n_a);
2874 sv_setpv(ERRSV, "Compilation error");
2879 CopLINE_set(&PL_compiling, 0);
2881 *startop = PL_eval_root;
2883 SAVEFREEOP(PL_eval_root);
2885 /* Set the context for this new optree.
2886 * If the last op is an OP_REQUIRE, force scalar context.
2887 * Otherwise, propagate the context from the eval(). */
2888 if (PL_eval_root->op_type == OP_LEAVEEVAL
2889 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2890 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2892 scalar(PL_eval_root);
2893 else if (gimme & G_VOID)
2894 scalarvoid(PL_eval_root);
2895 else if (gimme & G_ARRAY)
2898 scalar(PL_eval_root);
2900 DEBUG_x(dump_eval());
2902 /* Register with debugger: */
2903 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2904 CV *cv = get_cv("DB::postponed", FALSE);
2908 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2910 call_sv((SV*)cv, G_DISCARD);
2914 /* compiled okay, so do it */
2916 CvDEPTH(PL_compcv) = 1;
2917 SP = PL_stack_base + POPMARK; /* pop original mark */
2918 PL_op = saveop; /* The caller may need it. */
2919 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2921 RETURNOP(PL_eval_start);
2925 S_doopen_pm(pTHX_ const char *name, const char *mode)
2927 #ifndef PERL_DISABLE_PMC
2928 STRLEN namelen = strlen(name);
2931 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2932 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2933 char *pmc = SvPV_nolen(pmcsv);
2936 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2937 fp = PerlIO_open(name, mode);
2940 if (PerlLIO_stat(name, &pmstat) < 0 ||
2941 pmstat.st_mtime < pmcstat.st_mtime)
2943 fp = PerlIO_open(pmc, mode);
2946 fp = PerlIO_open(name, mode);
2949 SvREFCNT_dec(pmcsv);
2952 fp = PerlIO_open(name, mode);
2956 return PerlIO_open(name, mode);
2957 #endif /* !PERL_DISABLE_PMC */
2963 register PERL_CONTEXT *cx;
2967 char *tryname = Nullch;
2968 SV *namesv = Nullsv;
2970 I32 gimme = GIMME_V;
2971 PerlIO *tryrsfp = 0;
2973 int filter_has_file = 0;
2974 GV *filter_child_proc = 0;
2975 SV *filter_state = 0;
2982 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2983 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2984 UV rev = 0, ver = 0, sver = 0;
2986 U8 *s = (U8*)SvPVX(sv);
2987 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2989 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2992 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2995 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2998 if (PERL_REVISION < rev
2999 || (PERL_REVISION == rev
3000 && (PERL_VERSION < ver
3001 || (PERL_VERSION == ver
3002 && PERL_SUBVERSION < sver))))
3004 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3005 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3006 PERL_VERSION, PERL_SUBVERSION);
3008 if (ckWARN(WARN_PORTABLE))
3009 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3010 "v-string in use/require non-portable");
3013 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3014 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3015 + ((NV)PERL_SUBVERSION/(NV)1000000)
3016 + 0.00000099 < SvNV(sv))
3020 NV nver = (nrev - rev) * 1000;
3021 UV ver = (UV)(nver + 0.0009);
3022 NV nsver = (nver - ver) * 1000;
3023 UV sver = (UV)(nsver + 0.0009);
3025 /* help out with the "use 5.6" confusion */
3026 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3027 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3028 " (did you mean v%"UVuf".%03"UVuf"?)--"
3029 "this is only v%d.%d.%d, stopped",
3030 rev, ver, sver, rev, ver/100,
3031 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3034 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3035 "this is only v%d.%d.%d, stopped",
3036 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3043 name = SvPV(sv, len);
3044 if (!(name && len > 0 && *name))
3045 DIE(aTHX_ "Null filename used");
3046 TAINT_PROPER("require");
3047 if (PL_op->op_type == OP_REQUIRE &&
3048 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3049 if (*svp != &PL_sv_undef)
3052 DIE(aTHX_ "Compilation failed in require");
3055 /* prepare to compile file */
3057 if (path_is_absolute(name)) {
3059 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3061 #ifdef MACOS_TRADITIONAL
3065 MacPerl_CanonDir(name, newname, 1);
3066 if (path_is_absolute(newname)) {
3068 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3073 AV *ar = GvAVn(PL_incgv);
3077 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3080 namesv = NEWSV(806, 0);
3081 for (i = 0; i <= AvFILL(ar); i++) {
3082 SV *dirsv = *av_fetch(ar, i, TRUE);
3088 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3089 && !sv_isobject(loader))
3091 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3094 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3095 PTR2UV(SvRV(dirsv)), name);
3096 tryname = SvPVX(namesv);
3107 if (sv_isobject(loader))
3108 count = call_method("INC", G_ARRAY);
3110 count = call_sv(loader, G_ARRAY);
3120 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3124 if (SvTYPE(arg) == SVt_PVGV) {
3125 IO *io = GvIO((GV *)arg);
3130 tryrsfp = IoIFP(io);
3131 if (IoTYPE(io) == IoTYPE_PIPE) {
3132 /* reading from a child process doesn't
3133 nest -- when returning from reading
3134 the inner module, the outer one is
3135 unreadable (closed?) I've tried to
3136 save the gv to manage the lifespan of
3137 the pipe, but this didn't help. XXX */
3138 filter_child_proc = (GV *)arg;
3139 (void)SvREFCNT_inc(filter_child_proc);
3142 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3143 PerlIO_close(IoOFP(io));
3155 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3157 (void)SvREFCNT_inc(filter_sub);
3160 filter_state = SP[i];
3161 (void)SvREFCNT_inc(filter_state);
3165 tryrsfp = PerlIO_open("/dev/null",
3181 filter_has_file = 0;
3182 if (filter_child_proc) {
3183 SvREFCNT_dec(filter_child_proc);
3184 filter_child_proc = 0;
3187 SvREFCNT_dec(filter_state);
3191 SvREFCNT_dec(filter_sub);
3196 if (!path_is_absolute(name)
3197 #ifdef MACOS_TRADITIONAL
3198 /* We consider paths of the form :a:b ambiguous and interpret them first
3199 as global then as local
3201 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3204 char *dir = SvPVx(dirsv, n_a);
3205 #ifdef MACOS_TRADITIONAL
3209 MacPerl_CanonDir(name, buf2, 1);
3210 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3214 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3216 sv_setpv(namesv, unixdir);
3217 sv_catpv(namesv, unixname);
3219 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3222 TAINT_PROPER("require");
3223 tryname = SvPVX(namesv);
3224 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3226 if (tryname[0] == '.' && tryname[1] == '/')
3235 SAVECOPFILE_FREE(&PL_compiling);
3236 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3237 SvREFCNT_dec(namesv);
3239 if (PL_op->op_type == OP_REQUIRE) {
3240 char *msgstr = name;
3241 if (namesv) { /* did we lookup @INC? */
3242 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3243 SV *dirmsgsv = NEWSV(0, 0);
3244 AV *ar = GvAVn(PL_incgv);
3246 sv_catpvn(msg, " in @INC", 8);
3247 if (instr(SvPVX(msg), ".h "))
3248 sv_catpv(msg, " (change .h to .ph maybe?)");
3249 if (instr(SvPVX(msg), ".ph "))
3250 sv_catpv(msg, " (did you run h2ph?)");
3251 sv_catpv(msg, " (@INC contains:");
3252 for (i = 0; i <= AvFILL(ar); i++) {
3253 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3254 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3255 sv_catsv(msg, dirmsgsv);
3257 sv_catpvn(msg, ")", 1);
3258 SvREFCNT_dec(dirmsgsv);
3259 msgstr = SvPV_nolen(msg);
3261 DIE(aTHX_ "Can't locate %s", msgstr);
3267 SETERRNO(0, SS_NORMAL);
3269 /* Assume success here to prevent recursive requirement. */
3271 /* Check whether a hook in @INC has already filled %INC */
3272 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3273 (void)hv_store(GvHVn(PL_incgv), name, len,
3274 (hook_sv ? SvREFCNT_inc(hook_sv)
3275 : newSVpv(CopFILE(&PL_compiling), 0)),
3281 lex_start(sv_2mortal(newSVpvn("",0)));
3282 SAVEGENERICSV(PL_rsfp_filters);
3283 PL_rsfp_filters = Nullav;
3288 SAVESPTR(PL_compiling.cop_warnings);
3289 if (PL_dowarn & G_WARN_ALL_ON)
3290 PL_compiling.cop_warnings = pWARN_ALL ;
3291 else if (PL_dowarn & G_WARN_ALL_OFF)
3292 PL_compiling.cop_warnings = pWARN_NONE ;
3293 else if (PL_taint_warn)
3294 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3296 PL_compiling.cop_warnings = pWARN_STD ;
3297 SAVESPTR(PL_compiling.cop_io);
3298 PL_compiling.cop_io = Nullsv;
3300 if (filter_sub || filter_child_proc) {
3301 SV *datasv = filter_add(run_user_filter, Nullsv);
3302 IoLINES(datasv) = filter_has_file;
3303 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3304 IoTOP_GV(datasv) = (GV *)filter_state;
3305 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3308 /* switch to eval mode */
3309 push_return(PL_op->op_next);
3310 PUSHBLOCK(cx, CXt_EVAL, SP);
3311 PUSHEVAL(cx, name, Nullgv);
3313 SAVECOPLINE(&PL_compiling);
3314 CopLINE_set(&PL_compiling, 0);
3318 /* Store and reset encoding. */
3319 encoding = PL_encoding;
3320 PL_encoding = Nullsv;
3322 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3324 /* Restore encoding. */
3325 PL_encoding = encoding;
3332 return pp_require();
3338 register PERL_CONTEXT *cx;
3340 I32 gimme = GIMME_V, was = PL_sub_generation;
3341 char tbuf[TYPE_DIGITS(long) + 12];
3342 char *tmpbuf = tbuf;
3351 TAINT_PROPER("eval");
3357 /* switch to eval mode */
3359 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3360 SV *sv = sv_newmortal();
3361 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3362 (unsigned long)++PL_evalseq,
3363 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3367 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3368 SAVECOPFILE_FREE(&PL_compiling);
3369 CopFILE_set(&PL_compiling, tmpbuf+2);
3370 SAVECOPLINE(&PL_compiling);
3371 CopLINE_set(&PL_compiling, 1);
3372 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3373 deleting the eval's FILEGV from the stash before gv_check() runs
3374 (i.e. before run-time proper). To work around the coredump that
3375 ensues, we always turn GvMULTI_on for any globals that were
3376 introduced within evals. See force_ident(). GSAR 96-10-12 */
3377 safestr = savepv(tmpbuf);
3378 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3380 PL_hints = PL_op->op_targ;
3381 SAVESPTR(PL_compiling.cop_warnings);
3382 if (specialWARN(PL_curcop->cop_warnings))
3383 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3385 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3386 SAVEFREESV(PL_compiling.cop_warnings);
3388 SAVESPTR(PL_compiling.cop_io);
3389 if (specialCopIO(PL_curcop->cop_io))
3390 PL_compiling.cop_io = PL_curcop->cop_io;
3392 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3393 SAVEFREESV(PL_compiling.cop_io);
3395 /* special case: an eval '' executed within the DB package gets lexically
3396 * placed in the first non-DB CV rather than the current CV - this
3397 * allows the debugger to execute code, find lexicals etc, in the
3398 * scope of the code being debugged. Passing &seq gets find_runcv
3399 * to do the dirty work for us */
3400 runcv = find_runcv(&seq);
3402 push_return(PL_op->op_next);
3403 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3404 PUSHEVAL(cx, 0, Nullgv);
3406 /* prepare to compile string */
3408 if (PERLDB_LINE && PL_curstash != PL_debstash)
3409 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3411 ret = doeval(gimme, NULL, runcv, seq);
3412 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3413 && ret != PL_op->op_next) { /* Successive compilation. */
3414 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3416 return DOCATCH(ret);
3426 register PERL_CONTEXT *cx;
3428 U8 save_flags = PL_op -> op_flags;
3433 retop = pop_return();
3436 if (gimme == G_VOID)
3438 else if (gimme == G_SCALAR) {
3441 if (SvFLAGS(TOPs) & SVs_TEMP)
3444 *MARK = sv_mortalcopy(TOPs);
3448 *MARK = &PL_sv_undef;
3453 /* in case LEAVE wipes old return values */
3454 for (mark = newsp + 1; mark <= SP; mark++) {
3455 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3456 *mark = sv_mortalcopy(*mark);
3457 TAINT_NOT; /* Each item is independent */
3461 PL_curpm = newpm; /* Don't pop $1 et al till now */
3464 assert(CvDEPTH(PL_compcv) == 1);
3466 CvDEPTH(PL_compcv) = 0;
3469 if (optype == OP_REQUIRE &&
3470 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3472 /* Unassume the success we assumed earlier. */
3473 SV *nsv = cx->blk_eval.old_namesv;
3474 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3475 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3476 /* die_where() did LEAVE, or we won't be here */
3480 if (!(save_flags & OPf_SPECIAL))
3490 register PERL_CONTEXT *cx;
3491 I32 gimme = GIMME_V;
3496 push_return(cLOGOP->op_other->op_next);
3497 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3500 PL_in_eval = EVAL_INEVAL;
3503 return DOCATCH(PL_op->op_next);
3514 register PERL_CONTEXT *cx;
3519 retop = pop_return();
3522 if (gimme == G_VOID)
3524 else if (gimme == G_SCALAR) {
3527 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3530 *MARK = sv_mortalcopy(TOPs);
3534 *MARK = &PL_sv_undef;
3539 /* in case LEAVE wipes old return values */
3540 for (mark = newsp + 1; mark <= SP; mark++) {
3541 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3542 *mark = sv_mortalcopy(*mark);
3543 TAINT_NOT; /* Each item is independent */
3547 PL_curpm = newpm; /* Don't pop $1 et al till now */
3555 S_doparseform(pTHX_ SV *sv)
3558 register char *s = SvPV_force(sv, len);
3559 register char *send = s + len;
3560 register char *base = Nullch;
3561 register I32 skipspaces = 0;
3562 bool noblank = FALSE;
3563 bool repeat = FALSE;
3564 bool postspace = FALSE;
3570 bool unchopnum = FALSE;
3571 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3574 Perl_croak(aTHX_ "Null picture in formline");
3576 /* estimate the buffer size needed */
3577 for (base = s; s <= send; s++) {
3578 if (*s == '\n' || *s == '@' || *s == '^')
3584 New(804, fops, maxops, U32);
3589 *fpc++ = FF_LINEMARK;
3590 noblank = repeat = FALSE;
3608 case ' ': case '\t':
3615 } /* else FALL THROUGH */
3623 *fpc++ = FF_LITERAL;
3631 *fpc++ = (U16)skipspaces;
3635 *fpc++ = FF_NEWLINE;
3639 arg = fpc - linepc + 1;
3646 *fpc++ = FF_LINEMARK;
3647 noblank = repeat = FALSE;
3656 ischop = s[-1] == '^';
3662 arg = (s - base) - 1;
3664 *fpc++ = FF_LITERAL;
3672 *fpc++ = 2; /* skip the @* or ^* */
3674 *fpc++ = FF_LINESNGL;
3677 *fpc++ = FF_LINEGLOB;
3679 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3680 arg = ischop ? 512 : 0;
3690 arg |= 256 + (s - f);
3692 *fpc++ = s - base; /* fieldsize for FETCH */
3693 *fpc++ = FF_DECIMAL;
3695 unchopnum |= ! ischop;
3697 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3698 arg = ischop ? 512 : 0;
3700 s++; /* skip the '0' first */
3709 arg |= 256 + (s - f);
3711 *fpc++ = s - base; /* fieldsize for FETCH */
3712 *fpc++ = FF_0DECIMAL;
3714 unchopnum |= ! ischop;
3718 bool ismore = FALSE;
3721 while (*++s == '>') ;
3722 prespace = FF_SPACE;
3724 else if (*s == '|') {
3725 while (*++s == '|') ;
3726 prespace = FF_HALFSPACE;
3731 while (*++s == '<') ;
3734 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3738 *fpc++ = s - base; /* fieldsize for FETCH */
3740 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3743 *fpc++ = (U16)prespace;
3757 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3759 { /* need to jump to the next word */
3761 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3762 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3763 s = SvPVX(sv) + SvCUR(sv) + z;
3765 Copy(fops, s, arg, U32);
3767 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3770 if (unchopnum && repeat)
3771 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3777 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3779 /* Can value be printed in fldsize chars, using %*.*f ? */
3783 int intsize = fldsize - (value < 0 ? 1 : 0);
3790 while (intsize--) pwr *= 10.0;
3791 while (frcsize--) eps /= 10.0;
3794 if (value + eps >= pwr)
3797 if (value - eps <= -pwr)
3804 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3806 SV *datasv = FILTER_DATA(idx);
3807 int filter_has_file = IoLINES(datasv);
3808 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3809 SV *filter_state = (SV *)IoTOP_GV(datasv);
3810 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3813 /* I was having segfault trouble under Linux 2.2.5 after a
3814 parse error occured. (Had to hack around it with a test
3815 for PL_error_count == 0.) Solaris doesn't segfault --
3816 not sure where the trouble is yet. XXX */
3818 if (filter_has_file) {
3819 len = FILTER_READ(idx+1, buf_sv, maxlen);
3822 if (filter_sub && len >= 0) {
3833 PUSHs(sv_2mortal(newSViv(maxlen)));
3835 PUSHs(filter_state);
3838 count = call_sv(filter_sub, G_SCALAR);
3854 IoLINES(datasv) = 0;
3855 if (filter_child_proc) {
3856 SvREFCNT_dec(filter_child_proc);
3857 IoFMT_GV(datasv) = Nullgv;
3860 SvREFCNT_dec(filter_state);
3861 IoTOP_GV(datasv) = Nullgv;
3864 SvREFCNT_dec(filter_sub);
3865 IoBOTTOM_GV(datasv) = Nullgv;
3867 filter_del(run_user_filter);
3873 /* perhaps someone can come up with a better name for
3874 this? it is not really "absolute", per se ... */
3876 S_path_is_absolute(pTHX_ char *name)
3878 if (PERL_FILE_IS_ABSOLUTE(name)
3879 #ifdef MACOS_TRADITIONAL
3882 || (*name == '.' && (name[1] == '/' ||
3883 (name[1] == '.' && name[2] == '/'))))