3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
161 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
163 if (cx->sb_iters++) {
164 I32 saviters = cx->sb_iters;
165 if (cx->sb_iters > cx->sb_maxiters)
166 DIE(aTHX_ "Substitution loop");
168 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
169 cx->sb_rxtainted |= 2;
170 sv_catsv(dstr, POPs);
173 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
174 s == m, cx->sb_targ, NULL,
175 ((cx->sb_rflags & REXEC_COPY_STR)
176 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
177 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
179 SV *targ = cx->sb_targ;
181 sv_catpvn(dstr, s, cx->sb_strend - s);
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 #ifdef PERL_COPY_ON_WRITE
186 sv_force_normal_flags(targ, SV_COW_DROP_PV);
190 (void)SvOOK_off(targ);
192 Safefree(SvPVX(targ));
194 SvPVX(targ) = SvPVX(dstr);
195 SvCUR_set(targ, SvCUR(dstr));
196 SvLEN_set(targ, SvLEN(dstr));
202 TAINT_IF(cx->sb_rxtainted & 1);
203 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
205 (void)SvPOK_only_UTF8(targ);
206 TAINT_IF(cx->sb_rxtainted);
210 LEAVE_SCOPE(cx->sb_oldsave);
212 RETURNOP(pm->op_next);
214 cx->sb_iters = saviters;
216 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
219 cx->sb_orig = orig = rx->subbeg;
221 cx->sb_strend = s + (cx->sb_strend - m);
223 cx->sb_m = m = rx->startp[0] + orig;
225 sv_catpvn(dstr, s, m-s);
226 cx->sb_s = rx->endp[0] + orig;
227 { /* Update the pos() information. */
228 SV *sv = cx->sb_targ;
231 if (SvTYPE(sv) < SVt_PVMG)
232 (void)SvUPGRADE(sv, SVt_PVMG);
233 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
234 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
235 mg = mg_find(sv, PERL_MAGIC_regex_global);
242 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
243 rxres_save(&cx->sb_rxres, rx);
244 RETURNOP(pm->op_pmreplstart);
248 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
253 if (!p || p[1] < rx->nparens) {
254 #ifdef PERL_COPY_ON_WRITE
255 i = 7 + rx->nparens * 2;
257 i = 6 + rx->nparens * 2;
266 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
267 RX_MATCH_COPIED_off(rx);
269 #ifdef PERL_COPY_ON_WRITE
270 *p++ = PTR2UV(rx->saved_copy);
271 rx->saved_copy = Nullsv;
276 *p++ = PTR2UV(rx->subbeg);
277 *p++ = (UV)rx->sublen;
278 for (i = 0; i <= rx->nparens; ++i) {
279 *p++ = (UV)rx->startp[i];
280 *p++ = (UV)rx->endp[i];
285 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
290 RX_MATCH_COPY_FREE(rx);
291 RX_MATCH_COPIED_set(rx, *p);
294 #ifdef PERL_COPY_ON_WRITE
296 SvREFCNT_dec (rx->saved_copy);
297 rx->saved_copy = INT2PTR(SV*,*p);
303 rx->subbeg = INT2PTR(char*,*p++);
304 rx->sublen = (I32)(*p++);
305 for (i = 0; i <= rx->nparens; ++i) {
306 rx->startp[i] = (I32)(*p++);
307 rx->endp[i] = (I32)(*p++);
312 Perl_rxres_free(pTHX_ void **rsp)
317 Safefree(INT2PTR(char*,*p));
318 #ifdef PERL_COPY_ON_WRITE
320 SvREFCNT_dec (INT2PTR(SV*,p[1]));
330 dSP; dMARK; dORIGMARK;
331 register SV *tmpForm = *++MARK;
338 register SV *sv = Nullsv;
343 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
344 char *chophere = Nullch;
345 char *linemark = Nullch;
347 bool gotsome = FALSE;
349 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
350 bool item_is_utf = FALSE;
352 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
353 if (SvREADONLY(tmpForm)) {
354 SvREADONLY_off(tmpForm);
355 doparseform(tmpForm);
356 SvREADONLY_on(tmpForm);
359 doparseform(tmpForm);
362 SvPV_force(PL_formtarget, len);
363 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
365 f = SvPV(tmpForm, len);
366 /* need to jump to the next word */
367 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
376 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
377 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
378 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
379 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
380 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
382 case FF_CHECKNL: name = "CHECKNL"; break;
383 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
384 case FF_SPACE: name = "SPACE"; break;
385 case FF_HALFSPACE: name = "HALFSPACE"; break;
386 case FF_ITEM: name = "ITEM"; break;
387 case FF_CHOP: name = "CHOP"; break;
388 case FF_LINEGLOB: name = "LINEGLOB"; break;
389 case FF_NEWLINE: name = "NEWLINE"; break;
390 case FF_MORE: name = "MORE"; break;
391 case FF_LINEMARK: name = "LINEMARK"; break;
392 case FF_END: name = "END"; break;
393 case FF_0DECIMAL: name = "0DECIMAL"; break;
396 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
398 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
426 if (ckWARN(WARN_SYNTAX))
427 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
432 item = s = SvPV(sv, len);
435 itemsize = sv_len_utf8(sv);
436 if (itemsize != (I32)len) {
438 if (itemsize > fieldsize) {
439 itemsize = fieldsize;
440 itembytes = itemsize;
441 sv_pos_u2b(sv, &itembytes, 0);
445 send = chophere = s + itembytes;
455 sv_pos_b2u(sv, &itemsize);
460 if (itemsize > fieldsize)
461 itemsize = fieldsize;
462 send = chophere = s + itemsize;
474 item = s = SvPV(sv, len);
477 itemsize = sv_len_utf8(sv);
478 if (itemsize != (I32)len) {
480 if (itemsize <= fieldsize) {
481 send = chophere = s + itemsize;
492 itemsize = fieldsize;
493 itembytes = itemsize;
494 sv_pos_u2b(sv, &itembytes, 0);
495 send = chophere = s + itembytes;
496 while (s < send || (s == send && isSPACE(*s))) {
506 if (strchr(PL_chopset, *s))
511 itemsize = chophere - item;
512 sv_pos_b2u(sv, &itemsize);
519 if (itemsize <= fieldsize) {
520 send = chophere = s + itemsize;
531 itemsize = fieldsize;
532 send = chophere = s + itemsize;
533 while (s < send || (s == send && isSPACE(*s))) {
543 if (strchr(PL_chopset, *s))
548 itemsize = chophere - item;
553 arg = fieldsize - itemsize;
562 arg = fieldsize - itemsize;
576 if (UTF8_IS_CONTINUED(*s)) {
577 STRLEN skip = UTF8SKIP(s);
594 if ( !((*t++ = *s++) & ~31) )
602 int ch = *t++ = *s++;
605 if ( !((*t++ = *s++) & ~31) )
614 while (*s && isSPACE(*s))
621 item = s = SvPV(sv, len);
623 item_is_utf = FALSE; /* XXX is this correct? */
635 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
636 sv_catpvn(PL_formtarget, item, itemsize);
637 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
638 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
643 /* If the field is marked with ^ and the value is undefined,
646 if ((arg & 512) && !SvOK(sv)) {
654 /* Formats aren't yet marked for locales, so assume "yes". */
656 STORE_NUMERIC_STANDARD_SET_LOCAL();
657 #if defined(USE_LONG_DOUBLE)
659 sprintf(t, "%#*.*" PERL_PRIfldbl,
660 (int) fieldsize, (int) arg & 255, value);
662 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
667 (int) fieldsize, (int) arg & 255, value);
670 (int) fieldsize, value);
673 RESTORE_NUMERIC_STANDARD();
679 /* If the field is marked with ^ and the value is undefined,
682 if ((arg & 512) && !SvOK(sv)) {
690 /* Formats aren't yet marked for locales, so assume "yes". */
692 STORE_NUMERIC_STANDARD_SET_LOCAL();
693 #if defined(USE_LONG_DOUBLE)
695 sprintf(t, "%#0*.*" PERL_PRIfldbl,
696 (int) fieldsize, (int) arg & 255, value);
697 /* is this legal? I don't have long doubles */
699 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
703 sprintf(t, "%#0*.*f",
704 (int) fieldsize, (int) arg & 255, value);
707 (int) fieldsize, value);
710 RESTORE_NUMERIC_STANDARD();
717 while (t-- > linemark && *t == ' ') ;
725 if (arg) { /* repeat until fields exhausted? */
727 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
728 lines += FmLINES(PL_formtarget);
731 if (strnEQ(linemark, linemark - arg, arg))
732 DIE(aTHX_ "Runaway format");
734 FmLINES(PL_formtarget) = lines;
736 RETURNOP(cLISTOP->op_first);
749 while (*s && isSPACE(*s) && s < send)
753 arg = fieldsize - itemsize;
760 if (strnEQ(s," ",3)) {
761 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
772 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
773 FmLINES(PL_formtarget) += lines;
785 if (PL_stack_base + *PL_markstack_ptr == SP) {
787 if (GIMME_V == G_SCALAR)
788 XPUSHs(sv_2mortal(newSViv(0)));
789 RETURNOP(PL_op->op_next->op_next);
791 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
792 pp_pushmark(); /* push dst */
793 pp_pushmark(); /* push src */
794 ENTER; /* enter outer scope */
797 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
799 ENTER; /* enter inner scope */
802 src = PL_stack_base[*PL_markstack_ptr];
807 if (PL_op->op_type == OP_MAPSTART)
808 pp_pushmark(); /* push top */
809 return ((LOGOP*)PL_op->op_next)->op_other;
814 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
820 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
826 /* first, move source pointer to the next item in the source list */
827 ++PL_markstack_ptr[-1];
829 /* if there are new items, push them into the destination list */
831 /* might need to make room back there first */
832 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
833 /* XXX this implementation is very pessimal because the stack
834 * is repeatedly extended for every set of items. Is possible
835 * to do this without any stack extension or copying at all
836 * by maintaining a separate list over which the map iterates
837 * (like foreach does). --gsar */
839 /* everything in the stack after the destination list moves
840 * towards the end the stack by the amount of room needed */
841 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
843 /* items to shift up (accounting for the moved source pointer) */
844 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
846 /* This optimization is by Ben Tilly and it does
847 * things differently from what Sarathy (gsar)
848 * is describing. The downside of this optimization is
849 * that leaves "holes" (uninitialized and hopefully unused areas)
850 * to the Perl stack, but on the other hand this
851 * shouldn't be a problem. If Sarathy's idea gets
852 * implemented, this optimization should become
853 * irrelevant. --jhi */
855 shift = count; /* Avoid shifting too often --Ben Tilly */
860 PL_markstack_ptr[-1] += shift;
861 *PL_markstack_ptr += shift;
865 /* copy the new items down to the destination list */
866 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
868 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
870 LEAVE; /* exit inner scope */
873 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
876 (void)POPMARK; /* pop top */
877 LEAVE; /* exit outer scope */
878 (void)POPMARK; /* pop src */
879 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
880 (void)POPMARK; /* pop dst */
881 SP = PL_stack_base + POPMARK; /* pop original mark */
882 if (gimme == G_SCALAR) {
886 else if (gimme == G_ARRAY)
893 ENTER; /* enter inner scope */
896 /* set $_ to the new source item */
897 src = PL_stack_base[PL_markstack_ptr[-1]];
901 RETURNOP(cLOGOP->op_other);
909 if (GIMME == G_ARRAY)
911 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
912 return cLOGOP->op_other;
921 if (GIMME == G_ARRAY) {
922 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
926 SV *targ = PAD_SV(PL_op->op_targ);
929 if (PL_op->op_private & OPpFLIP_LINENUM) {
930 if (GvIO(PL_last_in_gv)) {
931 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
934 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
935 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
941 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
942 if (PL_op->op_flags & OPf_SPECIAL) {
950 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
963 if (GIMME == G_ARRAY) {
969 if (SvGMAGICAL(left))
971 if (SvGMAGICAL(right))
974 /* This code tries to decide if "$left .. $right" should use the
975 magical string increment, or if the range is numeric (we make
976 an exception for .."0" [#18165]). AMS 20021031. */
978 if (SvNIOKp(left) || !SvPOKp(left) ||
979 SvNIOKp(right) || !SvPOKp(right) ||
980 (looks_like_number(left) && *SvPVX(left) != '0' &&
981 looks_like_number(right)))
983 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
984 DIE(aTHX_ "Range iterator outside integer range");
995 sv = sv_2mortal(newSViv(i++));
1000 SV *final = sv_mortalcopy(right);
1002 char *tmps = SvPV(final, len);
1004 sv = sv_mortalcopy(left);
1006 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1008 if (strEQ(SvPVX(sv),tmps))
1010 sv = sv_2mortal(newSVsv(sv));
1017 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1021 if (PL_op->op_private & OPpFLIP_LINENUM) {
1022 if (GvIO(PL_last_in_gv)) {
1023 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1026 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1027 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1035 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1036 sv_catpv(targ, "E0");
1046 static char *context_name[] = {
1057 S_dopoptolabel(pTHX_ char *label)
1060 register PERL_CONTEXT *cx;
1062 for (i = cxstack_ix; i >= 0; i--) {
1064 switch (CxTYPE(cx)) {
1070 if (ckWARN(WARN_EXITING))
1071 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1072 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1073 if (CxTYPE(cx) == CXt_NULL)
1077 if (!cx->blk_loop.label ||
1078 strNE(label, cx->blk_loop.label) ) {
1079 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1080 (long)i, cx->blk_loop.label));
1083 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1091 Perl_dowantarray(pTHX)
1093 I32 gimme = block_gimme();
1094 return (gimme == G_VOID) ? G_SCALAR : gimme;
1098 Perl_block_gimme(pTHX)
1102 cxix = dopoptosub(cxstack_ix);
1106 switch (cxstack[cxix].blk_gimme) {
1114 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1121 Perl_is_lvalue_sub(pTHX)
1125 cxix = dopoptosub(cxstack_ix);
1126 assert(cxix >= 0); /* We should only be called from inside subs */
1128 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1129 return cxstack[cxix].blk_sub.lval;
1135 S_dopoptosub(pTHX_ I32 startingblock)
1137 return dopoptosub_at(cxstack, startingblock);
1141 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1144 register PERL_CONTEXT *cx;
1145 for (i = startingblock; i >= 0; i--) {
1147 switch (CxTYPE(cx)) {
1153 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1161 S_dopoptoeval(pTHX_ I32 startingblock)
1164 register PERL_CONTEXT *cx;
1165 for (i = startingblock; i >= 0; i--) {
1167 switch (CxTYPE(cx)) {
1171 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1179 S_dopoptoloop(pTHX_ I32 startingblock)
1182 register PERL_CONTEXT *cx;
1183 for (i = startingblock; i >= 0; i--) {
1185 switch (CxTYPE(cx)) {
1191 if (ckWARN(WARN_EXITING))
1192 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1193 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1194 if ((CxTYPE(cx)) == CXt_NULL)
1198 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1206 Perl_dounwind(pTHX_ I32 cxix)
1208 register PERL_CONTEXT *cx;
1211 while (cxstack_ix > cxix) {
1213 cx = &cxstack[cxstack_ix];
1214 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1215 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1216 /* Note: we don't need to restore the base context info till the end. */
1217 switch (CxTYPE(cx)) {
1220 continue; /* not break */
1242 Perl_qerror(pTHX_ SV *err)
1245 sv_catsv(ERRSV, err);
1247 sv_catsv(PL_errors, err);
1249 Perl_warn(aTHX_ "%"SVf, err);
1254 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1262 register PERL_CONTEXT *cx;
1267 if (PL_in_eval & EVAL_KEEPERR) {
1268 static char prefix[] = "\t(in cleanup) ";
1273 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1276 if (*e != *message || strNE(e,message))
1280 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1281 sv_catpvn(err, prefix, sizeof(prefix)-1);
1282 sv_catpvn(err, message, msglen);
1283 if (ckWARN(WARN_MISC)) {
1284 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1285 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1290 sv_setpvn(ERRSV, message, msglen);
1294 message = SvPVx(ERRSV, msglen);
1296 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1297 && PL_curstackinfo->si_prev)
1306 if (cxix < cxstack_ix)
1309 POPBLOCK(cx,PL_curpm);
1310 if (CxTYPE(cx) != CXt_EVAL) {
1311 PerlIO_write(Perl_error_log, "panic: die ", 11);
1312 PerlIO_write(Perl_error_log, message, msglen);
1317 if (gimme == G_SCALAR)
1318 *++newsp = &PL_sv_undef;
1319 PL_stack_sp = newsp;
1323 /* LEAVE could clobber PL_curcop (see save_re_context())
1324 * XXX it might be better to find a way to avoid messing with
1325 * PL_curcop in save_re_context() instead, but this is a more
1326 * minimal fix --GSAR */
1327 PL_curcop = cx->blk_oldcop;
1329 if (optype == OP_REQUIRE) {
1330 char* msg = SvPVx(ERRSV, n_a);
1331 DIE(aTHX_ "%sCompilation failed in require",
1332 *msg ? msg : "Unknown error\n");
1334 return pop_return();
1338 message = SvPVx(ERRSV, msglen);
1340 /* if STDERR is tied, print to it instead */
1341 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1342 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1345 XPUSHs(SvTIED_obj((SV*)io, mg));
1346 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1348 call_method("PRINT", G_SCALAR);
1353 /* SFIO can really mess with your errno */
1356 PerlIO *serr = Perl_error_log;
1358 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1359 (void)PerlIO_flush(serr);
1372 if (SvTRUE(left) != SvTRUE(right))
1384 RETURNOP(cLOGOP->op_other);
1393 RETURNOP(cLOGOP->op_other);
1402 if (!sv || !SvANY(sv)) {
1403 RETURNOP(cLOGOP->op_other);
1406 switch (SvTYPE(sv)) {
1408 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1412 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1416 if (CvROOT(sv) || CvXSUB(sv))
1426 RETURNOP(cLOGOP->op_other);
1432 register I32 cxix = dopoptosub(cxstack_ix);
1433 register PERL_CONTEXT *cx;
1434 register PERL_CONTEXT *ccstack = cxstack;
1435 PERL_SI *top_si = PL_curstackinfo;
1446 /* we may be in a higher stacklevel, so dig down deeper */
1447 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1448 top_si = top_si->si_prev;
1449 ccstack = top_si->si_cxstack;
1450 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1453 if (GIMME != G_ARRAY) {
1459 if (PL_DBsub && cxix >= 0 &&
1460 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1464 cxix = dopoptosub_at(ccstack, cxix - 1);
1467 cx = &ccstack[cxix];
1468 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1469 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1470 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1471 field below is defined for any cx. */
1472 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1473 cx = &ccstack[dbcxix];
1476 stashname = CopSTASHPV(cx->blk_oldcop);
1477 if (GIMME != G_ARRAY) {
1480 PUSHs(&PL_sv_undef);
1483 sv_setpv(TARG, stashname);
1492 PUSHs(&PL_sv_undef);
1494 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1495 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1496 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1499 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1500 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1501 /* So is ccstack[dbcxix]. */
1504 gv_efullname3(sv, cvgv, Nullch);
1505 PUSHs(sv_2mortal(sv));
1506 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1509 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1510 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1514 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1515 PUSHs(sv_2mortal(newSViv(0)));
1517 gimme = (I32)cx->blk_gimme;
1518 if (gimme == G_VOID)
1519 PUSHs(&PL_sv_undef);
1521 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1522 if (CxTYPE(cx) == CXt_EVAL) {
1524 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1525 PUSHs(cx->blk_eval.cur_text);
1529 else if (cx->blk_eval.old_namesv) {
1530 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1533 /* eval BLOCK (try blocks have old_namesv == 0) */
1535 PUSHs(&PL_sv_undef);
1536 PUSHs(&PL_sv_undef);
1540 PUSHs(&PL_sv_undef);
1541 PUSHs(&PL_sv_undef);
1543 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1544 && CopSTASH_eq(PL_curcop, PL_debstash))
1546 AV *ary = cx->blk_sub.argarray;
1547 int off = AvARRAY(ary) - AvALLOC(ary);
1551 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1554 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1557 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1558 av_extend(PL_dbargs, AvFILLp(ary) + off);
1559 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1560 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1562 /* XXX only hints propagated via op_private are currently
1563 * visible (others are not easily accessible, since they
1564 * use the global PL_hints) */
1565 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1566 HINT_PRIVATE_MASK)));
1569 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1571 if (old_warnings == pWARN_NONE ||
1572 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1573 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1574 else if (old_warnings == pWARN_ALL ||
1575 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1576 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1578 mask = newSVsv(old_warnings);
1579 PUSHs(sv_2mortal(mask));
1594 sv_reset(tmps, CopSTASH(PL_curcop));
1604 /* like pp_nextstate, but used instead when the debugger is active */
1608 PL_curcop = (COP*)PL_op;
1609 TAINT_NOT; /* Each statement is presumed innocent */
1610 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1613 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1614 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1618 register PERL_CONTEXT *cx;
1619 I32 gimme = G_ARRAY;
1626 DIE(aTHX_ "No DB::DB routine defined");
1628 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1629 /* don't do recursive DB::DB call */
1641 push_return(PL_op->op_next);
1642 PUSHBLOCK(cx, CXt_SUB, SP);
1645 (void)SvREFCNT_inc(cv);
1646 PAD_SET_CUR(CvPADLIST(cv),1);
1647 RETURNOP(CvSTART(cv));
1661 register PERL_CONTEXT *cx;
1662 I32 gimme = GIMME_V;
1664 U32 cxtype = CXt_LOOP;
1672 if (PL_op->op_targ) {
1673 #ifndef USE_ITHREADS
1674 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1677 SAVEPADSV(PL_op->op_targ);
1678 iterdata = INT2PTR(void*, PL_op->op_targ);
1679 cxtype |= CXp_PADVAR;
1684 svp = &GvSV(gv); /* symbol table variable */
1685 SAVEGENERICSV(*svp);
1688 iterdata = (void*)gv;
1694 PUSHBLOCK(cx, cxtype, SP);
1696 PUSHLOOP(cx, iterdata, MARK);
1698 PUSHLOOP(cx, svp, MARK);
1700 if (PL_op->op_flags & OPf_STACKED) {
1701 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1702 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1704 /* See comment in pp_flop() */
1705 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1706 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1707 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1708 looks_like_number((SV*)cx->blk_loop.iterary)))
1710 if (SvNV(sv) < IV_MIN ||
1711 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1712 DIE(aTHX_ "Range iterator outside integer range");
1713 cx->blk_loop.iterix = SvIV(sv);
1714 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1717 cx->blk_loop.iterlval = newSVsv(sv);
1721 cx->blk_loop.iterary = PL_curstack;
1722 AvFILLp(PL_curstack) = SP - PL_stack_base;
1723 cx->blk_loop.iterix = MARK - PL_stack_base;
1732 register PERL_CONTEXT *cx;
1733 I32 gimme = GIMME_V;
1739 PUSHBLOCK(cx, CXt_LOOP, SP);
1740 PUSHLOOP(cx, 0, SP);
1748 register PERL_CONTEXT *cx;
1756 newsp = PL_stack_base + cx->blk_loop.resetsp;
1759 if (gimme == G_VOID)
1761 else if (gimme == G_SCALAR) {
1763 *++newsp = sv_mortalcopy(*SP);
1765 *++newsp = &PL_sv_undef;
1769 *++newsp = sv_mortalcopy(*++mark);
1770 TAINT_NOT; /* Each item is independent */
1776 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1777 PL_curpm = newpm; /* ... and pop $1 et al */
1789 register PERL_CONTEXT *cx;
1790 bool popsub2 = FALSE;
1791 bool clear_errsv = FALSE;
1798 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1799 if (cxstack_ix == PL_sortcxix
1800 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1802 if (cxstack_ix > PL_sortcxix)
1803 dounwind(PL_sortcxix);
1804 AvARRAY(PL_curstack)[1] = *SP;
1805 PL_stack_sp = PL_stack_base + 1;
1810 cxix = dopoptosub(cxstack_ix);
1812 DIE(aTHX_ "Can't return outside a subroutine");
1813 if (cxix < cxstack_ix)
1817 switch (CxTYPE(cx)) {
1822 if (!(PL_in_eval & EVAL_KEEPERR))
1828 if (optype == OP_REQUIRE &&
1829 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1831 /* Unassume the success we assumed earlier. */
1832 SV *nsv = cx->blk_eval.old_namesv;
1833 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1834 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1841 DIE(aTHX_ "panic: return");
1845 if (gimme == G_SCALAR) {
1848 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1850 *++newsp = SvREFCNT_inc(*SP);
1855 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1857 *++newsp = sv_mortalcopy(sv);
1862 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1865 *++newsp = sv_mortalcopy(*SP);
1868 *++newsp = &PL_sv_undef;
1870 else if (gimme == G_ARRAY) {
1871 while (++MARK <= SP) {
1872 *++newsp = (popsub2 && SvTEMP(*MARK))
1873 ? *MARK : sv_mortalcopy(*MARK);
1874 TAINT_NOT; /* Each item is independent */
1877 PL_stack_sp = newsp;
1879 /* Stack values are safe: */
1881 POPSUB(cx,sv); /* release CV and @_ ... */
1885 PL_curpm = newpm; /* ... and pop $1 et al */
1891 return pop_return();
1898 register PERL_CONTEXT *cx;
1908 if (PL_op->op_flags & OPf_SPECIAL) {
1909 cxix = dopoptoloop(cxstack_ix);
1911 DIE(aTHX_ "Can't \"last\" outside a loop block");
1914 cxix = dopoptolabel(cPVOP->op_pv);
1916 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1918 if (cxix < cxstack_ix)
1923 switch (CxTYPE(cx)) {
1926 newsp = PL_stack_base + cx->blk_loop.resetsp;
1927 nextop = cx->blk_loop.last_op->op_next;
1931 nextop = pop_return();
1935 nextop = pop_return();
1939 nextop = pop_return();
1942 DIE(aTHX_ "panic: last");
1946 if (gimme == G_SCALAR) {
1948 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1949 ? *SP : sv_mortalcopy(*SP);
1951 *++newsp = &PL_sv_undef;
1953 else if (gimme == G_ARRAY) {
1954 while (++MARK <= SP) {
1955 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1956 ? *MARK : sv_mortalcopy(*MARK);
1957 TAINT_NOT; /* Each item is independent */
1963 /* Stack values are safe: */
1966 POPLOOP(cx); /* release loop vars ... */
1970 POPSUB(cx,sv); /* release CV and @_ ... */
1973 PL_curpm = newpm; /* ... and pop $1 et al */
1983 register PERL_CONTEXT *cx;
1986 if (PL_op->op_flags & OPf_SPECIAL) {
1987 cxix = dopoptoloop(cxstack_ix);
1989 DIE(aTHX_ "Can't \"next\" outside a loop block");
1992 cxix = dopoptolabel(cPVOP->op_pv);
1994 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1996 if (cxix < cxstack_ix)
1999 /* clear off anything above the scope we're re-entering, but
2000 * save the rest until after a possible continue block */
2001 inner = PL_scopestack_ix;
2003 if (PL_scopestack_ix < inner)
2004 leave_scope(PL_scopestack[PL_scopestack_ix]);
2005 return cx->blk_loop.next_op;
2011 register PERL_CONTEXT *cx;
2014 if (PL_op->op_flags & OPf_SPECIAL) {
2015 cxix = dopoptoloop(cxstack_ix);
2017 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2020 cxix = dopoptolabel(cPVOP->op_pv);
2022 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2024 if (cxix < cxstack_ix)
2028 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2029 LEAVE_SCOPE(oldsave);
2030 return cx->blk_loop.redo_op;
2034 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2038 static char too_deep[] = "Target of goto is too deeply nested";
2041 Perl_croak(aTHX_ too_deep);
2042 if (o->op_type == OP_LEAVE ||
2043 o->op_type == OP_SCOPE ||
2044 o->op_type == OP_LEAVELOOP ||
2045 o->op_type == OP_LEAVESUB ||
2046 o->op_type == OP_LEAVETRY)
2048 *ops++ = cUNOPo->op_first;
2050 Perl_croak(aTHX_ too_deep);
2053 if (o->op_flags & OPf_KIDS) {
2054 /* First try all the kids at this level, since that's likeliest. */
2055 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2056 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2057 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2060 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2061 if (kid == PL_lastgotoprobe)
2063 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2066 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2067 ops[-1]->op_type == OP_DBSTATE)
2072 if ((o = dofindlabel(kid, label, ops, oplimit)))
2091 register PERL_CONTEXT *cx;
2092 #define GOTO_DEPTH 64
2093 OP *enterops[GOTO_DEPTH];
2095 int do_dump = (PL_op->op_type == OP_DUMP);
2096 static char must_have_label[] = "goto must have label";
2099 if (PL_op->op_flags & OPf_STACKED) {
2103 /* This egregious kludge implements goto &subroutine */
2104 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2106 register PERL_CONTEXT *cx;
2107 CV* cv = (CV*)SvRV(sv);
2113 if (!CvROOT(cv) && !CvXSUB(cv)) {
2118 /* autoloaded stub? */
2119 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2121 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2122 GvNAMELEN(gv), FALSE);
2123 if (autogv && (cv = GvCV(autogv)))
2125 tmpstr = sv_newmortal();
2126 gv_efullname3(tmpstr, gv, Nullch);
2127 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2129 DIE(aTHX_ "Goto undefined subroutine");
2132 /* First do some returnish stuff. */
2134 cxix = dopoptosub(cxstack_ix);
2136 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2137 if (cxix < cxstack_ix)
2141 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2143 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2144 /* put @_ back onto stack */
2145 AV* av = cx->blk_sub.argarray;
2147 items = AvFILLp(av) + 1;
2149 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2150 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2151 PL_stack_sp += items;
2152 SvREFCNT_dec(GvAV(PL_defgv));
2153 GvAV(PL_defgv) = cx->blk_sub.savearray;
2154 /* abandon @_ if it got reified */
2156 (void)sv_2mortal((SV*)av); /* delay until return */
2158 av_extend(av, items-1);
2159 AvFLAGS(av) = AVf_REIFY;
2160 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2163 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2165 av = GvAV(PL_defgv);
2166 items = AvFILLp(av) + 1;
2168 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2169 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2170 PL_stack_sp += items;
2172 if (CxTYPE(cx) == CXt_SUB &&
2173 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2174 SvREFCNT_dec(cx->blk_sub.cv);
2175 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2176 LEAVE_SCOPE(oldsave);
2178 /* Now do some callish stuff. */
2181 #ifdef PERL_XSUB_OLDSTYLE
2182 if (CvOLDSTYLE(cv)) {
2183 I32 (*fp3)(int,int,int);
2188 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2189 items = (*fp3)(CvXSUBANY(cv).any_i32,
2190 mark - PL_stack_base + 1,
2192 SP = PL_stack_base + items;
2195 #endif /* PERL_XSUB_OLDSTYLE */
2200 PL_stack_sp--; /* There is no cv arg. */
2201 /* Push a mark for the start of arglist */
2203 (void)(*CvXSUB(cv))(aTHX_ cv);
2204 /* Pop the current context like a decent sub should */
2205 POPBLOCK(cx, PL_curpm);
2206 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2209 return pop_return();
2212 AV* padlist = CvPADLIST(cv);
2213 if (CxTYPE(cx) == CXt_EVAL) {
2214 PL_in_eval = cx->blk_eval.old_in_eval;
2215 PL_eval_root = cx->blk_eval.old_eval_root;
2216 cx->cx_type = CXt_SUB;
2217 cx->blk_sub.hasargs = 0;
2219 cx->blk_sub.cv = cv;
2220 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2223 if (CvDEPTH(cv) < 2)
2224 (void)SvREFCNT_inc(cv);
2226 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2227 sub_crush_depth(cv);
2228 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2230 PAD_SET_CUR(padlist, CvDEPTH(cv));
2231 if (cx->blk_sub.hasargs)
2233 AV* av = (AV*)PAD_SVl(0);
2236 cx->blk_sub.savearray = GvAV(PL_defgv);
2237 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2238 CX_CURPAD_SAVE(cx->blk_sub);
2239 cx->blk_sub.argarray = av;
2242 if (items >= AvMAX(av) + 1) {
2244 if (AvARRAY(av) != ary) {
2245 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2246 SvPVX(av) = (char*)ary;
2248 if (items >= AvMAX(av) + 1) {
2249 AvMAX(av) = items - 1;
2250 Renew(ary,items+1,SV*);
2252 SvPVX(av) = (char*)ary;
2255 Copy(mark,AvARRAY(av),items,SV*);
2256 AvFILLp(av) = items - 1;
2257 assert(!AvREAL(av));
2264 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2266 * We do not care about using sv to call CV;
2267 * it's for informational purposes only.
2269 SV *sv = GvSV(PL_DBsub);
2272 if (PERLDB_SUB_NN) {
2273 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2276 gv_efullname3(sv, CvGV(cv), Nullch);
2279 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2280 PUSHMARK( PL_stack_sp );
2281 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2285 RETURNOP(CvSTART(cv));
2289 label = SvPV(sv,n_a);
2290 if (!(do_dump || *label))
2291 DIE(aTHX_ must_have_label);
2294 else if (PL_op->op_flags & OPf_SPECIAL) {
2296 DIE(aTHX_ must_have_label);
2299 label = cPVOP->op_pv;
2301 if (label && *label) {
2303 bool leaving_eval = FALSE;
2304 bool in_block = FALSE;
2305 PERL_CONTEXT *last_eval_cx = 0;
2309 PL_lastgotoprobe = 0;
2311 for (ix = cxstack_ix; ix >= 0; ix--) {
2313 switch (CxTYPE(cx)) {
2315 leaving_eval = TRUE;
2316 if (CxREALEVAL(cx)) {
2317 gotoprobe = (last_eval_cx ?
2318 last_eval_cx->blk_eval.old_eval_root :
2323 /* else fall through */
2325 gotoprobe = cx->blk_oldcop->op_sibling;
2331 gotoprobe = cx->blk_oldcop->op_sibling;
2334 gotoprobe = PL_main_root;
2337 if (CvDEPTH(cx->blk_sub.cv)) {
2338 gotoprobe = CvROOT(cx->blk_sub.cv);
2344 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2347 DIE(aTHX_ "panic: goto");
2348 gotoprobe = PL_main_root;
2352 retop = dofindlabel(gotoprobe, label,
2353 enterops, enterops + GOTO_DEPTH);
2357 PL_lastgotoprobe = gotoprobe;
2360 DIE(aTHX_ "Can't find label %s", label);
2362 /* if we're leaving an eval, check before we pop any frames
2363 that we're not going to punt, otherwise the error
2366 if (leaving_eval && *enterops && enterops[1]) {
2368 for (i = 1; enterops[i]; i++)
2369 if (enterops[i]->op_type == OP_ENTERITER)
2370 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2373 /* pop unwanted frames */
2375 if (ix < cxstack_ix) {
2382 oldsave = PL_scopestack[PL_scopestack_ix];
2383 LEAVE_SCOPE(oldsave);
2386 /* push wanted frames */
2388 if (*enterops && enterops[1]) {
2390 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2391 for (; enterops[ix]; ix++) {
2392 PL_op = enterops[ix];
2393 /* Eventually we may want to stack the needed arguments
2394 * for each op. For now, we punt on the hard ones. */
2395 if (PL_op->op_type == OP_ENTERITER)
2396 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2397 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2405 if (!retop) retop = PL_main_start;
2407 PL_restartop = retop;
2408 PL_do_undump = TRUE;
2412 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2413 PL_do_undump = FALSE;
2429 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2431 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2434 PL_exit_flags |= PERL_EXIT_EXPECTED;
2436 PUSHs(&PL_sv_undef);
2444 NV value = SvNVx(GvSV(cCOP->cop_gv));
2445 register I32 match = I_32(value);
2448 if (((NV)match) > value)
2449 --match; /* was fractional--truncate other way */
2451 match -= cCOP->uop.scop.scop_offset;
2454 else if (match > cCOP->uop.scop.scop_max)
2455 match = cCOP->uop.scop.scop_max;
2456 PL_op = cCOP->uop.scop.scop_next[match];
2466 PL_op = PL_op->op_next; /* can't assume anything */
2469 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2470 match -= cCOP->uop.scop.scop_offset;
2473 else if (match > cCOP->uop.scop.scop_max)
2474 match = cCOP->uop.scop.scop_max;
2475 PL_op = cCOP->uop.scop.scop_next[match];
2484 S_save_lines(pTHX_ AV *array, SV *sv)
2486 register char *s = SvPVX(sv);
2487 register char *send = SvPVX(sv) + SvCUR(sv);
2489 register I32 line = 1;
2491 while (s && s < send) {
2492 SV *tmpstr = NEWSV(85,0);
2494 sv_upgrade(tmpstr, SVt_PVMG);
2495 t = strchr(s, '\n');
2501 sv_setpvn(tmpstr, s, t - s);
2502 av_store(array, line++, tmpstr);
2507 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2509 S_docatch_body(pTHX_ va_list args)
2511 return docatch_body();
2516 S_docatch_body(pTHX)
2523 S_docatch(pTHX_ OP *o)
2528 volatile PERL_SI *cursi = PL_curstackinfo;
2532 assert(CATCH_GET == TRUE);
2536 /* Normally, the leavetry at the end of this block of ops will
2537 * pop an op off the return stack and continue there. By setting
2538 * the op to Nullop, we force an exit from the inner runops()
2541 retop = pop_return();
2542 push_return(Nullop);
2544 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2546 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2552 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2558 /* die caught by an inner eval - continue inner loop */
2559 if (PL_restartop && cursi == PL_curstackinfo) {
2560 PL_op = PL_restartop;
2564 /* a die in this eval - continue in outer loop */
2580 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2581 /* sv Text to convert to OP tree. */
2582 /* startop op_free() this to undo. */
2583 /* code Short string id of the caller. */
2585 dSP; /* Make POPBLOCK work. */
2588 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2592 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2593 char *tmpbuf = tbuf;
2596 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2601 /* switch to eval mode */
2603 if (PL_curcop == &PL_compiling) {
2604 SAVECOPSTASH_FREE(&PL_compiling);
2605 CopSTASH_set(&PL_compiling, PL_curstash);
2607 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2608 SV *sv = sv_newmortal();
2609 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2610 code, (unsigned long)++PL_evalseq,
2611 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2615 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2616 SAVECOPFILE_FREE(&PL_compiling);
2617 CopFILE_set(&PL_compiling, tmpbuf+2);
2618 SAVECOPLINE(&PL_compiling);
2619 CopLINE_set(&PL_compiling, 1);
2620 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2621 deleting the eval's FILEGV from the stash before gv_check() runs
2622 (i.e. before run-time proper). To work around the coredump that
2623 ensues, we always turn GvMULTI_on for any globals that were
2624 introduced within evals. See force_ident(). GSAR 96-10-12 */
2625 safestr = savepv(tmpbuf);
2626 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2628 #ifdef OP_IN_REGISTER
2633 PL_hints &= HINT_UTF8;
2635 /* we get here either during compilation, or via pp_regcomp at runtime */
2636 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2638 runcv = find_runcv(NULL);
2641 PL_op->op_type = OP_ENTEREVAL;
2642 PL_op->op_flags = 0; /* Avoid uninit warning. */
2643 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2644 PUSHEVAL(cx, 0, Nullgv);
2647 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2649 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2650 POPBLOCK(cx,PL_curpm);
2653 (*startop)->op_type = OP_NULL;
2654 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2656 /* XXX DAPM do this properly one year */
2657 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2659 if (PL_curcop == &PL_compiling)
2660 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2661 #ifdef OP_IN_REGISTER
2669 =for apidoc find_runcv
2671 Locate the CV corresponding to the currently executing sub or eval.
2672 If db_seqp is non_null, skip CVs that are in the DB package and populate
2673 *db_seqp with the cop sequence number at the point that the DB:: code was
2674 entered. (allows debuggers to eval in the scope of the breakpoint rather
2675 than in in the scope of the debuger itself).
2681 Perl_find_runcv(pTHX_ U32 *db_seqp)
2688 *db_seqp = PL_curcop->cop_seq;
2689 for (si = PL_curstackinfo; si; si = si->si_prev) {
2690 for (ix = si->si_cxix; ix >= 0; ix--) {
2691 cx = &(si->si_cxstack[ix]);
2692 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2693 CV *cv = cx->blk_sub.cv;
2694 /* skip DB:: code */
2695 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2696 *db_seqp = cx->blk_oldcop->cop_seq;
2701 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2709 /* Compile a require/do, an eval '', or a /(?{...})/.
2710 * In the last case, startop is non-null, and contains the address of
2711 * a pointer that should be set to the just-compiled code.
2712 * outside is the lexically enclosing CV (if any) that invoked us.
2715 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2717 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2722 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2723 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2728 SAVESPTR(PL_compcv);
2729 PL_compcv = (CV*)NEWSV(1104,0);
2730 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2731 CvEVAL_on(PL_compcv);
2732 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2733 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2735 CvOUTSIDE_SEQ(PL_compcv) = seq;
2736 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2738 /* set up a scratch pad */
2740 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2743 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2745 /* make sure we compile in the right package */
2747 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2748 SAVESPTR(PL_curstash);
2749 PL_curstash = CopSTASH(PL_curcop);
2751 SAVESPTR(PL_beginav);
2752 PL_beginav = newAV();
2753 SAVEFREESV(PL_beginav);
2754 SAVEI32(PL_error_count);
2756 /* try to compile it */
2758 PL_eval_root = Nullop;
2760 PL_curcop = &PL_compiling;
2761 PL_curcop->cop_arybase = 0;
2762 if (saveop && saveop->op_flags & OPf_SPECIAL)
2763 PL_in_eval |= EVAL_KEEPERR;
2766 if (yyparse() || PL_error_count || !PL_eval_root) {
2770 I32 optype = 0; /* Might be reset by POPEVAL. */
2775 op_free(PL_eval_root);
2776 PL_eval_root = Nullop;
2778 SP = PL_stack_base + POPMARK; /* pop original mark */
2780 POPBLOCK(cx,PL_curpm);
2786 if (optype == OP_REQUIRE) {
2787 char* msg = SvPVx(ERRSV, n_a);
2788 DIE(aTHX_ "%sCompilation failed in require",
2789 *msg ? msg : "Unknown error\n");
2792 char* msg = SvPVx(ERRSV, n_a);
2794 POPBLOCK(cx,PL_curpm);
2796 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2797 (*msg ? msg : "Unknown error\n"));
2800 char* msg = SvPVx(ERRSV, n_a);
2802 sv_setpv(ERRSV, "Compilation error");
2807 CopLINE_set(&PL_compiling, 0);
2809 *startop = PL_eval_root;
2811 SAVEFREEOP(PL_eval_root);
2813 scalarvoid(PL_eval_root);
2814 else if (gimme & G_ARRAY)
2817 scalar(PL_eval_root);
2819 DEBUG_x(dump_eval());
2821 /* Register with debugger: */
2822 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2823 CV *cv = get_cv("DB::postponed", FALSE);
2827 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2829 call_sv((SV*)cv, G_DISCARD);
2833 /* compiled okay, so do it */
2835 CvDEPTH(PL_compcv) = 1;
2836 SP = PL_stack_base + POPMARK; /* pop original mark */
2837 PL_op = saveop; /* The caller may need it. */
2838 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2840 RETURNOP(PL_eval_start);
2844 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2846 STRLEN namelen = strlen(name);
2849 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2850 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2851 char *pmc = SvPV_nolen(pmcsv);
2854 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2855 fp = PerlIO_open(name, mode);
2858 if (PerlLIO_stat(name, &pmstat) < 0 ||
2859 pmstat.st_mtime < pmcstat.st_mtime)
2861 fp = PerlIO_open(pmc, mode);
2864 fp = PerlIO_open(name, mode);
2867 SvREFCNT_dec(pmcsv);
2870 fp = PerlIO_open(name, mode);
2878 register PERL_CONTEXT *cx;
2882 char *tryname = Nullch;
2883 SV *namesv = Nullsv;
2885 I32 gimme = GIMME_V;
2886 PerlIO *tryrsfp = 0;
2888 int filter_has_file = 0;
2889 GV *filter_child_proc = 0;
2890 SV *filter_state = 0;
2897 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2898 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2899 UV rev = 0, ver = 0, sver = 0;
2901 U8 *s = (U8*)SvPVX(sv);
2902 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2904 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2907 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2910 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2913 if (PERL_REVISION < rev
2914 || (PERL_REVISION == rev
2915 && (PERL_VERSION < ver
2916 || (PERL_VERSION == ver
2917 && PERL_SUBVERSION < sver))))
2919 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2920 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2921 PERL_VERSION, PERL_SUBVERSION);
2923 if (ckWARN(WARN_PORTABLE))
2924 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2925 "v-string in use/require non-portable");
2928 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2929 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2930 + ((NV)PERL_SUBVERSION/(NV)1000000)
2931 + 0.00000099 < SvNV(sv))
2935 NV nver = (nrev - rev) * 1000;
2936 UV ver = (UV)(nver + 0.0009);
2937 NV nsver = (nver - ver) * 1000;
2938 UV sver = (UV)(nsver + 0.0009);
2940 /* help out with the "use 5.6" confusion */
2941 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2942 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2943 " (did you mean v%"UVuf".%03"UVuf"?)--"
2944 "this is only v%d.%d.%d, stopped",
2945 rev, ver, sver, rev, ver/100,
2946 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2949 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2950 "this is only v%d.%d.%d, stopped",
2951 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2958 name = SvPV(sv, len);
2959 if (!(name && len > 0 && *name))
2960 DIE(aTHX_ "Null filename used");
2961 TAINT_PROPER("require");
2962 if (PL_op->op_type == OP_REQUIRE &&
2963 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2964 *svp != &PL_sv_undef)
2967 /* prepare to compile file */
2969 if (path_is_absolute(name)) {
2971 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2973 #ifdef MACOS_TRADITIONAL
2977 MacPerl_CanonDir(name, newname, 1);
2978 if (path_is_absolute(newname)) {
2980 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2985 AV *ar = GvAVn(PL_incgv);
2989 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2992 namesv = NEWSV(806, 0);
2993 for (i = 0; i <= AvFILL(ar); i++) {
2994 SV *dirsv = *av_fetch(ar, i, TRUE);
3000 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3001 && !sv_isobject(loader))
3003 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3006 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3007 PTR2UV(SvRV(dirsv)), name);
3008 tryname = SvPVX(namesv);
3019 if (sv_isobject(loader))
3020 count = call_method("INC", G_ARRAY);
3022 count = call_sv(loader, G_ARRAY);
3032 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3036 if (SvTYPE(arg) == SVt_PVGV) {
3037 IO *io = GvIO((GV *)arg);
3042 tryrsfp = IoIFP(io);
3043 if (IoTYPE(io) == IoTYPE_PIPE) {
3044 /* reading from a child process doesn't
3045 nest -- when returning from reading
3046 the inner module, the outer one is
3047 unreadable (closed?) I've tried to
3048 save the gv to manage the lifespan of
3049 the pipe, but this didn't help. XXX */
3050 filter_child_proc = (GV *)arg;
3051 (void)SvREFCNT_inc(filter_child_proc);
3054 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3055 PerlIO_close(IoOFP(io));
3067 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3069 (void)SvREFCNT_inc(filter_sub);
3072 filter_state = SP[i];
3073 (void)SvREFCNT_inc(filter_state);
3077 tryrsfp = PerlIO_open("/dev/null",
3092 filter_has_file = 0;
3093 if (filter_child_proc) {
3094 SvREFCNT_dec(filter_child_proc);
3095 filter_child_proc = 0;
3098 SvREFCNT_dec(filter_state);
3102 SvREFCNT_dec(filter_sub);
3107 if (!path_is_absolute(name)
3108 #ifdef MACOS_TRADITIONAL
3109 /* We consider paths of the form :a:b ambiguous and interpret them first
3110 as global then as local
3112 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3115 char *dir = SvPVx(dirsv, n_a);
3116 #ifdef MACOS_TRADITIONAL
3120 MacPerl_CanonDir(name, buf2, 1);
3121 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3125 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3127 sv_setpv(namesv, unixdir);
3128 sv_catpv(namesv, unixname);
3130 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3133 TAINT_PROPER("require");
3134 tryname = SvPVX(namesv);
3135 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3137 if (tryname[0] == '.' && tryname[1] == '/')
3146 SAVECOPFILE_FREE(&PL_compiling);
3147 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3148 SvREFCNT_dec(namesv);
3150 if (PL_op->op_type == OP_REQUIRE) {
3151 char *msgstr = name;
3152 if (namesv) { /* did we lookup @INC? */
3153 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3154 SV *dirmsgsv = NEWSV(0, 0);
3155 AV *ar = GvAVn(PL_incgv);
3157 sv_catpvn(msg, " in @INC", 8);
3158 if (instr(SvPVX(msg), ".h "))
3159 sv_catpv(msg, " (change .h to .ph maybe?)");
3160 if (instr(SvPVX(msg), ".ph "))
3161 sv_catpv(msg, " (did you run h2ph?)");
3162 sv_catpv(msg, " (@INC contains:");
3163 for (i = 0; i <= AvFILL(ar); i++) {
3164 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3165 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3166 sv_catsv(msg, dirmsgsv);
3168 sv_catpvn(msg, ")", 1);
3169 SvREFCNT_dec(dirmsgsv);
3170 msgstr = SvPV_nolen(msg);
3172 DIE(aTHX_ "Can't locate %s", msgstr);
3178 SETERRNO(0, SS_NORMAL);
3180 /* Assume success here to prevent recursive requirement. */
3182 /* Check whether a hook in @INC has already filled %INC */
3183 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3184 (void)hv_store(GvHVn(PL_incgv), name, len,
3185 (hook_sv ? SvREFCNT_inc(hook_sv)
3186 : newSVpv(CopFILE(&PL_compiling), 0)),
3192 lex_start(sv_2mortal(newSVpvn("",0)));
3193 SAVEGENERICSV(PL_rsfp_filters);
3194 PL_rsfp_filters = Nullav;
3199 SAVESPTR(PL_compiling.cop_warnings);
3200 if (PL_dowarn & G_WARN_ALL_ON)
3201 PL_compiling.cop_warnings = pWARN_ALL ;
3202 else if (PL_dowarn & G_WARN_ALL_OFF)
3203 PL_compiling.cop_warnings = pWARN_NONE ;
3204 else if (PL_taint_warn)
3205 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3207 PL_compiling.cop_warnings = pWARN_STD ;
3208 SAVESPTR(PL_compiling.cop_io);
3209 PL_compiling.cop_io = Nullsv;
3211 if (filter_sub || filter_child_proc) {
3212 SV *datasv = filter_add(run_user_filter, Nullsv);
3213 IoLINES(datasv) = filter_has_file;
3214 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3215 IoTOP_GV(datasv) = (GV *)filter_state;
3216 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3219 /* switch to eval mode */
3220 push_return(PL_op->op_next);
3221 PUSHBLOCK(cx, CXt_EVAL, SP);
3222 PUSHEVAL(cx, name, Nullgv);
3224 SAVECOPLINE(&PL_compiling);
3225 CopLINE_set(&PL_compiling, 0);
3229 /* Store and reset encoding. */
3230 encoding = PL_encoding;
3231 PL_encoding = Nullsv;
3233 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3235 /* Restore encoding. */
3236 PL_encoding = encoding;
3243 return pp_require();
3249 register PERL_CONTEXT *cx;
3251 I32 gimme = GIMME_V, was = PL_sub_generation;
3252 char tbuf[TYPE_DIGITS(long) + 12];
3253 char *tmpbuf = tbuf;
3262 TAINT_PROPER("eval");
3268 /* switch to eval mode */
3270 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3271 SV *sv = sv_newmortal();
3272 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3273 (unsigned long)++PL_evalseq,
3274 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3278 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3279 SAVECOPFILE_FREE(&PL_compiling);
3280 CopFILE_set(&PL_compiling, tmpbuf+2);
3281 SAVECOPLINE(&PL_compiling);
3282 CopLINE_set(&PL_compiling, 1);
3283 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3284 deleting the eval's FILEGV from the stash before gv_check() runs
3285 (i.e. before run-time proper). To work around the coredump that
3286 ensues, we always turn GvMULTI_on for any globals that were
3287 introduced within evals. See force_ident(). GSAR 96-10-12 */
3288 safestr = savepv(tmpbuf);
3289 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3291 PL_hints = PL_op->op_targ;
3292 SAVESPTR(PL_compiling.cop_warnings);
3293 if (specialWARN(PL_curcop->cop_warnings))
3294 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3296 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3297 SAVEFREESV(PL_compiling.cop_warnings);
3299 SAVESPTR(PL_compiling.cop_io);
3300 if (specialCopIO(PL_curcop->cop_io))
3301 PL_compiling.cop_io = PL_curcop->cop_io;
3303 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3304 SAVEFREESV(PL_compiling.cop_io);
3306 /* special case: an eval '' executed within the DB package gets lexically
3307 * placed in the first non-DB CV rather than the current CV - this
3308 * allows the debugger to execute code, find lexicals etc, in the
3309 * scope of the code being debugged. Passing &seq gets find_runcv
3310 * to do the dirty work for us */
3311 runcv = find_runcv(&seq);
3313 push_return(PL_op->op_next);
3314 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3315 PUSHEVAL(cx, 0, Nullgv);
3317 /* prepare to compile string */
3319 if (PERLDB_LINE && PL_curstash != PL_debstash)
3320 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3322 ret = doeval(gimme, NULL, runcv, seq);
3323 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3324 && ret != PL_op->op_next) { /* Successive compilation. */
3325 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3327 return DOCATCH(ret);
3337 register PERL_CONTEXT *cx;
3339 U8 save_flags = PL_op -> op_flags;
3344 retop = pop_return();
3347 if (gimme == G_VOID)
3349 else if (gimme == G_SCALAR) {
3352 if (SvFLAGS(TOPs) & SVs_TEMP)
3355 *MARK = sv_mortalcopy(TOPs);
3359 *MARK = &PL_sv_undef;
3364 /* in case LEAVE wipes old return values */
3365 for (mark = newsp + 1; mark <= SP; mark++) {
3366 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3367 *mark = sv_mortalcopy(*mark);
3368 TAINT_NOT; /* Each item is independent */
3372 PL_curpm = newpm; /* Don't pop $1 et al till now */
3375 assert(CvDEPTH(PL_compcv) == 1);
3377 CvDEPTH(PL_compcv) = 0;
3380 if (optype == OP_REQUIRE &&
3381 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3383 /* Unassume the success we assumed earlier. */
3384 SV *nsv = cx->blk_eval.old_namesv;
3385 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3386 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3387 /* die_where() did LEAVE, or we won't be here */
3391 if (!(save_flags & OPf_SPECIAL))
3401 register PERL_CONTEXT *cx;
3402 I32 gimme = GIMME_V;
3407 push_return(cLOGOP->op_other->op_next);
3408 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3411 PL_in_eval = EVAL_INEVAL;
3414 return DOCATCH(PL_op->op_next);
3425 register PERL_CONTEXT *cx;
3430 retop = pop_return();
3433 if (gimme == G_VOID)
3435 else if (gimme == G_SCALAR) {
3438 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3441 *MARK = sv_mortalcopy(TOPs);
3445 *MARK = &PL_sv_undef;
3450 /* in case LEAVE wipes old return values */
3451 for (mark = newsp + 1; mark <= SP; mark++) {
3452 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3453 *mark = sv_mortalcopy(*mark);
3454 TAINT_NOT; /* Each item is independent */
3458 PL_curpm = newpm; /* Don't pop $1 et al till now */
3466 S_doparseform(pTHX_ SV *sv)
3469 register char *s = SvPV_force(sv, len);
3470 register char *send = s + len;
3471 register char *base = Nullch;
3472 register I32 skipspaces = 0;
3473 bool noblank = FALSE;
3474 bool repeat = FALSE;
3475 bool postspace = FALSE;
3483 Perl_croak(aTHX_ "Null picture in formline");
3485 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3490 *fpc++ = FF_LINEMARK;
3491 noblank = repeat = FALSE;
3509 case ' ': case '\t':
3520 *fpc++ = FF_LITERAL;
3528 *fpc++ = (U16)skipspaces;
3532 *fpc++ = FF_NEWLINE;
3536 arg = fpc - linepc + 1;
3543 *fpc++ = FF_LINEMARK;
3544 noblank = repeat = FALSE;
3553 ischop = s[-1] == '^';
3559 arg = (s - base) - 1;
3561 *fpc++ = FF_LITERAL;
3570 *fpc++ = FF_LINEGLOB;
3572 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3573 arg = ischop ? 512 : 0;
3583 arg |= 256 + (s - f);
3585 *fpc++ = s - base; /* fieldsize for FETCH */
3586 *fpc++ = FF_DECIMAL;
3589 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3590 arg = ischop ? 512 : 0;
3592 s++; /* skip the '0' first */
3601 arg |= 256 + (s - f);
3603 *fpc++ = s - base; /* fieldsize for FETCH */
3604 *fpc++ = FF_0DECIMAL;
3609 bool ismore = FALSE;
3612 while (*++s == '>') ;
3613 prespace = FF_SPACE;
3615 else if (*s == '|') {
3616 while (*++s == '|') ;
3617 prespace = FF_HALFSPACE;
3622 while (*++s == '<') ;
3625 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3629 *fpc++ = s - base; /* fieldsize for FETCH */
3631 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3634 *fpc++ = (U16)prespace;
3649 { /* need to jump to the next word */
3651 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3652 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3653 s = SvPVX(sv) + SvCUR(sv) + z;
3655 Copy(fops, s, arg, U16);
3657 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3662 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3664 SV *datasv = FILTER_DATA(idx);
3665 int filter_has_file = IoLINES(datasv);
3666 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3667 SV *filter_state = (SV *)IoTOP_GV(datasv);
3668 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3671 /* I was having segfault trouble under Linux 2.2.5 after a
3672 parse error occured. (Had to hack around it with a test
3673 for PL_error_count == 0.) Solaris doesn't segfault --
3674 not sure where the trouble is yet. XXX */
3676 if (filter_has_file) {
3677 len = FILTER_READ(idx+1, buf_sv, maxlen);
3680 if (filter_sub && len >= 0) {
3691 PUSHs(sv_2mortal(newSViv(maxlen)));
3693 PUSHs(filter_state);
3696 count = call_sv(filter_sub, G_SCALAR);
3712 IoLINES(datasv) = 0;
3713 if (filter_child_proc) {
3714 SvREFCNT_dec(filter_child_proc);
3715 IoFMT_GV(datasv) = Nullgv;
3718 SvREFCNT_dec(filter_state);
3719 IoTOP_GV(datasv) = Nullgv;
3722 SvREFCNT_dec(filter_sub);
3723 IoBOTTOM_GV(datasv) = Nullgv;
3725 filter_del(run_user_filter);
3731 /* perhaps someone can come up with a better name for
3732 this? it is not really "absolute", per se ... */
3734 S_path_is_absolute(pTHX_ char *name)
3736 if (PERL_FILE_IS_ABSOLUTE(name)
3737 #ifdef MACOS_TRADITIONAL
3740 || (*name == '.' && (name[1] == '/' ||
3741 (name[1] == '.' && name[2] == '/'))))