3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 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 assert(cx->sb_strend >= s);
191 if(cx->sb_strend > s) {
192 if (DO_UTF8(dstr) && !SvUTF8(targ))
193 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
195 sv_catpvn(dstr, s, cx->sb_strend - s);
197 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
199 #ifdef PERL_COPY_ON_WRITE
201 sv_force_normal_flags(targ, SV_COW_DROP_PV);
205 (void)SvOOK_off(targ);
207 Safefree(SvPVX(targ));
209 SvPVX(targ) = SvPVX(dstr);
210 SvCUR_set(targ, SvCUR(dstr));
211 SvLEN_set(targ, SvLEN(dstr));
217 TAINT_IF(cx->sb_rxtainted & 1);
218 PUSHs(sv_2mortal(newSViv(saviters - 1)));
220 (void)SvPOK_only_UTF8(targ);
221 TAINT_IF(cx->sb_rxtainted);
225 LEAVE_SCOPE(cx->sb_oldsave);
228 RETURNOP(pm->op_next);
230 cx->sb_iters = saviters;
232 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
235 cx->sb_orig = orig = rx->subbeg;
237 cx->sb_strend = s + (cx->sb_strend - m);
239 cx->sb_m = m = rx->startp[0] + orig;
241 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
242 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
244 sv_catpvn(dstr, s, m-s);
246 cx->sb_s = rx->endp[0] + orig;
247 { /* Update the pos() information. */
248 SV *sv = cx->sb_targ;
251 if (SvTYPE(sv) < SVt_PVMG)
252 (void)SvUPGRADE(sv, SVt_PVMG);
253 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
254 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
255 mg = mg_find(sv, PERL_MAGIC_regex_global);
264 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
265 rxres_save(&cx->sb_rxres, rx);
266 RETURNOP(pm->op_pmreplstart);
270 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
275 if (!p || p[1] < rx->nparens) {
276 #ifdef PERL_COPY_ON_WRITE
277 i = 7 + rx->nparens * 2;
279 i = 6 + rx->nparens * 2;
288 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
289 RX_MATCH_COPIED_off(rx);
291 #ifdef PERL_COPY_ON_WRITE
292 *p++ = PTR2UV(rx->saved_copy);
293 rx->saved_copy = Nullsv;
298 *p++ = PTR2UV(rx->subbeg);
299 *p++ = (UV)rx->sublen;
300 for (i = 0; i <= rx->nparens; ++i) {
301 *p++ = (UV)rx->startp[i];
302 *p++ = (UV)rx->endp[i];
307 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
312 RX_MATCH_COPY_FREE(rx);
313 RX_MATCH_COPIED_set(rx, *p);
316 #ifdef PERL_COPY_ON_WRITE
318 SvREFCNT_dec (rx->saved_copy);
319 rx->saved_copy = INT2PTR(SV*,*p);
325 rx->subbeg = INT2PTR(char*,*p++);
326 rx->sublen = (I32)(*p++);
327 for (i = 0; i <= rx->nparens; ++i) {
328 rx->startp[i] = (I32)(*p++);
329 rx->endp[i] = (I32)(*p++);
334 Perl_rxres_free(pTHX_ void **rsp)
339 Safefree(INT2PTR(char*,*p));
340 #ifdef PERL_COPY_ON_WRITE
342 SvREFCNT_dec (INT2PTR(SV*,p[1]));
352 dSP; dMARK; dORIGMARK;
353 register SV *tmpForm = *++MARK;
360 register SV *sv = Nullsv;
365 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
366 char *chophere = Nullch;
367 char *linemark = Nullch;
369 bool gotsome = FALSE;
371 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
372 bool item_is_utf8 = FALSE;
373 bool targ_is_utf8 = FALSE;
379 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
380 if (SvREADONLY(tmpForm)) {
381 SvREADONLY_off(tmpForm);
382 parseres = doparseform(tmpForm);
383 SvREADONLY_on(tmpForm);
386 parseres = doparseform(tmpForm);
390 SvPV_force(PL_formtarget, len);
391 if (DO_UTF8(PL_formtarget))
393 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
395 f = SvPV(tmpForm, len);
396 /* need to jump to the next word */
397 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
406 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
407 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
408 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
409 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
410 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
412 case FF_CHECKNL: name = "CHECKNL"; break;
413 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
414 case FF_SPACE: name = "SPACE"; break;
415 case FF_HALFSPACE: name = "HALFSPACE"; break;
416 case FF_ITEM: name = "ITEM"; break;
417 case FF_CHOP: name = "CHOP"; break;
418 case FF_LINEGLOB: name = "LINEGLOB"; break;
419 case FF_NEWLINE: name = "NEWLINE"; break;
420 case FF_MORE: name = "MORE"; break;
421 case FF_LINEMARK: name = "LINEMARK"; break;
422 case FF_END: name = "END"; break;
423 case FF_0DECIMAL: name = "0DECIMAL"; break;
424 case FF_LINESNGL: name = "LINESNGL"; break;
427 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
429 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
440 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
441 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
443 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
444 t = SvEND(PL_formtarget);
447 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
448 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
450 sv_utf8_upgrade(PL_formtarget);
451 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
452 t = SvEND(PL_formtarget);
472 if (ckWARN(WARN_SYNTAX))
473 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
478 item = s = SvPV(sv, len);
481 itemsize = sv_len_utf8(sv);
482 if (itemsize != (I32)len) {
484 if (itemsize > fieldsize) {
485 itemsize = fieldsize;
486 itembytes = itemsize;
487 sv_pos_u2b(sv, &itembytes, 0);
491 send = chophere = s + itembytes;
501 sv_pos_b2u(sv, &itemsize);
505 item_is_utf8 = FALSE;
506 if (itemsize > fieldsize)
507 itemsize = fieldsize;
508 send = chophere = s + itemsize;
520 item = s = SvPV(sv, len);
523 itemsize = sv_len_utf8(sv);
524 if (itemsize != (I32)len) {
526 if (itemsize <= fieldsize) {
527 send = chophere = s + itemsize;
539 itemsize = fieldsize;
540 itembytes = itemsize;
541 sv_pos_u2b(sv, &itembytes, 0);
542 send = chophere = s + itembytes;
543 while (s < send || (s == send && isSPACE(*s))) {
553 if (strchr(PL_chopset, *s))
558 itemsize = chophere - item;
559 sv_pos_b2u(sv, &itemsize);
565 item_is_utf8 = FALSE;
566 if (itemsize <= fieldsize) {
567 send = chophere = s + itemsize;
579 itemsize = fieldsize;
580 send = chophere = s + itemsize;
581 while (s < send || (s == send && isSPACE(*s))) {
591 if (strchr(PL_chopset, *s))
596 itemsize = chophere - item;
601 arg = fieldsize - itemsize;
610 arg = fieldsize - itemsize;
624 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
626 sv_utf8_upgrade(PL_formtarget);
627 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
628 t = SvEND(PL_formtarget);
632 if (UTF8_IS_CONTINUED(*s)) {
633 STRLEN skip = UTF8SKIP(s);
650 if ( !((*t++ = *s++) & ~31) )
656 if (targ_is_utf8 && !item_is_utf8) {
657 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
659 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
660 for (; t < SvEND(PL_formtarget); t++) {
673 int ch = *t++ = *s++;
676 if ( !((*t++ = *s++) & ~31) )
685 while (*s && isSPACE(*s))
699 item = s = SvPV(sv, len);
701 if ((item_is_utf8 = DO_UTF8(sv)))
702 itemsize = sv_len_utf8(sv);
704 bool chopped = FALSE;
707 chophere = s + itemsize;
723 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
725 SvUTF8_on(PL_formtarget);
727 SvCUR_set(sv, chophere - item);
728 sv_catsv(PL_formtarget, sv);
729 SvCUR_set(sv, itemsize);
731 sv_catsv(PL_formtarget, sv);
733 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
734 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
735 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
743 #if defined(USE_LONG_DOUBLE)
744 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
746 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
751 #if defined(USE_LONG_DOUBLE)
752 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
754 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
757 /* If the field is marked with ^ and the value is undefined,
759 if ((arg & 512) && !SvOK(sv)) {
767 /* overflow evidence */
768 if (num_overflow(value, fieldsize, arg)) {
774 /* Formats aren't yet marked for locales, so assume "yes". */
776 STORE_NUMERIC_STANDARD_SET_LOCAL();
777 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
778 RESTORE_NUMERIC_STANDARD();
785 while (t-- > linemark && *t == ' ') ;
793 if (arg) { /* repeat until fields exhausted? */
795 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
796 lines += FmLINES(PL_formtarget);
799 if (strnEQ(linemark, linemark - arg, arg))
800 DIE(aTHX_ "Runaway format");
803 SvUTF8_on(PL_formtarget);
804 FmLINES(PL_formtarget) = lines;
806 RETURNOP(cLISTOP->op_first);
819 while (*s && isSPACE(*s) && s < send)
823 arg = fieldsize - itemsize;
830 if (strnEQ(s," ",3)) {
831 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
842 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
844 SvUTF8_on(PL_formtarget);
845 FmLINES(PL_formtarget) += lines;
857 if (PL_stack_base + *PL_markstack_ptr == SP) {
859 if (GIMME_V == G_SCALAR)
860 XPUSHs(sv_2mortal(newSViv(0)));
861 RETURNOP(PL_op->op_next->op_next);
863 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
864 pp_pushmark(); /* push dst */
865 pp_pushmark(); /* push src */
866 ENTER; /* enter outer scope */
869 if (PL_op->op_private & OPpGREP_LEX)
870 SAVESPTR(PAD_SVl(PL_op->op_targ));
873 ENTER; /* enter inner scope */
876 src = PL_stack_base[*PL_markstack_ptr];
878 if (PL_op->op_private & OPpGREP_LEX)
879 PAD_SVl(PL_op->op_targ) = src;
884 if (PL_op->op_type == OP_MAPSTART)
885 pp_pushmark(); /* push top */
886 return ((LOGOP*)PL_op->op_next)->op_other;
891 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
898 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
904 /* first, move source pointer to the next item in the source list */
905 ++PL_markstack_ptr[-1];
907 /* if there are new items, push them into the destination list */
908 if (items && gimme != G_VOID) {
909 /* might need to make room back there first */
910 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
911 /* XXX this implementation is very pessimal because the stack
912 * is repeatedly extended for every set of items. Is possible
913 * to do this without any stack extension or copying at all
914 * by maintaining a separate list over which the map iterates
915 * (like foreach does). --gsar */
917 /* everything in the stack after the destination list moves
918 * towards the end the stack by the amount of room needed */
919 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
921 /* items to shift up (accounting for the moved source pointer) */
922 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
924 /* This optimization is by Ben Tilly and it does
925 * things differently from what Sarathy (gsar)
926 * is describing. The downside of this optimization is
927 * that leaves "holes" (uninitialized and hopefully unused areas)
928 * to the Perl stack, but on the other hand this
929 * shouldn't be a problem. If Sarathy's idea gets
930 * implemented, this optimization should become
931 * irrelevant. --jhi */
933 shift = count; /* Avoid shifting too often --Ben Tilly */
938 PL_markstack_ptr[-1] += shift;
939 *PL_markstack_ptr += shift;
943 /* copy the new items down to the destination list */
944 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
945 if (gimme == G_ARRAY) {
947 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
950 /* scalar context: we don't care about which values map returns
951 * (we use undef here). And so we certainly don't want to do mortal
952 * copies of meaningless values. */
953 while (items-- > 0) {
955 *dst-- = &PL_sv_undef;
959 LEAVE; /* exit inner scope */
962 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
964 (void)POPMARK; /* pop top */
965 LEAVE; /* exit outer scope */
966 (void)POPMARK; /* pop src */
967 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
968 (void)POPMARK; /* pop dst */
969 SP = PL_stack_base + POPMARK; /* pop original mark */
970 if (gimme == G_SCALAR) {
971 if (PL_op->op_private & OPpGREP_LEX) {
972 SV* sv = sv_newmortal();
981 else if (gimme == G_ARRAY)
988 ENTER; /* enter inner scope */
991 /* set $_ to the new source item */
992 src = PL_stack_base[PL_markstack_ptr[-1]];
994 if (PL_op->op_private & OPpGREP_LEX)
995 PAD_SVl(PL_op->op_targ) = src;
999 RETURNOP(cLOGOP->op_other);
1007 if (GIMME == G_ARRAY)
1009 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1010 return cLOGOP->op_other;
1019 if (GIMME == G_ARRAY) {
1020 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1024 SV *targ = PAD_SV(PL_op->op_targ);
1027 if (PL_op->op_private & OPpFLIP_LINENUM) {
1028 if (GvIO(PL_last_in_gv)) {
1029 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1032 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1033 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1039 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1040 if (PL_op->op_flags & OPf_SPECIAL) {
1048 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1057 /* This code tries to decide if "$left .. $right" should use the
1058 magical string increment, or if the range is numeric (we make
1059 an exception for .."0" [#18165]). AMS 20021031. */
1061 #define RANGE_IS_NUMERIC(left,right) ( \
1062 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1063 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1064 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1065 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1066 && (!SvOK(right) || looks_like_number(right))))
1072 if (GIMME == G_ARRAY) {
1078 if (SvGMAGICAL(left))
1080 if (SvGMAGICAL(right))
1083 if (RANGE_IS_NUMERIC(left,right)) {
1084 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1085 (SvOK(right) && SvNV(right) > IV_MAX))
1086 DIE(aTHX_ "Range iterator outside integer range");
1097 sv = sv_2mortal(newSViv(i++));
1102 SV *final = sv_mortalcopy(right);
1104 char *tmps = SvPV(final, len);
1106 sv = sv_mortalcopy(left);
1108 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1110 if (strEQ(SvPVX(sv),tmps))
1112 sv = sv_2mortal(newSVsv(sv));
1119 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1123 if (PL_op->op_private & OPpFLIP_LINENUM) {
1124 if (GvIO(PL_last_in_gv)) {
1125 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1128 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1129 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1137 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1138 sv_catpv(targ, "E0");
1148 static char *context_name[] = {
1159 S_dopoptolabel(pTHX_ char *label)
1162 register PERL_CONTEXT *cx;
1164 for (i = cxstack_ix; i >= 0; i--) {
1166 switch (CxTYPE(cx)) {
1172 if (ckWARN(WARN_EXITING))
1173 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1174 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1175 if (CxTYPE(cx) == CXt_NULL)
1179 if (!cx->blk_loop.label ||
1180 strNE(label, cx->blk_loop.label) ) {
1181 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1182 (long)i, cx->blk_loop.label));
1185 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1193 Perl_dowantarray(pTHX)
1195 I32 gimme = block_gimme();
1196 return (gimme == G_VOID) ? G_SCALAR : gimme;
1200 Perl_block_gimme(pTHX)
1204 cxix = dopoptosub(cxstack_ix);
1208 switch (cxstack[cxix].blk_gimme) {
1216 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1223 Perl_is_lvalue_sub(pTHX)
1227 cxix = dopoptosub(cxstack_ix);
1228 assert(cxix >= 0); /* We should only be called from inside subs */
1230 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1231 return cxstack[cxix].blk_sub.lval;
1237 S_dopoptosub(pTHX_ I32 startingblock)
1239 return dopoptosub_at(cxstack, startingblock);
1243 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1246 register PERL_CONTEXT *cx;
1247 for (i = startingblock; i >= 0; i--) {
1249 switch (CxTYPE(cx)) {
1255 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1263 S_dopoptoeval(pTHX_ I32 startingblock)
1266 register PERL_CONTEXT *cx;
1267 for (i = startingblock; i >= 0; i--) {
1269 switch (CxTYPE(cx)) {
1273 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1281 S_dopoptoloop(pTHX_ I32 startingblock)
1284 register PERL_CONTEXT *cx;
1285 for (i = startingblock; i >= 0; i--) {
1287 switch (CxTYPE(cx)) {
1293 if (ckWARN(WARN_EXITING))
1294 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1295 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1296 if ((CxTYPE(cx)) == CXt_NULL)
1300 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1308 Perl_dounwind(pTHX_ I32 cxix)
1310 register PERL_CONTEXT *cx;
1313 while (cxstack_ix > cxix) {
1315 cx = &cxstack[cxstack_ix];
1316 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1317 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1318 /* Note: we don't need to restore the base context info till the end. */
1319 switch (CxTYPE(cx)) {
1322 continue; /* not break */
1344 Perl_qerror(pTHX_ SV *err)
1347 sv_catsv(ERRSV, err);
1349 sv_catsv(PL_errors, err);
1351 Perl_warn(aTHX_ "%"SVf, err);
1356 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1362 register PERL_CONTEXT *cx;
1367 if (PL_in_eval & EVAL_KEEPERR) {
1368 static char prefix[] = "\t(in cleanup) ";
1373 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1376 if (*e != *message || strNE(e,message))
1380 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1381 sv_catpvn(err, prefix, sizeof(prefix)-1);
1382 sv_catpvn(err, message, msglen);
1383 if (ckWARN(WARN_MISC)) {
1384 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1385 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1390 sv_setpvn(ERRSV, message, msglen);
1394 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1395 && PL_curstackinfo->si_prev)
1404 if (cxix < cxstack_ix)
1407 POPBLOCK(cx,PL_curpm);
1408 if (CxTYPE(cx) != CXt_EVAL) {
1410 message = SvPVx(ERRSV, msglen);
1411 PerlIO_write(Perl_error_log, "panic: die ", 11);
1412 PerlIO_write(Perl_error_log, message, msglen);
1417 if (gimme == G_SCALAR)
1418 *++newsp = &PL_sv_undef;
1419 PL_stack_sp = newsp;
1423 /* LEAVE could clobber PL_curcop (see save_re_context())
1424 * XXX it might be better to find a way to avoid messing with
1425 * PL_curcop in save_re_context() instead, but this is a more
1426 * minimal fix --GSAR */
1427 PL_curcop = cx->blk_oldcop;
1429 if (optype == OP_REQUIRE) {
1430 char* msg = SvPVx(ERRSV, n_a);
1431 SV *nsv = cx->blk_eval.old_namesv;
1432 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1434 DIE(aTHX_ "%sCompilation failed in require",
1435 *msg ? msg : "Unknown error\n");
1437 return pop_return();
1441 message = SvPVx(ERRSV, msglen);
1443 write_to_stderr(message, msglen);
1452 if (SvTRUE(left) != SvTRUE(right))
1464 RETURNOP(cLOGOP->op_other);
1473 RETURNOP(cLOGOP->op_other);
1482 if (!sv || !SvANY(sv)) {
1483 RETURNOP(cLOGOP->op_other);
1486 switch (SvTYPE(sv)) {
1488 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1492 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1496 if (CvROOT(sv) || CvXSUB(sv))
1506 RETURNOP(cLOGOP->op_other);
1512 register I32 cxix = dopoptosub(cxstack_ix);
1513 register PERL_CONTEXT *cx;
1514 register PERL_CONTEXT *ccstack = cxstack;
1515 PERL_SI *top_si = PL_curstackinfo;
1526 /* we may be in a higher stacklevel, so dig down deeper */
1527 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1528 top_si = top_si->si_prev;
1529 ccstack = top_si->si_cxstack;
1530 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1533 if (GIMME != G_ARRAY) {
1539 if (PL_DBsub && cxix >= 0 &&
1540 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1544 cxix = dopoptosub_at(ccstack, cxix - 1);
1547 cx = &ccstack[cxix];
1548 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1549 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1550 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1551 field below is defined for any cx. */
1552 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1553 cx = &ccstack[dbcxix];
1556 stashname = CopSTASHPV(cx->blk_oldcop);
1557 if (GIMME != G_ARRAY) {
1560 PUSHs(&PL_sv_undef);
1563 sv_setpv(TARG, stashname);
1572 PUSHs(&PL_sv_undef);
1574 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1575 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1576 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1579 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1580 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1581 /* So is ccstack[dbcxix]. */
1584 gv_efullname3(sv, cvgv, Nullch);
1585 PUSHs(sv_2mortal(sv));
1586 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1589 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1590 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1594 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1595 PUSHs(sv_2mortal(newSViv(0)));
1597 gimme = (I32)cx->blk_gimme;
1598 if (gimme == G_VOID)
1599 PUSHs(&PL_sv_undef);
1601 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1602 if (CxTYPE(cx) == CXt_EVAL) {
1604 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1605 PUSHs(cx->blk_eval.cur_text);
1609 else if (cx->blk_eval.old_namesv) {
1610 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1613 /* eval BLOCK (try blocks have old_namesv == 0) */
1615 PUSHs(&PL_sv_undef);
1616 PUSHs(&PL_sv_undef);
1620 PUSHs(&PL_sv_undef);
1621 PUSHs(&PL_sv_undef);
1623 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1624 && CopSTASH_eq(PL_curcop, PL_debstash))
1626 AV *ary = cx->blk_sub.argarray;
1627 int off = AvARRAY(ary) - AvALLOC(ary);
1631 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1634 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1637 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1638 av_extend(PL_dbargs, AvFILLp(ary) + off);
1639 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1640 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1642 /* XXX only hints propagated via op_private are currently
1643 * visible (others are not easily accessible, since they
1644 * use the global PL_hints) */
1645 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1646 HINT_PRIVATE_MASK)));
1649 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1651 if (old_warnings == pWARN_NONE ||
1652 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1653 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1654 else if (old_warnings == pWARN_ALL ||
1655 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1656 /* Get the bit mask for $warnings::Bits{all}, because
1657 * it could have been extended by warnings::register */
1659 HV *bits = get_hv("warnings::Bits", FALSE);
1660 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1661 mask = newSVsv(*bits_all);
1664 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1668 mask = newSVsv(old_warnings);
1669 PUSHs(sv_2mortal(mask));
1684 sv_reset(tmps, CopSTASH(PL_curcop));
1694 /* like pp_nextstate, but used instead when the debugger is active */
1698 PL_curcop = (COP*)PL_op;
1699 TAINT_NOT; /* Each statement is presumed innocent */
1700 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1703 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1704 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1708 register PERL_CONTEXT *cx;
1709 I32 gimme = G_ARRAY;
1716 DIE(aTHX_ "No DB::DB routine defined");
1718 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1719 /* don't do recursive DB::DB call */
1731 push_return(PL_op->op_next);
1732 PUSHBLOCK(cx, CXt_SUB, SP);
1735 PAD_SET_CUR(CvPADLIST(cv),1);
1736 RETURNOP(CvSTART(cv));
1750 register PERL_CONTEXT *cx;
1751 I32 gimme = GIMME_V;
1753 U32 cxtype = CXt_LOOP;
1761 if (PL_op->op_targ) {
1762 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1763 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1764 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1765 SVs_PADSTALE, SVs_PADSTALE);
1767 #ifndef USE_ITHREADS
1768 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1771 SAVEPADSV(PL_op->op_targ);
1772 iterdata = INT2PTR(void*, PL_op->op_targ);
1773 cxtype |= CXp_PADVAR;
1778 svp = &GvSV(gv); /* symbol table variable */
1779 SAVEGENERICSV(*svp);
1782 iterdata = (void*)gv;
1788 PUSHBLOCK(cx, cxtype, SP);
1790 PUSHLOOP(cx, iterdata, MARK);
1792 PUSHLOOP(cx, svp, MARK);
1794 if (PL_op->op_flags & OPf_STACKED) {
1795 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1796 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1798 SV *right = (SV*)cx->blk_loop.iterary;
1799 if (RANGE_IS_NUMERIC(sv,right)) {
1800 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1801 (SvOK(right) && SvNV(right) >= IV_MAX))
1802 DIE(aTHX_ "Range iterator outside integer range");
1803 cx->blk_loop.iterix = SvIV(sv);
1804 cx->blk_loop.itermax = SvIV(right);
1808 cx->blk_loop.iterlval = newSVsv(sv);
1809 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1810 (void) SvPV(right,n_a);
1815 cx->blk_loop.iterary = PL_curstack;
1816 AvFILLp(PL_curstack) = SP - PL_stack_base;
1817 cx->blk_loop.iterix = MARK - PL_stack_base;
1826 register PERL_CONTEXT *cx;
1827 I32 gimme = GIMME_V;
1833 PUSHBLOCK(cx, CXt_LOOP, SP);
1834 PUSHLOOP(cx, 0, SP);
1842 register PERL_CONTEXT *cx;
1850 newsp = PL_stack_base + cx->blk_loop.resetsp;
1853 if (gimme == G_VOID)
1855 else if (gimme == G_SCALAR) {
1857 *++newsp = sv_mortalcopy(*SP);
1859 *++newsp = &PL_sv_undef;
1863 *++newsp = sv_mortalcopy(*++mark);
1864 TAINT_NOT; /* Each item is independent */
1870 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1871 PL_curpm = newpm; /* ... and pop $1 et al */
1883 register PERL_CONTEXT *cx;
1884 bool popsub2 = FALSE;
1885 bool clear_errsv = FALSE;
1892 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1893 if (cxstack_ix == PL_sortcxix
1894 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1896 if (cxstack_ix > PL_sortcxix)
1897 dounwind(PL_sortcxix);
1898 AvARRAY(PL_curstack)[1] = *SP;
1899 PL_stack_sp = PL_stack_base + 1;
1904 cxix = dopoptosub(cxstack_ix);
1906 DIE(aTHX_ "Can't return outside a subroutine");
1907 if (cxix < cxstack_ix)
1911 switch (CxTYPE(cx)) {
1914 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1917 if (!(PL_in_eval & EVAL_KEEPERR))
1923 if (optype == OP_REQUIRE &&
1924 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1926 /* Unassume the success we assumed earlier. */
1927 SV *nsv = cx->blk_eval.old_namesv;
1928 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1929 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1936 DIE(aTHX_ "panic: return");
1940 if (gimme == G_SCALAR) {
1943 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1945 *++newsp = SvREFCNT_inc(*SP);
1950 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1952 *++newsp = sv_mortalcopy(sv);
1957 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1960 *++newsp = sv_mortalcopy(*SP);
1963 *++newsp = &PL_sv_undef;
1965 else if (gimme == G_ARRAY) {
1966 while (++MARK <= SP) {
1967 *++newsp = (popsub2 && SvTEMP(*MARK))
1968 ? *MARK : sv_mortalcopy(*MARK);
1969 TAINT_NOT; /* Each item is independent */
1972 PL_stack_sp = newsp;
1975 /* Stack values are safe: */
1978 POPSUB(cx,sv); /* release CV and @_ ... */
1982 PL_curpm = newpm; /* ... and pop $1 et al */
1987 return pop_return();
1994 register PERL_CONTEXT *cx;
2004 if (PL_op->op_flags & OPf_SPECIAL) {
2005 cxix = dopoptoloop(cxstack_ix);
2007 DIE(aTHX_ "Can't \"last\" outside a loop block");
2010 cxix = dopoptolabel(cPVOP->op_pv);
2012 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2014 if (cxix < cxstack_ix)
2018 cxstack_ix++; /* temporarily protect top context */
2020 switch (CxTYPE(cx)) {
2023 newsp = PL_stack_base + cx->blk_loop.resetsp;
2024 nextop = cx->blk_loop.last_op->op_next;
2028 nextop = pop_return();
2032 nextop = pop_return();
2036 nextop = pop_return();
2039 DIE(aTHX_ "panic: last");
2043 if (gimme == G_SCALAR) {
2045 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2046 ? *SP : sv_mortalcopy(*SP);
2048 *++newsp = &PL_sv_undef;
2050 else if (gimme == G_ARRAY) {
2051 while (++MARK <= SP) {
2052 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2053 ? *MARK : sv_mortalcopy(*MARK);
2054 TAINT_NOT; /* Each item is independent */
2062 /* Stack values are safe: */
2065 POPLOOP(cx); /* release loop vars ... */
2069 POPSUB(cx,sv); /* release CV and @_ ... */
2072 PL_curpm = newpm; /* ... and pop $1 et al */
2081 register PERL_CONTEXT *cx;
2084 if (PL_op->op_flags & OPf_SPECIAL) {
2085 cxix = dopoptoloop(cxstack_ix);
2087 DIE(aTHX_ "Can't \"next\" outside a loop block");
2090 cxix = dopoptolabel(cPVOP->op_pv);
2092 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2094 if (cxix < cxstack_ix)
2097 /* clear off anything above the scope we're re-entering, but
2098 * save the rest until after a possible continue block */
2099 inner = PL_scopestack_ix;
2101 if (PL_scopestack_ix < inner)
2102 leave_scope(PL_scopestack[PL_scopestack_ix]);
2103 return cx->blk_loop.next_op;
2109 register PERL_CONTEXT *cx;
2112 if (PL_op->op_flags & OPf_SPECIAL) {
2113 cxix = dopoptoloop(cxstack_ix);
2115 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2118 cxix = dopoptolabel(cPVOP->op_pv);
2120 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2122 if (cxix < cxstack_ix)
2126 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2127 LEAVE_SCOPE(oldsave);
2129 return cx->blk_loop.redo_op;
2133 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2137 static char too_deep[] = "Target of goto is too deeply nested";
2140 Perl_croak(aTHX_ too_deep);
2141 if (o->op_type == OP_LEAVE ||
2142 o->op_type == OP_SCOPE ||
2143 o->op_type == OP_LEAVELOOP ||
2144 o->op_type == OP_LEAVESUB ||
2145 o->op_type == OP_LEAVETRY)
2147 *ops++ = cUNOPo->op_first;
2149 Perl_croak(aTHX_ too_deep);
2152 if (o->op_flags & OPf_KIDS) {
2153 /* First try all the kids at this level, since that's likeliest. */
2154 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2155 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2156 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2159 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2160 if (kid == PL_lastgotoprobe)
2162 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2165 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2166 ops[-1]->op_type == OP_DBSTATE)
2171 if ((o = dofindlabel(kid, label, ops, oplimit)))
2190 register PERL_CONTEXT *cx;
2191 #define GOTO_DEPTH 64
2192 OP *enterops[GOTO_DEPTH];
2194 int do_dump = (PL_op->op_type == OP_DUMP);
2195 static char must_have_label[] = "goto must have label";
2199 if (PL_op->op_flags & OPf_STACKED) {
2203 /* This egregious kludge implements goto &subroutine */
2204 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2206 register PERL_CONTEXT *cx;
2207 CV* cv = (CV*)SvRV(sv);
2213 if (!CvROOT(cv) && !CvXSUB(cv)) {
2218 /* autoloaded stub? */
2219 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2221 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2222 GvNAMELEN(gv), FALSE);
2223 if (autogv && (cv = GvCV(autogv)))
2225 tmpstr = sv_newmortal();
2226 gv_efullname3(tmpstr, gv, Nullch);
2227 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2229 DIE(aTHX_ "Goto undefined subroutine");
2232 /* First do some returnish stuff. */
2233 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2235 cxix = dopoptosub(cxstack_ix);
2237 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2238 if (cxix < cxstack_ix)
2242 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2244 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2245 /* put @_ back onto stack */
2246 AV* av = cx->blk_sub.argarray;
2248 items = AvFILLp(av) + 1;
2250 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2251 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2252 PL_stack_sp += items;
2253 SvREFCNT_dec(GvAV(PL_defgv));
2254 GvAV(PL_defgv) = cx->blk_sub.savearray;
2255 /* abandon @_ if it got reified */
2257 oldav = av; /* delay until return */
2259 av_extend(av, items-1);
2260 AvFLAGS(av) = AVf_REIFY;
2261 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2266 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2268 av = GvAV(PL_defgv);
2269 items = AvFILLp(av) + 1;
2271 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2272 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2273 PL_stack_sp += items;
2275 if (CxTYPE(cx) == CXt_SUB &&
2276 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2277 SvREFCNT_dec(cx->blk_sub.cv);
2278 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2279 LEAVE_SCOPE(oldsave);
2281 /* Now do some callish stuff. */
2283 /* For reified @_, delay freeing till return from new sub */
2285 SAVEFREESV((SV*)oldav);
2286 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2288 #ifdef PERL_XSUB_OLDSTYLE
2289 if (CvOLDSTYLE(cv)) {
2290 I32 (*fp3)(int,int,int);
2295 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2296 items = (*fp3)(CvXSUBANY(cv).any_i32,
2297 mark - PL_stack_base + 1,
2299 SP = PL_stack_base + items;
2302 #endif /* PERL_XSUB_OLDSTYLE */
2307 PL_stack_sp--; /* There is no cv arg. */
2308 /* Push a mark for the start of arglist */
2310 (void)(*CvXSUB(cv))(aTHX_ cv);
2311 /* Pop the current context like a decent sub should */
2312 POPBLOCK(cx, PL_curpm);
2313 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2316 return pop_return();
2319 AV* padlist = CvPADLIST(cv);
2320 if (CxTYPE(cx) == CXt_EVAL) {
2321 PL_in_eval = cx->blk_eval.old_in_eval;
2322 PL_eval_root = cx->blk_eval.old_eval_root;
2323 cx->cx_type = CXt_SUB;
2324 cx->blk_sub.hasargs = 0;
2326 cx->blk_sub.cv = cv;
2327 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2330 if (CvDEPTH(cv) < 2)
2331 (void)SvREFCNT_inc(cv);
2333 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2334 sub_crush_depth(cv);
2335 pad_push(padlist, CvDEPTH(cv), 1);
2337 PAD_SET_CUR(padlist, CvDEPTH(cv));
2338 if (cx->blk_sub.hasargs)
2340 AV* av = (AV*)PAD_SVl(0);
2343 cx->blk_sub.savearray = GvAV(PL_defgv);
2344 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2345 CX_CURPAD_SAVE(cx->blk_sub);
2346 cx->blk_sub.argarray = av;
2349 if (items >= AvMAX(av) + 1) {
2351 if (AvARRAY(av) != ary) {
2352 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2353 SvPVX(av) = (char*)ary;
2355 if (items >= AvMAX(av) + 1) {
2356 AvMAX(av) = items - 1;
2357 Renew(ary,items+1,SV*);
2359 SvPVX(av) = (char*)ary;
2362 Copy(mark,AvARRAY(av),items,SV*);
2363 AvFILLp(av) = items - 1;
2364 assert(!AvREAL(av));
2371 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2373 * We do not care about using sv to call CV;
2374 * it's for informational purposes only.
2376 SV *sv = GvSV(PL_DBsub);
2379 if (PERLDB_SUB_NN) {
2380 (void)SvUPGRADE(sv, SVt_PVIV);
2383 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2386 gv_efullname3(sv, CvGV(cv), Nullch);
2389 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2390 PUSHMARK( PL_stack_sp );
2391 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2395 RETURNOP(CvSTART(cv));
2399 label = SvPV(sv,n_a);
2400 if (!(do_dump || *label))
2401 DIE(aTHX_ must_have_label);
2404 else if (PL_op->op_flags & OPf_SPECIAL) {
2406 DIE(aTHX_ must_have_label);
2409 label = cPVOP->op_pv;
2411 if (label && *label) {
2413 bool leaving_eval = FALSE;
2414 bool in_block = FALSE;
2415 PERL_CONTEXT *last_eval_cx = 0;
2419 PL_lastgotoprobe = 0;
2421 for (ix = cxstack_ix; ix >= 0; ix--) {
2423 switch (CxTYPE(cx)) {
2425 leaving_eval = TRUE;
2426 if (!CxTRYBLOCK(cx)) {
2427 gotoprobe = (last_eval_cx ?
2428 last_eval_cx->blk_eval.old_eval_root :
2433 /* else fall through */
2435 gotoprobe = cx->blk_oldcop->op_sibling;
2441 gotoprobe = cx->blk_oldcop->op_sibling;
2444 gotoprobe = PL_main_root;
2447 if (CvDEPTH(cx->blk_sub.cv)) {
2448 gotoprobe = CvROOT(cx->blk_sub.cv);
2454 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2457 DIE(aTHX_ "panic: goto");
2458 gotoprobe = PL_main_root;
2462 retop = dofindlabel(gotoprobe, label,
2463 enterops, enterops + GOTO_DEPTH);
2467 PL_lastgotoprobe = gotoprobe;
2470 DIE(aTHX_ "Can't find label %s", label);
2472 /* if we're leaving an eval, check before we pop any frames
2473 that we're not going to punt, otherwise the error
2476 if (leaving_eval && *enterops && enterops[1]) {
2478 for (i = 1; enterops[i]; i++)
2479 if (enterops[i]->op_type == OP_ENTERITER)
2480 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2483 /* pop unwanted frames */
2485 if (ix < cxstack_ix) {
2492 oldsave = PL_scopestack[PL_scopestack_ix];
2493 LEAVE_SCOPE(oldsave);
2496 /* push wanted frames */
2498 if (*enterops && enterops[1]) {
2500 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2501 for (; enterops[ix]; ix++) {
2502 PL_op = enterops[ix];
2503 /* Eventually we may want to stack the needed arguments
2504 * for each op. For now, we punt on the hard ones. */
2505 if (PL_op->op_type == OP_ENTERITER)
2506 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2507 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2515 if (!retop) retop = PL_main_start;
2517 PL_restartop = retop;
2518 PL_do_undump = TRUE;
2522 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2523 PL_do_undump = FALSE;
2539 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2541 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2544 PL_exit_flags |= PERL_EXIT_EXPECTED;
2546 PUSHs(&PL_sv_undef);
2554 NV value = SvNVx(GvSV(cCOP->cop_gv));
2555 register I32 match = I_32(value);
2558 if (((NV)match) > value)
2559 --match; /* was fractional--truncate other way */
2561 match -= cCOP->uop.scop.scop_offset;
2564 else if (match > cCOP->uop.scop.scop_max)
2565 match = cCOP->uop.scop.scop_max;
2566 PL_op = cCOP->uop.scop.scop_next[match];
2576 PL_op = PL_op->op_next; /* can't assume anything */
2579 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2580 match -= cCOP->uop.scop.scop_offset;
2583 else if (match > cCOP->uop.scop.scop_max)
2584 match = cCOP->uop.scop.scop_max;
2585 PL_op = cCOP->uop.scop.scop_next[match];
2594 S_save_lines(pTHX_ AV *array, SV *sv)
2596 register char *s = SvPVX(sv);
2597 register char *send = SvPVX(sv) + SvCUR(sv);
2599 register I32 line = 1;
2601 while (s && s < send) {
2602 SV *tmpstr = NEWSV(85,0);
2604 sv_upgrade(tmpstr, SVt_PVMG);
2605 t = strchr(s, '\n');
2611 sv_setpvn(tmpstr, s, t - s);
2612 av_store(array, line++, tmpstr);
2617 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2619 S_docatch_body(pTHX_ va_list args)
2621 return docatch_body();
2626 S_docatch_body(pTHX)
2633 S_docatch(pTHX_ OP *o)
2638 volatile PERL_SI *cursi = PL_curstackinfo;
2642 assert(CATCH_GET == TRUE);
2646 /* Normally, the leavetry at the end of this block of ops will
2647 * pop an op off the return stack and continue there. By setting
2648 * the op to Nullop, we force an exit from the inner runops()
2651 retop = pop_return();
2652 push_return(Nullop);
2654 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2656 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2662 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2668 /* die caught by an inner eval - continue inner loop */
2669 if (PL_restartop && cursi == PL_curstackinfo) {
2670 PL_op = PL_restartop;
2674 /* a die in this eval - continue in outer loop */
2690 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2691 /* sv Text to convert to OP tree. */
2692 /* startop op_free() this to undo. */
2693 /* code Short string id of the caller. */
2695 dSP; /* Make POPBLOCK work. */
2698 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2702 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2703 char *tmpbuf = tbuf;
2706 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2711 /* switch to eval mode */
2713 if (IN_PERL_COMPILETIME) {
2714 SAVECOPSTASH_FREE(&PL_compiling);
2715 CopSTASH_set(&PL_compiling, PL_curstash);
2717 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2718 SV *sv = sv_newmortal();
2719 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2720 code, (unsigned long)++PL_evalseq,
2721 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2725 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2726 SAVECOPFILE_FREE(&PL_compiling);
2727 CopFILE_set(&PL_compiling, tmpbuf+2);
2728 SAVECOPLINE(&PL_compiling);
2729 CopLINE_set(&PL_compiling, 1);
2730 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2731 deleting the eval's FILEGV from the stash before gv_check() runs
2732 (i.e. before run-time proper). To work around the coredump that
2733 ensues, we always turn GvMULTI_on for any globals that were
2734 introduced within evals. See force_ident(). GSAR 96-10-12 */
2735 safestr = savepv(tmpbuf);
2736 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2738 #ifdef OP_IN_REGISTER
2744 /* we get here either during compilation, or via pp_regcomp at runtime */
2745 runtime = IN_PERL_RUNTIME;
2747 runcv = find_runcv(NULL);
2750 PL_op->op_type = OP_ENTEREVAL;
2751 PL_op->op_flags = 0; /* Avoid uninit warning. */
2752 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2753 PUSHEVAL(cx, 0, Nullgv);
2756 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2758 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2759 POPBLOCK(cx,PL_curpm);
2762 (*startop)->op_type = OP_NULL;
2763 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2765 /* XXX DAPM do this properly one year */
2766 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2768 if (IN_PERL_COMPILETIME)
2769 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2770 #ifdef OP_IN_REGISTER
2778 =for apidoc find_runcv
2780 Locate the CV corresponding to the currently executing sub or eval.
2781 If db_seqp is non_null, skip CVs that are in the DB package and populate
2782 *db_seqp with the cop sequence number at the point that the DB:: code was
2783 entered. (allows debuggers to eval in the scope of the breakpoint rather
2784 than in in the scope of the debugger itself).
2790 Perl_find_runcv(pTHX_ U32 *db_seqp)
2797 *db_seqp = PL_curcop->cop_seq;
2798 for (si = PL_curstackinfo; si; si = si->si_prev) {
2799 for (ix = si->si_cxix; ix >= 0; ix--) {
2800 cx = &(si->si_cxstack[ix]);
2801 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2802 CV *cv = cx->blk_sub.cv;
2803 /* skip DB:: code */
2804 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2805 *db_seqp = cx->blk_oldcop->cop_seq;
2810 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2818 /* Compile a require/do, an eval '', or a /(?{...})/.
2819 * In the last case, startop is non-null, and contains the address of
2820 * a pointer that should be set to the just-compiled code.
2821 * outside is the lexically enclosing CV (if any) that invoked us.
2824 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2826 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2831 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2832 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2837 SAVESPTR(PL_compcv);
2838 PL_compcv = (CV*)NEWSV(1104,0);
2839 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2840 CvEVAL_on(PL_compcv);
2841 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2842 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2844 CvOUTSIDE_SEQ(PL_compcv) = seq;
2845 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2847 /* set up a scratch pad */
2849 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2852 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2854 /* make sure we compile in the right package */
2856 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2857 SAVESPTR(PL_curstash);
2858 PL_curstash = CopSTASH(PL_curcop);
2860 SAVESPTR(PL_beginav);
2861 PL_beginav = newAV();
2862 SAVEFREESV(PL_beginav);
2863 SAVEI32(PL_error_count);
2865 /* try to compile it */
2867 PL_eval_root = Nullop;
2869 PL_curcop = &PL_compiling;
2870 PL_curcop->cop_arybase = 0;
2871 if (saveop && saveop->op_flags & OPf_SPECIAL)
2872 PL_in_eval |= EVAL_KEEPERR;
2875 if (yyparse() || PL_error_count || !PL_eval_root) {
2876 SV **newsp; /* Used by POPBLOCK. */
2877 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2878 I32 optype = 0; /* Might be reset by POPEVAL. */
2883 op_free(PL_eval_root);
2884 PL_eval_root = Nullop;
2886 SP = PL_stack_base + POPMARK; /* pop original mark */
2888 POPBLOCK(cx,PL_curpm);
2894 if (optype == OP_REQUIRE) {
2895 char* msg = SvPVx(ERRSV, n_a);
2896 SV *nsv = cx->blk_eval.old_namesv;
2897 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2899 DIE(aTHX_ "%sCompilation failed in require",
2900 *msg ? msg : "Unknown error\n");
2903 char* msg = SvPVx(ERRSV, n_a);
2905 POPBLOCK(cx,PL_curpm);
2907 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2908 (*msg ? msg : "Unknown error\n"));
2911 char* msg = SvPVx(ERRSV, n_a);
2913 sv_setpv(ERRSV, "Compilation error");
2918 CopLINE_set(&PL_compiling, 0);
2920 *startop = PL_eval_root;
2922 SAVEFREEOP(PL_eval_root);
2924 /* Set the context for this new optree.
2925 * If the last op is an OP_REQUIRE, force scalar context.
2926 * Otherwise, propagate the context from the eval(). */
2927 if (PL_eval_root->op_type == OP_LEAVEEVAL
2928 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2929 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2931 scalar(PL_eval_root);
2932 else if (gimme & G_VOID)
2933 scalarvoid(PL_eval_root);
2934 else if (gimme & G_ARRAY)
2937 scalar(PL_eval_root);
2939 DEBUG_x(dump_eval());
2941 /* Register with debugger: */
2942 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2943 CV *cv = get_cv("DB::postponed", FALSE);
2947 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2949 call_sv((SV*)cv, G_DISCARD);
2953 /* compiled okay, so do it */
2955 CvDEPTH(PL_compcv) = 1;
2956 SP = PL_stack_base + POPMARK; /* pop original mark */
2957 PL_op = saveop; /* The caller may need it. */
2958 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2960 RETURNOP(PL_eval_start);
2964 S_doopen_pm(pTHX_ const char *name, const char *mode)
2966 #ifndef PERL_DISABLE_PMC
2967 STRLEN namelen = strlen(name);
2970 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2971 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2972 char *pmc = SvPV_nolen(pmcsv);
2975 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2976 fp = PerlIO_open(name, mode);
2979 if (PerlLIO_stat(name, &pmstat) < 0 ||
2980 pmstat.st_mtime < pmcstat.st_mtime)
2982 fp = PerlIO_open(pmc, mode);
2985 fp = PerlIO_open(name, mode);
2988 SvREFCNT_dec(pmcsv);
2991 fp = PerlIO_open(name, mode);
2995 return PerlIO_open(name, mode);
2996 #endif /* !PERL_DISABLE_PMC */
3002 register PERL_CONTEXT *cx;
3006 char *tryname = Nullch;
3007 SV *namesv = Nullsv;
3009 I32 gimme = GIMME_V;
3010 PerlIO *tryrsfp = 0;
3012 int filter_has_file = 0;
3013 GV *filter_child_proc = 0;
3014 SV *filter_state = 0;
3021 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
3022 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3023 UV rev = 0, ver = 0, sver = 0;
3025 U8 *s = (U8*)SvPVX(sv);
3026 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3028 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3031 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3034 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3037 if (PERL_REVISION < rev
3038 || (PERL_REVISION == rev
3039 && (PERL_VERSION < ver
3040 || (PERL_VERSION == ver
3041 && PERL_SUBVERSION < sver))))
3043 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3044 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3045 PERL_VERSION, PERL_SUBVERSION);
3047 if (ckWARN(WARN_PORTABLE))
3048 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3049 "v-string in use/require non-portable");
3052 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3053 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3054 + ((NV)PERL_SUBVERSION/(NV)1000000)
3055 + 0.00000099 < SvNV(sv))
3059 NV nver = (nrev - rev) * 1000;
3060 UV ver = (UV)(nver + 0.0009);
3061 NV nsver = (nver - ver) * 1000;
3062 UV sver = (UV)(nsver + 0.0009);
3064 /* help out with the "use 5.6" confusion */
3065 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3066 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3067 " (did you mean v%"UVuf".%03"UVuf"?)--"
3068 "this is only v%d.%d.%d, stopped",
3069 rev, ver, sver, rev, ver/100,
3070 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3073 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3074 "this is only v%d.%d.%d, stopped",
3075 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3082 name = SvPV(sv, len);
3083 if (!(name && len > 0 && *name))
3084 DIE(aTHX_ "Null filename used");
3085 TAINT_PROPER("require");
3086 if (PL_op->op_type == OP_REQUIRE &&
3087 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3088 if (*svp != &PL_sv_undef)
3091 DIE(aTHX_ "Compilation failed in require");
3094 /* prepare to compile file */
3096 if (path_is_absolute(name)) {
3098 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3100 #ifdef MACOS_TRADITIONAL
3104 MacPerl_CanonDir(name, newname, 1);
3105 if (path_is_absolute(newname)) {
3107 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3112 AV *ar = GvAVn(PL_incgv);
3116 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3119 namesv = NEWSV(806, 0);
3120 for (i = 0; i <= AvFILL(ar); i++) {
3121 SV *dirsv = *av_fetch(ar, i, TRUE);
3127 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3128 && !sv_isobject(loader))
3130 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3133 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3134 PTR2UV(SvRV(dirsv)), name);
3135 tryname = SvPVX(namesv);
3146 if (sv_isobject(loader))
3147 count = call_method("INC", G_ARRAY);
3149 count = call_sv(loader, G_ARRAY);
3159 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3163 if (SvTYPE(arg) == SVt_PVGV) {
3164 IO *io = GvIO((GV *)arg);
3169 tryrsfp = IoIFP(io);
3170 if (IoTYPE(io) == IoTYPE_PIPE) {
3171 /* reading from a child process doesn't
3172 nest -- when returning from reading
3173 the inner module, the outer one is
3174 unreadable (closed?) I've tried to
3175 save the gv to manage the lifespan of
3176 the pipe, but this didn't help. XXX */
3177 filter_child_proc = (GV *)arg;
3178 (void)SvREFCNT_inc(filter_child_proc);
3181 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3182 PerlIO_close(IoOFP(io));
3194 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3196 (void)SvREFCNT_inc(filter_sub);
3199 filter_state = SP[i];
3200 (void)SvREFCNT_inc(filter_state);
3204 tryrsfp = PerlIO_open("/dev/null",
3220 filter_has_file = 0;
3221 if (filter_child_proc) {
3222 SvREFCNT_dec(filter_child_proc);
3223 filter_child_proc = 0;
3226 SvREFCNT_dec(filter_state);
3230 SvREFCNT_dec(filter_sub);
3235 if (!path_is_absolute(name)
3236 #ifdef MACOS_TRADITIONAL
3237 /* We consider paths of the form :a:b ambiguous and interpret them first
3238 as global then as local
3240 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3243 char *dir = SvPVx(dirsv, n_a);
3244 #ifdef MACOS_TRADITIONAL
3248 MacPerl_CanonDir(name, buf2, 1);
3249 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3253 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3255 sv_setpv(namesv, unixdir);
3256 sv_catpv(namesv, unixname);
3258 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3261 TAINT_PROPER("require");
3262 tryname = SvPVX(namesv);
3263 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3265 if (tryname[0] == '.' && tryname[1] == '/')
3274 SAVECOPFILE_FREE(&PL_compiling);
3275 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3276 SvREFCNT_dec(namesv);
3278 if (PL_op->op_type == OP_REQUIRE) {
3279 char *msgstr = name;
3280 if (namesv) { /* did we lookup @INC? */
3281 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3282 SV *dirmsgsv = NEWSV(0, 0);
3283 AV *ar = GvAVn(PL_incgv);
3285 sv_catpvn(msg, " in @INC", 8);
3286 if (instr(SvPVX(msg), ".h "))
3287 sv_catpv(msg, " (change .h to .ph maybe?)");
3288 if (instr(SvPVX(msg), ".ph "))
3289 sv_catpv(msg, " (did you run h2ph?)");
3290 sv_catpv(msg, " (@INC contains:");
3291 for (i = 0; i <= AvFILL(ar); i++) {
3292 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3293 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3294 sv_catsv(msg, dirmsgsv);
3296 sv_catpvn(msg, ")", 1);
3297 SvREFCNT_dec(dirmsgsv);
3298 msgstr = SvPV_nolen(msg);
3300 DIE(aTHX_ "Can't locate %s", msgstr);
3306 SETERRNO(0, SS_NORMAL);
3308 /* Assume success here to prevent recursive requirement. */
3310 /* Check whether a hook in @INC has already filled %INC */
3311 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3312 (void)hv_store(GvHVn(PL_incgv), name, len,
3313 (hook_sv ? SvREFCNT_inc(hook_sv)
3314 : newSVpv(CopFILE(&PL_compiling), 0)),
3320 lex_start(sv_2mortal(newSVpvn("",0)));
3321 SAVEGENERICSV(PL_rsfp_filters);
3322 PL_rsfp_filters = Nullav;
3327 SAVESPTR(PL_compiling.cop_warnings);
3328 if (PL_dowarn & G_WARN_ALL_ON)
3329 PL_compiling.cop_warnings = pWARN_ALL ;
3330 else if (PL_dowarn & G_WARN_ALL_OFF)
3331 PL_compiling.cop_warnings = pWARN_NONE ;
3332 else if (PL_taint_warn)
3333 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3335 PL_compiling.cop_warnings = pWARN_STD ;
3336 SAVESPTR(PL_compiling.cop_io);
3337 PL_compiling.cop_io = Nullsv;
3339 if (filter_sub || filter_child_proc) {
3340 SV *datasv = filter_add(run_user_filter, Nullsv);
3341 IoLINES(datasv) = filter_has_file;
3342 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3343 IoTOP_GV(datasv) = (GV *)filter_state;
3344 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3347 /* switch to eval mode */
3348 push_return(PL_op->op_next);
3349 PUSHBLOCK(cx, CXt_EVAL, SP);
3350 PUSHEVAL(cx, name, Nullgv);
3352 SAVECOPLINE(&PL_compiling);
3353 CopLINE_set(&PL_compiling, 0);
3357 /* Store and reset encoding. */
3358 encoding = PL_encoding;
3359 PL_encoding = Nullsv;
3361 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3363 /* Restore encoding. */
3364 PL_encoding = encoding;
3371 return pp_require();
3377 register PERL_CONTEXT *cx;
3379 I32 gimme = GIMME_V, was = PL_sub_generation;
3380 char tbuf[TYPE_DIGITS(long) + 12];
3381 char *tmpbuf = tbuf;
3390 TAINT_PROPER("eval");
3396 /* switch to eval mode */
3398 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3399 SV *sv = sv_newmortal();
3400 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3401 (unsigned long)++PL_evalseq,
3402 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3406 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3407 SAVECOPFILE_FREE(&PL_compiling);
3408 CopFILE_set(&PL_compiling, tmpbuf+2);
3409 SAVECOPLINE(&PL_compiling);
3410 CopLINE_set(&PL_compiling, 1);
3411 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3412 deleting the eval's FILEGV from the stash before gv_check() runs
3413 (i.e. before run-time proper). To work around the coredump that
3414 ensues, we always turn GvMULTI_on for any globals that were
3415 introduced within evals. See force_ident(). GSAR 96-10-12 */
3416 safestr = savepv(tmpbuf);
3417 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3419 PL_hints = PL_op->op_targ;
3420 SAVESPTR(PL_compiling.cop_warnings);
3421 if (specialWARN(PL_curcop->cop_warnings))
3422 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3424 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3425 SAVEFREESV(PL_compiling.cop_warnings);
3427 SAVESPTR(PL_compiling.cop_io);
3428 if (specialCopIO(PL_curcop->cop_io))
3429 PL_compiling.cop_io = PL_curcop->cop_io;
3431 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3432 SAVEFREESV(PL_compiling.cop_io);
3434 /* special case: an eval '' executed within the DB package gets lexically
3435 * placed in the first non-DB CV rather than the current CV - this
3436 * allows the debugger to execute code, find lexicals etc, in the
3437 * scope of the code being debugged. Passing &seq gets find_runcv
3438 * to do the dirty work for us */
3439 runcv = find_runcv(&seq);
3441 push_return(PL_op->op_next);
3442 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3443 PUSHEVAL(cx, 0, Nullgv);
3445 /* prepare to compile string */
3447 if (PERLDB_LINE && PL_curstash != PL_debstash)
3448 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3450 ret = doeval(gimme, NULL, runcv, seq);
3451 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3452 && ret != PL_op->op_next) { /* Successive compilation. */
3453 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3455 return DOCATCH(ret);
3465 register PERL_CONTEXT *cx;
3467 U8 save_flags = PL_op -> op_flags;
3472 retop = pop_return();
3475 if (gimme == G_VOID)
3477 else if (gimme == G_SCALAR) {
3480 if (SvFLAGS(TOPs) & SVs_TEMP)
3483 *MARK = sv_mortalcopy(TOPs);
3487 *MARK = &PL_sv_undef;
3492 /* in case LEAVE wipes old return values */
3493 for (mark = newsp + 1; mark <= SP; mark++) {
3494 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3495 *mark = sv_mortalcopy(*mark);
3496 TAINT_NOT; /* Each item is independent */
3500 PL_curpm = newpm; /* Don't pop $1 et al till now */
3503 assert(CvDEPTH(PL_compcv) == 1);
3505 CvDEPTH(PL_compcv) = 0;
3508 if (optype == OP_REQUIRE &&
3509 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3511 /* Unassume the success we assumed earlier. */
3512 SV *nsv = cx->blk_eval.old_namesv;
3513 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3514 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3515 /* die_where() did LEAVE, or we won't be here */
3519 if (!(save_flags & OPf_SPECIAL))
3529 register PERL_CONTEXT *cx;
3530 I32 gimme = GIMME_V;
3535 push_return(cLOGOP->op_other->op_next);
3536 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3539 PL_in_eval = EVAL_INEVAL;
3542 return DOCATCH(PL_op->op_next);
3553 register PERL_CONTEXT *cx;
3558 retop = pop_return();
3561 if (gimme == G_VOID)
3563 else if (gimme == G_SCALAR) {
3566 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3569 *MARK = sv_mortalcopy(TOPs);
3573 *MARK = &PL_sv_undef;
3578 /* in case LEAVE wipes old return values */
3579 for (mark = newsp + 1; mark <= SP; mark++) {
3580 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3581 *mark = sv_mortalcopy(*mark);
3582 TAINT_NOT; /* Each item is independent */
3586 PL_curpm = newpm; /* Don't pop $1 et al till now */
3594 S_doparseform(pTHX_ SV *sv)
3597 register char *s = SvPV_force(sv, len);
3598 register char *send = s + len;
3599 register char *base = Nullch;
3600 register I32 skipspaces = 0;
3601 bool noblank = FALSE;
3602 bool repeat = FALSE;
3603 bool postspace = FALSE;
3609 bool unchopnum = FALSE;
3610 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3613 Perl_croak(aTHX_ "Null picture in formline");
3615 /* estimate the buffer size needed */
3616 for (base = s; s <= send; s++) {
3617 if (*s == '\n' || *s == '@' || *s == '^')
3623 New(804, fops, maxops, U32);
3628 *fpc++ = FF_LINEMARK;
3629 noblank = repeat = FALSE;
3647 case ' ': case '\t':
3654 } /* else FALL THROUGH */
3662 *fpc++ = FF_LITERAL;
3670 *fpc++ = (U16)skipspaces;
3674 *fpc++ = FF_NEWLINE;
3678 arg = fpc - linepc + 1;
3685 *fpc++ = FF_LINEMARK;
3686 noblank = repeat = FALSE;
3695 ischop = s[-1] == '^';
3701 arg = (s - base) - 1;
3703 *fpc++ = FF_LITERAL;
3711 *fpc++ = 2; /* skip the @* or ^* */
3713 *fpc++ = FF_LINESNGL;
3716 *fpc++ = FF_LINEGLOB;
3718 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3719 arg = ischop ? 512 : 0;
3729 arg |= 256 + (s - f);
3731 *fpc++ = s - base; /* fieldsize for FETCH */
3732 *fpc++ = FF_DECIMAL;
3734 unchopnum |= ! ischop;
3736 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3737 arg = ischop ? 512 : 0;
3739 s++; /* skip the '0' first */
3748 arg |= 256 + (s - f);
3750 *fpc++ = s - base; /* fieldsize for FETCH */
3751 *fpc++ = FF_0DECIMAL;
3753 unchopnum |= ! ischop;
3757 bool ismore = FALSE;
3760 while (*++s == '>') ;
3761 prespace = FF_SPACE;
3763 else if (*s == '|') {
3764 while (*++s == '|') ;
3765 prespace = FF_HALFSPACE;
3770 while (*++s == '<') ;
3773 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3777 *fpc++ = s - base; /* fieldsize for FETCH */
3779 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3782 *fpc++ = (U16)prespace;
3796 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3798 { /* need to jump to the next word */
3800 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3801 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3802 s = SvPVX(sv) + SvCUR(sv) + z;
3804 Copy(fops, s, arg, U32);
3806 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3809 if (unchopnum && repeat)
3810 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3816 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3818 /* Can value be printed in fldsize chars, using %*.*f ? */
3822 int intsize = fldsize - (value < 0 ? 1 : 0);
3829 while (intsize--) pwr *= 10.0;
3830 while (frcsize--) eps /= 10.0;
3833 if (value + eps >= pwr)
3836 if (value - eps <= -pwr)
3843 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3845 SV *datasv = FILTER_DATA(idx);
3846 int filter_has_file = IoLINES(datasv);
3847 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3848 SV *filter_state = (SV *)IoTOP_GV(datasv);
3849 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3852 /* I was having segfault trouble under Linux 2.2.5 after a
3853 parse error occured. (Had to hack around it with a test
3854 for PL_error_count == 0.) Solaris doesn't segfault --
3855 not sure where the trouble is yet. XXX */
3857 if (filter_has_file) {
3858 len = FILTER_READ(idx+1, buf_sv, maxlen);
3861 if (filter_sub && len >= 0) {
3872 PUSHs(sv_2mortal(newSViv(maxlen)));
3874 PUSHs(filter_state);
3877 count = call_sv(filter_sub, G_SCALAR);
3893 IoLINES(datasv) = 0;
3894 if (filter_child_proc) {
3895 SvREFCNT_dec(filter_child_proc);
3896 IoFMT_GV(datasv) = Nullgv;
3899 SvREFCNT_dec(filter_state);
3900 IoTOP_GV(datasv) = Nullgv;
3903 SvREFCNT_dec(filter_sub);
3904 IoBOTTOM_GV(datasv) = Nullgv;
3906 filter_del(run_user_filter);
3912 /* perhaps someone can come up with a better name for
3913 this? it is not really "absolute", per se ... */
3915 S_path_is_absolute(pTHX_ char *name)
3917 if (PERL_FILE_IS_ABSOLUTE(name)
3918 #ifdef MACOS_TRADITIONAL
3921 || (*name == '.' && (name[1] == '/' ||
3922 (name[1] == '.' && name[2] == '/'))))