3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
21 #define PERL_IN_PP_CTL_C
25 #define WORD_ALIGN sizeof(U32)
28 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
30 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
38 cxix = dopoptosub(cxstack_ix);
42 switch (cxstack[cxix].blk_gimme) {
59 /* XXXX Should store the old value to allow for tie/overload - and
60 restore in regcomp, where marked with XXXX. */
68 register PMOP *pm = (PMOP*)cLOGOP->op_other;
72 MAGIC *mg = Null(MAGIC*);
76 /* prevent recompiling under /o and ithreads. */
77 #if defined(USE_ITHREADS)
78 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
83 SV *sv = SvRV(tmpstr);
85 mg = mg_find(sv, PERL_MAGIC_qr);
88 regexp *re = (regexp *)mg->mg_obj;
89 ReREFCNT_dec(PM_GETRE(pm));
90 PM_SETRE(pm, ReREFCNT_inc(re));
93 t = SvPV(tmpstr, len);
95 /* Check against the last compiled regexp. */
96 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
97 PM_GETRE(pm)->prelen != (I32)len ||
98 memNE(PM_GETRE(pm)->precomp, t, len))
101 ReREFCNT_dec(PM_GETRE(pm));
102 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
104 if (PL_op->op_flags & OPf_SPECIAL)
105 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
107 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
109 pm->op_pmdynflags |= PMdf_DYN_UTF8;
111 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
112 if (pm->op_pmdynflags & PMdf_UTF8)
113 t = (char*)bytes_to_utf8((U8*)t, &len);
115 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
116 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
118 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
119 inside tie/overload accessors. */
123 #ifndef INCOMPLETE_TAINTS
126 pm->op_pmdynflags |= PMdf_TAINTED;
128 pm->op_pmdynflags &= ~PMdf_TAINTED;
132 if (!PM_GETRE(pm)->prelen && PL_curpm)
134 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
135 pm->op_pmflags |= PMf_WHITE;
137 pm->op_pmflags &= ~PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
163 REGEXP *old = PM_GETRE(pm);
171 rxres_restore(&cx->sb_rxres, rx);
172 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
174 if (cx->sb_iters++) {
175 I32 saviters = cx->sb_iters;
176 if (cx->sb_iters > cx->sb_maxiters)
177 DIE(aTHX_ "Substitution loop");
179 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
180 cx->sb_rxtainted |= 2;
181 sv_catsv(dstr, POPs);
184 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
185 s == m, cx->sb_targ, NULL,
186 ((cx->sb_rflags & REXEC_COPY_STR)
187 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
188 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
190 SV *targ = cx->sb_targ;
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);
196 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
198 #ifdef PERL_COPY_ON_WRITE
200 sv_force_normal_flags(targ, SV_COW_DROP_PV);
204 (void)SvOOK_off(targ);
206 Safefree(SvPVX(targ));
208 SvPVX(targ) = SvPVX(dstr);
209 SvCUR_set(targ, SvCUR(dstr));
210 SvLEN_set(targ, SvLEN(dstr));
216 TAINT_IF(cx->sb_rxtainted & 1);
217 PUSHs(sv_2mortal(newSViv(saviters - 1)));
219 (void)SvPOK_only_UTF8(targ);
220 TAINT_IF(cx->sb_rxtainted);
224 LEAVE_SCOPE(cx->sb_oldsave);
227 RETURNOP(pm->op_next);
229 cx->sb_iters = saviters;
231 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
234 cx->sb_orig = orig = rx->subbeg;
236 cx->sb_strend = s + (cx->sb_strend - m);
238 cx->sb_m = m = rx->startp[0] + orig;
240 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
241 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
243 sv_catpvn(dstr, s, m-s);
245 cx->sb_s = rx->endp[0] + orig;
246 { /* Update the pos() information. */
247 SV *sv = cx->sb_targ;
250 if (SvTYPE(sv) < SVt_PVMG)
251 (void)SvUPGRADE(sv, SVt_PVMG);
252 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
253 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
254 mg = mg_find(sv, PERL_MAGIC_regex_global);
262 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
263 rxres_save(&cx->sb_rxres, rx);
264 RETURNOP(pm->op_pmreplstart);
268 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
273 if (!p || p[1] < rx->nparens) {
274 #ifdef PERL_COPY_ON_WRITE
275 i = 7 + rx->nparens * 2;
277 i = 6 + rx->nparens * 2;
286 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
287 RX_MATCH_COPIED_off(rx);
289 #ifdef PERL_COPY_ON_WRITE
290 *p++ = PTR2UV(rx->saved_copy);
291 rx->saved_copy = Nullsv;
296 *p++ = PTR2UV(rx->subbeg);
297 *p++ = (UV)rx->sublen;
298 for (i = 0; i <= rx->nparens; ++i) {
299 *p++ = (UV)rx->startp[i];
300 *p++ = (UV)rx->endp[i];
305 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
310 RX_MATCH_COPY_FREE(rx);
311 RX_MATCH_COPIED_set(rx, *p);
314 #ifdef PERL_COPY_ON_WRITE
316 SvREFCNT_dec (rx->saved_copy);
317 rx->saved_copy = INT2PTR(SV*,*p);
323 rx->subbeg = INT2PTR(char*,*p++);
324 rx->sublen = (I32)(*p++);
325 for (i = 0; i <= rx->nparens; ++i) {
326 rx->startp[i] = (I32)(*p++);
327 rx->endp[i] = (I32)(*p++);
332 Perl_rxres_free(pTHX_ void **rsp)
337 Safefree(INT2PTR(char*,*p));
338 #ifdef PERL_COPY_ON_WRITE
340 SvREFCNT_dec (INT2PTR(SV*,p[1]));
350 dSP; dMARK; dORIGMARK;
351 register SV *tmpForm = *++MARK;
358 register SV *sv = Nullsv;
363 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
364 char *chophere = Nullch;
365 char *linemark = Nullch;
367 bool gotsome = FALSE;
369 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
370 bool item_is_utf8 = FALSE;
371 bool targ_is_utf8 = FALSE;
374 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
375 if (SvREADONLY(tmpForm)) {
376 SvREADONLY_off(tmpForm);
377 doparseform(tmpForm);
378 SvREADONLY_on(tmpForm);
381 doparseform(tmpForm);
383 SvPV_force(PL_formtarget, len);
384 if (DO_UTF8(PL_formtarget))
386 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
388 f = SvPV(tmpForm, len);
389 /* need to jump to the next word */
390 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
399 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
400 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
401 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
402 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
403 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
405 case FF_CHECKNL: name = "CHECKNL"; break;
406 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
407 case FF_SPACE: name = "SPACE"; break;
408 case FF_HALFSPACE: name = "HALFSPACE"; break;
409 case FF_ITEM: name = "ITEM"; break;
410 case FF_CHOP: name = "CHOP"; break;
411 case FF_LINEGLOB: name = "LINEGLOB"; break;
412 case FF_NEWLINE: name = "NEWLINE"; break;
413 case FF_MORE: name = "MORE"; break;
414 case FF_LINEMARK: name = "LINEMARK"; break;
415 case FF_END: name = "END"; break;
416 case FF_0DECIMAL: name = "0DECIMAL"; break;
419 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
421 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
432 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
433 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
435 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
436 t = SvEND(PL_formtarget);
439 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
440 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
442 sv_utf8_upgrade(PL_formtarget);
443 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
444 t = SvEND(PL_formtarget);
464 if (ckWARN(WARN_SYNTAX))
465 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
470 item = s = SvPV(sv, len);
473 itemsize = sv_len_utf8(sv);
474 if (itemsize != (I32)len) {
476 if (itemsize > fieldsize) {
477 itemsize = fieldsize;
478 itembytes = itemsize;
479 sv_pos_u2b(sv, &itembytes, 0);
483 send = chophere = s + itembytes;
493 sv_pos_b2u(sv, &itemsize);
497 item_is_utf8 = FALSE;
498 if (itemsize > fieldsize)
499 itemsize = fieldsize;
500 send = chophere = s + itemsize;
512 item = s = SvPV(sv, len);
515 itemsize = sv_len_utf8(sv);
516 if (itemsize != (I32)len) {
518 if (itemsize <= fieldsize) {
519 send = chophere = s + itemsize;
530 itemsize = fieldsize;
531 itembytes = itemsize;
532 sv_pos_u2b(sv, &itembytes, 0);
533 send = chophere = s + itembytes;
534 while (s < send || (s == send && isSPACE(*s))) {
544 if (strchr(PL_chopset, *s))
549 itemsize = chophere - item;
550 sv_pos_b2u(sv, &itemsize);
556 item_is_utf8 = FALSE;
557 if (itemsize <= fieldsize) {
558 send = chophere = s + itemsize;
569 itemsize = fieldsize;
570 send = chophere = s + itemsize;
571 while (s < send || (s == send && isSPACE(*s))) {
581 if (strchr(PL_chopset, *s))
586 itemsize = chophere - item;
591 arg = fieldsize - itemsize;
600 arg = fieldsize - itemsize;
614 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
616 sv_utf8_upgrade(PL_formtarget);
617 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
618 t = SvEND(PL_formtarget);
622 if (UTF8_IS_CONTINUED(*s)) {
623 STRLEN skip = UTF8SKIP(s);
640 if ( !((*t++ = *s++) & ~31) )
646 if (targ_is_utf8 && !item_is_utf8) {
647 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
649 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
650 for (; t < SvEND(PL_formtarget); t++) {
652 int ch = *t++ = *s++;
663 int ch = *t++ = *s++;
666 if ( !((*t++ = *s++) & ~31) )
675 while (*s && isSPACE(*s))
682 item = s = SvPV(sv, len);
684 if ((item_is_utf8 = DO_UTF8(sv)))
685 itemsize = sv_len_utf8(sv);
687 bool chopped = FALSE;
700 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
702 SvUTF8_on(PL_formtarget);
703 sv_catsv(PL_formtarget, sv);
705 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
706 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
707 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
714 /* If the field is marked with ^ and the value is undefined,
717 if ((arg & 512) && !SvOK(sv)) {
725 /* Formats aren't yet marked for locales, so assume "yes". */
727 STORE_NUMERIC_STANDARD_SET_LOCAL();
728 #if defined(USE_LONG_DOUBLE)
730 sprintf(t, "%#*.*" PERL_PRIfldbl,
731 (int) fieldsize, (int) arg & 255, value);
733 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
738 (int) fieldsize, (int) arg & 255, value);
741 (int) fieldsize, value);
744 RESTORE_NUMERIC_STANDARD();
750 /* If the field is marked with ^ and the value is undefined,
753 if ((arg & 512) && !SvOK(sv)) {
761 /* Formats aren't yet marked for locales, so assume "yes". */
763 STORE_NUMERIC_STANDARD_SET_LOCAL();
764 #if defined(USE_LONG_DOUBLE)
766 sprintf(t, "%#0*.*" PERL_PRIfldbl,
767 (int) fieldsize, (int) arg & 255, value);
768 /* is this legal? I don't have long doubles */
770 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
774 sprintf(t, "%#0*.*f",
775 (int) fieldsize, (int) arg & 255, value);
778 (int) fieldsize, value);
781 RESTORE_NUMERIC_STANDARD();
788 while (t-- > linemark && *t == ' ') ;
796 if (arg) { /* repeat until fields exhausted? */
798 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
799 lines += FmLINES(PL_formtarget);
802 if (strnEQ(linemark, linemark - arg, arg))
803 DIE(aTHX_ "Runaway format");
806 SvUTF8_on(PL_formtarget);
807 FmLINES(PL_formtarget) = lines;
809 RETURNOP(cLISTOP->op_first);
822 while (*s && isSPACE(*s) && s < send)
826 arg = fieldsize - itemsize;
833 if (strnEQ(s," ",3)) {
834 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
845 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
847 SvUTF8_on(PL_formtarget);
848 FmLINES(PL_formtarget) += lines;
860 if (PL_stack_base + *PL_markstack_ptr == SP) {
862 if (GIMME_V == G_SCALAR)
863 XPUSHs(sv_2mortal(newSViv(0)));
864 RETURNOP(PL_op->op_next->op_next);
866 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
867 pp_pushmark(); /* push dst */
868 pp_pushmark(); /* push src */
869 ENTER; /* enter outer scope */
872 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
874 ENTER; /* enter inner scope */
877 src = PL_stack_base[*PL_markstack_ptr];
882 if (PL_op->op_type == OP_MAPSTART)
883 pp_pushmark(); /* push top */
884 return ((LOGOP*)PL_op->op_next)->op_other;
889 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
895 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
901 /* first, move source pointer to the next item in the source list */
902 ++PL_markstack_ptr[-1];
904 /* if there are new items, push them into the destination list */
906 /* might need to make room back there first */
907 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
908 /* XXX this implementation is very pessimal because the stack
909 * is repeatedly extended for every set of items. Is possible
910 * to do this without any stack extension or copying at all
911 * by maintaining a separate list over which the map iterates
912 * (like foreach does). --gsar */
914 /* everything in the stack after the destination list moves
915 * towards the end the stack by the amount of room needed */
916 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
918 /* items to shift up (accounting for the moved source pointer) */
919 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
921 /* This optimization is by Ben Tilly and it does
922 * things differently from what Sarathy (gsar)
923 * is describing. The downside of this optimization is
924 * that leaves "holes" (uninitialized and hopefully unused areas)
925 * to the Perl stack, but on the other hand this
926 * shouldn't be a problem. If Sarathy's idea gets
927 * implemented, this optimization should become
928 * irrelevant. --jhi */
930 shift = count; /* Avoid shifting too often --Ben Tilly */
935 PL_markstack_ptr[-1] += shift;
936 *PL_markstack_ptr += shift;
940 /* copy the new items down to the destination list */
941 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
943 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
945 LEAVE; /* exit inner scope */
948 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
951 (void)POPMARK; /* pop top */
952 LEAVE; /* exit outer scope */
953 (void)POPMARK; /* pop src */
954 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
955 (void)POPMARK; /* pop dst */
956 SP = PL_stack_base + POPMARK; /* pop original mark */
957 if (gimme == G_SCALAR) {
961 else if (gimme == G_ARRAY)
968 ENTER; /* enter inner scope */
971 /* set $_ to the new source item */
972 src = PL_stack_base[PL_markstack_ptr[-1]];
976 RETURNOP(cLOGOP->op_other);
984 if (GIMME == G_ARRAY)
986 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
987 return cLOGOP->op_other;
996 if (GIMME == G_ARRAY) {
997 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1001 SV *targ = PAD_SV(PL_op->op_targ);
1004 if (PL_op->op_private & OPpFLIP_LINENUM) {
1005 if (GvIO(PL_last_in_gv)) {
1006 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1009 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1010 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1016 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1017 if (PL_op->op_flags & OPf_SPECIAL) {
1025 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1038 if (GIMME == G_ARRAY) {
1044 if (SvGMAGICAL(left))
1046 if (SvGMAGICAL(right))
1049 /* This code tries to decide if "$left .. $right" should use the
1050 magical string increment, or if the range is numeric (we make
1051 an exception for .."0" [#18165]). AMS 20021031. */
1053 if (SvNIOKp(left) || !SvPOKp(left) ||
1054 SvNIOKp(right) || !SvPOKp(right) ||
1055 (looks_like_number(left) && *SvPVX(left) != '0' &&
1056 looks_like_number(right)))
1058 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1059 DIE(aTHX_ "Range iterator outside integer range");
1070 sv = sv_2mortal(newSViv(i++));
1075 SV *final = sv_mortalcopy(right);
1077 char *tmps = SvPV(final, len);
1079 sv = sv_mortalcopy(left);
1081 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1083 if (strEQ(SvPVX(sv),tmps))
1085 sv = sv_2mortal(newSVsv(sv));
1092 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1096 if (PL_op->op_private & OPpFLIP_LINENUM) {
1097 if (GvIO(PL_last_in_gv)) {
1098 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1101 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1102 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1110 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1111 sv_catpv(targ, "E0");
1121 static char *context_name[] = {
1132 S_dopoptolabel(pTHX_ char *label)
1135 register PERL_CONTEXT *cx;
1137 for (i = cxstack_ix; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1145 if (ckWARN(WARN_EXITING))
1146 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1147 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1148 if (CxTYPE(cx) == CXt_NULL)
1152 if (!cx->blk_loop.label ||
1153 strNE(label, cx->blk_loop.label) ) {
1154 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1155 (long)i, cx->blk_loop.label));
1158 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1166 Perl_dowantarray(pTHX)
1168 I32 gimme = block_gimme();
1169 return (gimme == G_VOID) ? G_SCALAR : gimme;
1173 Perl_block_gimme(pTHX)
1177 cxix = dopoptosub(cxstack_ix);
1181 switch (cxstack[cxix].blk_gimme) {
1189 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1196 Perl_is_lvalue_sub(pTHX)
1200 cxix = dopoptosub(cxstack_ix);
1201 assert(cxix >= 0); /* We should only be called from inside subs */
1203 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1204 return cxstack[cxix].blk_sub.lval;
1210 S_dopoptosub(pTHX_ I32 startingblock)
1212 return dopoptosub_at(cxstack, startingblock);
1216 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1219 register PERL_CONTEXT *cx;
1220 for (i = startingblock; i >= 0; i--) {
1222 switch (CxTYPE(cx)) {
1228 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1236 S_dopoptoeval(pTHX_ I32 startingblock)
1239 register PERL_CONTEXT *cx;
1240 for (i = startingblock; i >= 0; i--) {
1242 switch (CxTYPE(cx)) {
1246 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1254 S_dopoptoloop(pTHX_ I32 startingblock)
1257 register PERL_CONTEXT *cx;
1258 for (i = startingblock; i >= 0; i--) {
1260 switch (CxTYPE(cx)) {
1266 if (ckWARN(WARN_EXITING))
1267 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1268 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1269 if ((CxTYPE(cx)) == CXt_NULL)
1273 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1281 Perl_dounwind(pTHX_ I32 cxix)
1283 register PERL_CONTEXT *cx;
1286 while (cxstack_ix > cxix) {
1288 cx = &cxstack[cxstack_ix];
1289 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1290 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1291 /* Note: we don't need to restore the base context info till the end. */
1292 switch (CxTYPE(cx)) {
1295 continue; /* not break */
1317 Perl_qerror(pTHX_ SV *err)
1320 sv_catsv(ERRSV, err);
1322 sv_catsv(PL_errors, err);
1324 Perl_warn(aTHX_ "%"SVf, err);
1329 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1335 register PERL_CONTEXT *cx;
1340 if (PL_in_eval & EVAL_KEEPERR) {
1341 static char prefix[] = "\t(in cleanup) ";
1346 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1349 if (*e != *message || strNE(e,message))
1353 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1354 sv_catpvn(err, prefix, sizeof(prefix)-1);
1355 sv_catpvn(err, message, msglen);
1356 if (ckWARN(WARN_MISC)) {
1357 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1358 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1363 sv_setpvn(ERRSV, message, msglen);
1367 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1368 && PL_curstackinfo->si_prev)
1377 if (cxix < cxstack_ix)
1380 POPBLOCK(cx,PL_curpm);
1381 if (CxTYPE(cx) != CXt_EVAL) {
1383 message = SvPVx(ERRSV, msglen);
1384 PerlIO_write(Perl_error_log, "panic: die ", 11);
1385 PerlIO_write(Perl_error_log, message, msglen);
1390 if (gimme == G_SCALAR)
1391 *++newsp = &PL_sv_undef;
1392 PL_stack_sp = newsp;
1396 /* LEAVE could clobber PL_curcop (see save_re_context())
1397 * XXX it might be better to find a way to avoid messing with
1398 * PL_curcop in save_re_context() instead, but this is a more
1399 * minimal fix --GSAR */
1400 PL_curcop = cx->blk_oldcop;
1402 if (optype == OP_REQUIRE) {
1403 char* msg = SvPVx(ERRSV, n_a);
1404 DIE(aTHX_ "%sCompilation failed in require",
1405 *msg ? msg : "Unknown error\n");
1407 return pop_return();
1411 message = SvPVx(ERRSV, msglen);
1413 write_to_stderr(message, msglen);
1422 if (SvTRUE(left) != SvTRUE(right))
1434 RETURNOP(cLOGOP->op_other);
1443 RETURNOP(cLOGOP->op_other);
1452 if (!sv || !SvANY(sv)) {
1453 RETURNOP(cLOGOP->op_other);
1456 switch (SvTYPE(sv)) {
1458 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1462 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1466 if (CvROOT(sv) || CvXSUB(sv))
1476 RETURNOP(cLOGOP->op_other);
1482 register I32 cxix = dopoptosub(cxstack_ix);
1483 register PERL_CONTEXT *cx;
1484 register PERL_CONTEXT *ccstack = cxstack;
1485 PERL_SI *top_si = PL_curstackinfo;
1496 /* we may be in a higher stacklevel, so dig down deeper */
1497 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1498 top_si = top_si->si_prev;
1499 ccstack = top_si->si_cxstack;
1500 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1503 if (GIMME != G_ARRAY) {
1509 if (PL_DBsub && cxix >= 0 &&
1510 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1514 cxix = dopoptosub_at(ccstack, cxix - 1);
1517 cx = &ccstack[cxix];
1518 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1519 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1520 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1521 field below is defined for any cx. */
1522 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1523 cx = &ccstack[dbcxix];
1526 stashname = CopSTASHPV(cx->blk_oldcop);
1527 if (GIMME != G_ARRAY) {
1530 PUSHs(&PL_sv_undef);
1533 sv_setpv(TARG, stashname);
1542 PUSHs(&PL_sv_undef);
1544 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1545 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1546 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1549 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1550 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1551 /* So is ccstack[dbcxix]. */
1554 gv_efullname3(sv, cvgv, Nullch);
1555 PUSHs(sv_2mortal(sv));
1556 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1559 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1560 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1564 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1565 PUSHs(sv_2mortal(newSViv(0)));
1567 gimme = (I32)cx->blk_gimme;
1568 if (gimme == G_VOID)
1569 PUSHs(&PL_sv_undef);
1571 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1572 if (CxTYPE(cx) == CXt_EVAL) {
1574 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1575 PUSHs(cx->blk_eval.cur_text);
1579 else if (cx->blk_eval.old_namesv) {
1580 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1583 /* eval BLOCK (try blocks have old_namesv == 0) */
1585 PUSHs(&PL_sv_undef);
1586 PUSHs(&PL_sv_undef);
1590 PUSHs(&PL_sv_undef);
1591 PUSHs(&PL_sv_undef);
1593 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1594 && CopSTASH_eq(PL_curcop, PL_debstash))
1596 AV *ary = cx->blk_sub.argarray;
1597 int off = AvARRAY(ary) - AvALLOC(ary);
1601 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1604 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1607 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1608 av_extend(PL_dbargs, AvFILLp(ary) + off);
1609 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1610 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1612 /* XXX only hints propagated via op_private are currently
1613 * visible (others are not easily accessible, since they
1614 * use the global PL_hints) */
1615 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1616 HINT_PRIVATE_MASK)));
1619 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1621 if (old_warnings == pWARN_NONE ||
1622 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1623 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1624 else if (old_warnings == pWARN_ALL ||
1625 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1626 /* Get the bit mask for $warnings::Bits{all}, because
1627 * it could have been extended by warnings::register */
1629 HV *bits = get_hv("warnings::Bits", FALSE);
1630 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1631 mask = newSVsv(*bits_all);
1634 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1638 mask = newSVsv(old_warnings);
1639 PUSHs(sv_2mortal(mask));
1654 sv_reset(tmps, CopSTASH(PL_curcop));
1664 /* like pp_nextstate, but used instead when the debugger is active */
1668 PL_curcop = (COP*)PL_op;
1669 TAINT_NOT; /* Each statement is presumed innocent */
1670 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1673 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1674 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1678 register PERL_CONTEXT *cx;
1679 I32 gimme = G_ARRAY;
1686 DIE(aTHX_ "No DB::DB routine defined");
1688 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1689 /* don't do recursive DB::DB call */
1701 push_return(PL_op->op_next);
1702 PUSHBLOCK(cx, CXt_SUB, SP);
1705 (void)SvREFCNT_inc(cv);
1706 PAD_SET_CUR(CvPADLIST(cv),1);
1707 RETURNOP(CvSTART(cv));
1721 register PERL_CONTEXT *cx;
1722 I32 gimme = GIMME_V;
1724 U32 cxtype = CXt_LOOP;
1732 if (PL_op->op_targ) {
1733 #ifndef USE_ITHREADS
1734 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1737 SAVEPADSV(PL_op->op_targ);
1738 iterdata = INT2PTR(void*, PL_op->op_targ);
1739 cxtype |= CXp_PADVAR;
1744 svp = &GvSV(gv); /* symbol table variable */
1745 SAVEGENERICSV(*svp);
1748 iterdata = (void*)gv;
1754 PUSHBLOCK(cx, cxtype, SP);
1756 PUSHLOOP(cx, iterdata, MARK);
1758 PUSHLOOP(cx, svp, MARK);
1760 if (PL_op->op_flags & OPf_STACKED) {
1761 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1762 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1764 /* See comment in pp_flop() */
1765 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1766 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1767 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1768 looks_like_number((SV*)cx->blk_loop.iterary)))
1770 if (SvNV(sv) < IV_MIN ||
1771 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1772 DIE(aTHX_ "Range iterator outside integer range");
1773 cx->blk_loop.iterix = SvIV(sv);
1774 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1777 cx->blk_loop.iterlval = newSVsv(sv);
1781 cx->blk_loop.iterary = PL_curstack;
1782 AvFILLp(PL_curstack) = SP - PL_stack_base;
1783 cx->blk_loop.iterix = MARK - PL_stack_base;
1792 register PERL_CONTEXT *cx;
1793 I32 gimme = GIMME_V;
1799 PUSHBLOCK(cx, CXt_LOOP, SP);
1800 PUSHLOOP(cx, 0, SP);
1808 register PERL_CONTEXT *cx;
1816 newsp = PL_stack_base + cx->blk_loop.resetsp;
1819 if (gimme == G_VOID)
1821 else if (gimme == G_SCALAR) {
1823 *++newsp = sv_mortalcopy(*SP);
1825 *++newsp = &PL_sv_undef;
1829 *++newsp = sv_mortalcopy(*++mark);
1830 TAINT_NOT; /* Each item is independent */
1836 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1837 PL_curpm = newpm; /* ... and pop $1 et al */
1849 register PERL_CONTEXT *cx;
1850 bool popsub2 = FALSE;
1851 bool clear_errsv = FALSE;
1858 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1859 if (cxstack_ix == PL_sortcxix
1860 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1862 if (cxstack_ix > PL_sortcxix)
1863 dounwind(PL_sortcxix);
1864 AvARRAY(PL_curstack)[1] = *SP;
1865 PL_stack_sp = PL_stack_base + 1;
1870 cxix = dopoptosub(cxstack_ix);
1872 DIE(aTHX_ "Can't return outside a subroutine");
1873 if (cxix < cxstack_ix)
1877 switch (CxTYPE(cx)) {
1882 if (!(PL_in_eval & EVAL_KEEPERR))
1888 if (optype == OP_REQUIRE &&
1889 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1891 /* Unassume the success we assumed earlier. */
1892 SV *nsv = cx->blk_eval.old_namesv;
1893 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1894 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1901 DIE(aTHX_ "panic: return");
1905 if (gimme == G_SCALAR) {
1908 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1910 *++newsp = SvREFCNT_inc(*SP);
1915 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1917 *++newsp = sv_mortalcopy(sv);
1922 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1925 *++newsp = sv_mortalcopy(*SP);
1928 *++newsp = &PL_sv_undef;
1930 else if (gimme == G_ARRAY) {
1931 while (++MARK <= SP) {
1932 *++newsp = (popsub2 && SvTEMP(*MARK))
1933 ? *MARK : sv_mortalcopy(*MARK);
1934 TAINT_NOT; /* Each item is independent */
1937 PL_stack_sp = newsp;
1940 /* Stack values are safe: */
1942 POPSUB(cx,sv); /* release CV and @_ ... */
1946 PL_curpm = newpm; /* ... and pop $1 et al */
1951 return pop_return();
1958 register PERL_CONTEXT *cx;
1968 if (PL_op->op_flags & OPf_SPECIAL) {
1969 cxix = dopoptoloop(cxstack_ix);
1971 DIE(aTHX_ "Can't \"last\" outside a loop block");
1974 cxix = dopoptolabel(cPVOP->op_pv);
1976 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1978 if (cxix < cxstack_ix)
1983 switch (CxTYPE(cx)) {
1986 newsp = PL_stack_base + cx->blk_loop.resetsp;
1987 nextop = cx->blk_loop.last_op->op_next;
1991 nextop = pop_return();
1995 nextop = pop_return();
1999 nextop = pop_return();
2002 DIE(aTHX_ "panic: last");
2006 if (gimme == G_SCALAR) {
2008 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2009 ? *SP : sv_mortalcopy(*SP);
2011 *++newsp = &PL_sv_undef;
2013 else if (gimme == G_ARRAY) {
2014 while (++MARK <= SP) {
2015 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2016 ? *MARK : sv_mortalcopy(*MARK);
2017 TAINT_NOT; /* Each item is independent */
2024 /* Stack values are safe: */
2027 POPLOOP(cx); /* release loop vars ... */
2031 POPSUB(cx,sv); /* release CV and @_ ... */
2034 PL_curpm = newpm; /* ... and pop $1 et al */
2043 register PERL_CONTEXT *cx;
2046 if (PL_op->op_flags & OPf_SPECIAL) {
2047 cxix = dopoptoloop(cxstack_ix);
2049 DIE(aTHX_ "Can't \"next\" outside a loop block");
2052 cxix = dopoptolabel(cPVOP->op_pv);
2054 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2056 if (cxix < cxstack_ix)
2059 /* clear off anything above the scope we're re-entering, but
2060 * save the rest until after a possible continue block */
2061 inner = PL_scopestack_ix;
2063 if (PL_scopestack_ix < inner)
2064 leave_scope(PL_scopestack[PL_scopestack_ix]);
2065 return cx->blk_loop.next_op;
2071 register PERL_CONTEXT *cx;
2074 if (PL_op->op_flags & OPf_SPECIAL) {
2075 cxix = dopoptoloop(cxstack_ix);
2077 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2080 cxix = dopoptolabel(cPVOP->op_pv);
2082 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2084 if (cxix < cxstack_ix)
2088 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2089 LEAVE_SCOPE(oldsave);
2090 return cx->blk_loop.redo_op;
2094 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2098 static char too_deep[] = "Target of goto is too deeply nested";
2101 Perl_croak(aTHX_ too_deep);
2102 if (o->op_type == OP_LEAVE ||
2103 o->op_type == OP_SCOPE ||
2104 o->op_type == OP_LEAVELOOP ||
2105 o->op_type == OP_LEAVESUB ||
2106 o->op_type == OP_LEAVETRY)
2108 *ops++ = cUNOPo->op_first;
2110 Perl_croak(aTHX_ too_deep);
2113 if (o->op_flags & OPf_KIDS) {
2114 /* First try all the kids at this level, since that's likeliest. */
2115 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2116 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2117 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2120 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2121 if (kid == PL_lastgotoprobe)
2123 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2126 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2127 ops[-1]->op_type == OP_DBSTATE)
2132 if ((o = dofindlabel(kid, label, ops, oplimit)))
2151 register PERL_CONTEXT *cx;
2152 #define GOTO_DEPTH 64
2153 OP *enterops[GOTO_DEPTH];
2155 int do_dump = (PL_op->op_type == OP_DUMP);
2156 static char must_have_label[] = "goto must have label";
2159 if (PL_op->op_flags & OPf_STACKED) {
2163 /* This egregious kludge implements goto &subroutine */
2164 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2166 register PERL_CONTEXT *cx;
2167 CV* cv = (CV*)SvRV(sv);
2173 if (!CvROOT(cv) && !CvXSUB(cv)) {
2178 /* autoloaded stub? */
2179 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2181 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2182 GvNAMELEN(gv), FALSE);
2183 if (autogv && (cv = GvCV(autogv)))
2185 tmpstr = sv_newmortal();
2186 gv_efullname3(tmpstr, gv, Nullch);
2187 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2189 DIE(aTHX_ "Goto undefined subroutine");
2192 /* First do some returnish stuff. */
2193 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2195 cxix = dopoptosub(cxstack_ix);
2197 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2198 if (cxix < cxstack_ix)
2202 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2204 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2205 /* put @_ back onto stack */
2206 AV* av = cx->blk_sub.argarray;
2208 items = AvFILLp(av) + 1;
2210 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2211 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2212 PL_stack_sp += items;
2213 SvREFCNT_dec(GvAV(PL_defgv));
2214 GvAV(PL_defgv) = cx->blk_sub.savearray;
2215 /* abandon @_ if it got reified */
2217 (void)sv_2mortal((SV*)av); /* delay until return */
2219 av_extend(av, items-1);
2220 AvFLAGS(av) = AVf_REIFY;
2221 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2226 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2228 av = GvAV(PL_defgv);
2229 items = AvFILLp(av) + 1;
2231 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2232 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2233 PL_stack_sp += items;
2235 if (CxTYPE(cx) == CXt_SUB &&
2236 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2237 SvREFCNT_dec(cx->blk_sub.cv);
2238 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2239 LEAVE_SCOPE(oldsave);
2241 /* Now do some callish stuff. */
2243 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2245 #ifdef PERL_XSUB_OLDSTYLE
2246 if (CvOLDSTYLE(cv)) {
2247 I32 (*fp3)(int,int,int);
2252 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2253 items = (*fp3)(CvXSUBANY(cv).any_i32,
2254 mark - PL_stack_base + 1,
2256 SP = PL_stack_base + items;
2259 #endif /* PERL_XSUB_OLDSTYLE */
2264 PL_stack_sp--; /* There is no cv arg. */
2265 /* Push a mark for the start of arglist */
2267 (void)(*CvXSUB(cv))(aTHX_ cv);
2268 /* Pop the current context like a decent sub should */
2269 POPBLOCK(cx, PL_curpm);
2270 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2273 return pop_return();
2276 AV* padlist = CvPADLIST(cv);
2277 if (CxTYPE(cx) == CXt_EVAL) {
2278 PL_in_eval = cx->blk_eval.old_in_eval;
2279 PL_eval_root = cx->blk_eval.old_eval_root;
2280 cx->cx_type = CXt_SUB;
2281 cx->blk_sub.hasargs = 0;
2283 cx->blk_sub.cv = cv;
2284 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2287 if (CvDEPTH(cv) < 2)
2288 (void)SvREFCNT_inc(cv);
2290 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2291 sub_crush_depth(cv);
2292 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2294 PAD_SET_CUR(padlist, CvDEPTH(cv));
2295 if (cx->blk_sub.hasargs)
2297 AV* av = (AV*)PAD_SVl(0);
2300 cx->blk_sub.savearray = GvAV(PL_defgv);
2301 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2302 CX_CURPAD_SAVE(cx->blk_sub);
2303 cx->blk_sub.argarray = av;
2306 if (items >= AvMAX(av) + 1) {
2308 if (AvARRAY(av) != ary) {
2309 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2310 SvPVX(av) = (char*)ary;
2312 if (items >= AvMAX(av) + 1) {
2313 AvMAX(av) = items - 1;
2314 Renew(ary,items+1,SV*);
2316 SvPVX(av) = (char*)ary;
2319 Copy(mark,AvARRAY(av),items,SV*);
2320 AvFILLp(av) = items - 1;
2321 assert(!AvREAL(av));
2328 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2330 * We do not care about using sv to call CV;
2331 * it's for informational purposes only.
2333 SV *sv = GvSV(PL_DBsub);
2336 if (PERLDB_SUB_NN) {
2337 (void)SvUPGRADE(sv, SVt_PVIV);
2340 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2343 gv_efullname3(sv, CvGV(cv), Nullch);
2346 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2347 PUSHMARK( PL_stack_sp );
2348 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2352 RETURNOP(CvSTART(cv));
2356 label = SvPV(sv,n_a);
2357 if (!(do_dump || *label))
2358 DIE(aTHX_ must_have_label);
2361 else if (PL_op->op_flags & OPf_SPECIAL) {
2363 DIE(aTHX_ must_have_label);
2366 label = cPVOP->op_pv;
2368 if (label && *label) {
2370 bool leaving_eval = FALSE;
2371 bool in_block = FALSE;
2372 PERL_CONTEXT *last_eval_cx = 0;
2376 PL_lastgotoprobe = 0;
2378 for (ix = cxstack_ix; ix >= 0; ix--) {
2380 switch (CxTYPE(cx)) {
2382 leaving_eval = TRUE;
2383 if (!CxTRYBLOCK(cx)) {
2384 gotoprobe = (last_eval_cx ?
2385 last_eval_cx->blk_eval.old_eval_root :
2390 /* else fall through */
2392 gotoprobe = cx->blk_oldcop->op_sibling;
2398 gotoprobe = cx->blk_oldcop->op_sibling;
2401 gotoprobe = PL_main_root;
2404 if (CvDEPTH(cx->blk_sub.cv)) {
2405 gotoprobe = CvROOT(cx->blk_sub.cv);
2411 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2414 DIE(aTHX_ "panic: goto");
2415 gotoprobe = PL_main_root;
2419 retop = dofindlabel(gotoprobe, label,
2420 enterops, enterops + GOTO_DEPTH);
2424 PL_lastgotoprobe = gotoprobe;
2427 DIE(aTHX_ "Can't find label %s", label);
2429 /* if we're leaving an eval, check before we pop any frames
2430 that we're not going to punt, otherwise the error
2433 if (leaving_eval && *enterops && enterops[1]) {
2435 for (i = 1; enterops[i]; i++)
2436 if (enterops[i]->op_type == OP_ENTERITER)
2437 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2440 /* pop unwanted frames */
2442 if (ix < cxstack_ix) {
2449 oldsave = PL_scopestack[PL_scopestack_ix];
2450 LEAVE_SCOPE(oldsave);
2453 /* push wanted frames */
2455 if (*enterops && enterops[1]) {
2457 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2458 for (; enterops[ix]; ix++) {
2459 PL_op = enterops[ix];
2460 /* Eventually we may want to stack the needed arguments
2461 * for each op. For now, we punt on the hard ones. */
2462 if (PL_op->op_type == OP_ENTERITER)
2463 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2464 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2472 if (!retop) retop = PL_main_start;
2474 PL_restartop = retop;
2475 PL_do_undump = TRUE;
2479 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2480 PL_do_undump = FALSE;
2496 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2498 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2501 PL_exit_flags |= PERL_EXIT_EXPECTED;
2503 PUSHs(&PL_sv_undef);
2511 NV value = SvNVx(GvSV(cCOP->cop_gv));
2512 register I32 match = I_32(value);
2515 if (((NV)match) > value)
2516 --match; /* was fractional--truncate other way */
2518 match -= cCOP->uop.scop.scop_offset;
2521 else if (match > cCOP->uop.scop.scop_max)
2522 match = cCOP->uop.scop.scop_max;
2523 PL_op = cCOP->uop.scop.scop_next[match];
2533 PL_op = PL_op->op_next; /* can't assume anything */
2536 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2537 match -= cCOP->uop.scop.scop_offset;
2540 else if (match > cCOP->uop.scop.scop_max)
2541 match = cCOP->uop.scop.scop_max;
2542 PL_op = cCOP->uop.scop.scop_next[match];
2551 S_save_lines(pTHX_ AV *array, SV *sv)
2553 register char *s = SvPVX(sv);
2554 register char *send = SvPVX(sv) + SvCUR(sv);
2556 register I32 line = 1;
2558 while (s && s < send) {
2559 SV *tmpstr = NEWSV(85,0);
2561 sv_upgrade(tmpstr, SVt_PVMG);
2562 t = strchr(s, '\n');
2568 sv_setpvn(tmpstr, s, t - s);
2569 av_store(array, line++, tmpstr);
2574 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2576 S_docatch_body(pTHX_ va_list args)
2578 return docatch_body();
2583 S_docatch_body(pTHX)
2590 S_docatch(pTHX_ OP *o)
2595 volatile PERL_SI *cursi = PL_curstackinfo;
2599 assert(CATCH_GET == TRUE);
2603 /* Normally, the leavetry at the end of this block of ops will
2604 * pop an op off the return stack and continue there. By setting
2605 * the op to Nullop, we force an exit from the inner runops()
2608 retop = pop_return();
2609 push_return(Nullop);
2611 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2613 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2619 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2625 /* die caught by an inner eval - continue inner loop */
2626 if (PL_restartop && cursi == PL_curstackinfo) {
2627 PL_op = PL_restartop;
2631 /* a die in this eval - continue in outer loop */
2647 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2648 /* sv Text to convert to OP tree. */
2649 /* startop op_free() this to undo. */
2650 /* code Short string id of the caller. */
2652 dSP; /* Make POPBLOCK work. */
2655 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2659 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2660 char *tmpbuf = tbuf;
2663 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2668 /* switch to eval mode */
2670 if (PL_curcop == &PL_compiling) {
2671 SAVECOPSTASH_FREE(&PL_compiling);
2672 CopSTASH_set(&PL_compiling, PL_curstash);
2674 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2675 SV *sv = sv_newmortal();
2676 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2677 code, (unsigned long)++PL_evalseq,
2678 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2682 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2683 SAVECOPFILE_FREE(&PL_compiling);
2684 CopFILE_set(&PL_compiling, tmpbuf+2);
2685 SAVECOPLINE(&PL_compiling);
2686 CopLINE_set(&PL_compiling, 1);
2687 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2688 deleting the eval's FILEGV from the stash before gv_check() runs
2689 (i.e. before run-time proper). To work around the coredump that
2690 ensues, we always turn GvMULTI_on for any globals that were
2691 introduced within evals. See force_ident(). GSAR 96-10-12 */
2692 safestr = savepv(tmpbuf);
2693 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2695 #ifdef OP_IN_REGISTER
2700 PL_hints &= HINT_UTF8;
2702 /* we get here either during compilation, or via pp_regcomp at runtime */
2703 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2705 runcv = find_runcv(NULL);
2708 PL_op->op_type = OP_ENTEREVAL;
2709 PL_op->op_flags = 0; /* Avoid uninit warning. */
2710 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2711 PUSHEVAL(cx, 0, Nullgv);
2714 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2716 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2717 POPBLOCK(cx,PL_curpm);
2720 (*startop)->op_type = OP_NULL;
2721 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2723 /* XXX DAPM do this properly one year */
2724 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2726 if (PL_curcop == &PL_compiling)
2727 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2728 #ifdef OP_IN_REGISTER
2736 =for apidoc find_runcv
2738 Locate the CV corresponding to the currently executing sub or eval.
2739 If db_seqp is non_null, skip CVs that are in the DB package and populate
2740 *db_seqp with the cop sequence number at the point that the DB:: code was
2741 entered. (allows debuggers to eval in the scope of the breakpoint rather
2742 than in in the scope of the debuger itself).
2748 Perl_find_runcv(pTHX_ U32 *db_seqp)
2755 *db_seqp = PL_curcop->cop_seq;
2756 for (si = PL_curstackinfo; si; si = si->si_prev) {
2757 for (ix = si->si_cxix; ix >= 0; ix--) {
2758 cx = &(si->si_cxstack[ix]);
2759 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2760 CV *cv = cx->blk_sub.cv;
2761 /* skip DB:: code */
2762 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2763 *db_seqp = cx->blk_oldcop->cop_seq;
2768 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2776 /* Compile a require/do, an eval '', or a /(?{...})/.
2777 * In the last case, startop is non-null, and contains the address of
2778 * a pointer that should be set to the just-compiled code.
2779 * outside is the lexically enclosing CV (if any) that invoked us.
2782 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2784 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2789 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2790 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2795 SAVESPTR(PL_compcv);
2796 PL_compcv = (CV*)NEWSV(1104,0);
2797 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2798 CvEVAL_on(PL_compcv);
2799 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2800 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2802 CvOUTSIDE_SEQ(PL_compcv) = seq;
2803 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2805 /* set up a scratch pad */
2807 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2810 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2812 /* make sure we compile in the right package */
2814 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2815 SAVESPTR(PL_curstash);
2816 PL_curstash = CopSTASH(PL_curcop);
2818 SAVESPTR(PL_beginav);
2819 PL_beginav = newAV();
2820 SAVEFREESV(PL_beginav);
2821 SAVEI32(PL_error_count);
2823 /* try to compile it */
2825 PL_eval_root = Nullop;
2827 PL_curcop = &PL_compiling;
2828 PL_curcop->cop_arybase = 0;
2829 if (saveop && saveop->op_flags & OPf_SPECIAL)
2830 PL_in_eval |= EVAL_KEEPERR;
2833 if (yyparse() || PL_error_count || !PL_eval_root) {
2834 SV **newsp; /* Used by POPBLOCK. */
2836 I32 optype = 0; /* Might be reset by POPEVAL. */
2841 op_free(PL_eval_root);
2842 PL_eval_root = Nullop;
2844 SP = PL_stack_base + POPMARK; /* pop original mark */
2846 POPBLOCK(cx,PL_curpm);
2852 if (optype == OP_REQUIRE) {
2853 char* msg = SvPVx(ERRSV, n_a);
2854 DIE(aTHX_ "%sCompilation failed in require",
2855 *msg ? msg : "Unknown error\n");
2858 char* msg = SvPVx(ERRSV, n_a);
2860 POPBLOCK(cx,PL_curpm);
2862 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2863 (*msg ? msg : "Unknown error\n"));
2866 char* msg = SvPVx(ERRSV, n_a);
2868 sv_setpv(ERRSV, "Compilation error");
2873 CopLINE_set(&PL_compiling, 0);
2875 *startop = PL_eval_root;
2877 SAVEFREEOP(PL_eval_root);
2879 /* Set the context for this new optree.
2880 * If the last op is an OP_REQUIRE, force scalar context.
2881 * Otherwise, propagate the context from the eval(). */
2882 if (PL_eval_root->op_type == OP_LEAVEEVAL
2883 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2884 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2886 scalar(PL_eval_root);
2887 else if (gimme & G_VOID)
2888 scalarvoid(PL_eval_root);
2889 else if (gimme & G_ARRAY)
2892 scalar(PL_eval_root);
2894 DEBUG_x(dump_eval());
2896 /* Register with debugger: */
2897 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2898 CV *cv = get_cv("DB::postponed", FALSE);
2902 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2904 call_sv((SV*)cv, G_DISCARD);
2908 /* compiled okay, so do it */
2910 CvDEPTH(PL_compcv) = 1;
2911 SP = PL_stack_base + POPMARK; /* pop original mark */
2912 PL_op = saveop; /* The caller may need it. */
2913 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2915 RETURNOP(PL_eval_start);
2919 S_doopen_pm(pTHX_ const char *name, const char *mode)
2921 #ifndef PERL_DISABLE_PMC
2922 STRLEN namelen = strlen(name);
2925 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2926 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2927 char *pmc = SvPV_nolen(pmcsv);
2930 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2931 fp = PerlIO_open(name, mode);
2934 if (PerlLIO_stat(name, &pmstat) < 0 ||
2935 pmstat.st_mtime < pmcstat.st_mtime)
2937 fp = PerlIO_open(pmc, mode);
2940 fp = PerlIO_open(name, mode);
2943 SvREFCNT_dec(pmcsv);
2946 fp = PerlIO_open(name, mode);
2950 return PerlIO_open(name, mode);
2951 #endif /* !PERL_DISABLE_PMC */
2957 register PERL_CONTEXT *cx;
2961 char *tryname = Nullch;
2962 SV *namesv = Nullsv;
2964 I32 gimme = GIMME_V;
2965 PerlIO *tryrsfp = 0;
2967 int filter_has_file = 0;
2968 GV *filter_child_proc = 0;
2969 SV *filter_state = 0;
2976 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2977 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2978 UV rev = 0, ver = 0, sver = 0;
2980 U8 *s = (U8*)SvPVX(sv);
2981 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2983 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2986 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2989 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2992 if (PERL_REVISION < rev
2993 || (PERL_REVISION == rev
2994 && (PERL_VERSION < ver
2995 || (PERL_VERSION == ver
2996 && PERL_SUBVERSION < sver))))
2998 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2999 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3000 PERL_VERSION, PERL_SUBVERSION);
3002 if (ckWARN(WARN_PORTABLE))
3003 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3004 "v-string in use/require non-portable");
3007 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3008 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3009 + ((NV)PERL_SUBVERSION/(NV)1000000)
3010 + 0.00000099 < SvNV(sv))
3014 NV nver = (nrev - rev) * 1000;
3015 UV ver = (UV)(nver + 0.0009);
3016 NV nsver = (nver - ver) * 1000;
3017 UV sver = (UV)(nsver + 0.0009);
3019 /* help out with the "use 5.6" confusion */
3020 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3021 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3022 " (did you mean v%"UVuf".%03"UVuf"?)--"
3023 "this is only v%d.%d.%d, stopped",
3024 rev, ver, sver, rev, ver/100,
3025 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3028 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3029 "this is only v%d.%d.%d, stopped",
3030 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3037 name = SvPV(sv, len);
3038 if (!(name && len > 0 && *name))
3039 DIE(aTHX_ "Null filename used");
3040 TAINT_PROPER("require");
3041 if (PL_op->op_type == OP_REQUIRE &&
3042 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3043 *svp != &PL_sv_undef)
3046 /* prepare to compile file */
3048 if (path_is_absolute(name)) {
3050 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3052 #ifdef MACOS_TRADITIONAL
3056 MacPerl_CanonDir(name, newname, 1);
3057 if (path_is_absolute(newname)) {
3059 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3064 AV *ar = GvAVn(PL_incgv);
3068 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3071 namesv = NEWSV(806, 0);
3072 for (i = 0; i <= AvFILL(ar); i++) {
3073 SV *dirsv = *av_fetch(ar, i, TRUE);
3079 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3080 && !sv_isobject(loader))
3082 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3085 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3086 PTR2UV(SvRV(dirsv)), name);
3087 tryname = SvPVX(namesv);
3098 if (sv_isobject(loader))
3099 count = call_method("INC", G_ARRAY);
3101 count = call_sv(loader, G_ARRAY);
3111 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3115 if (SvTYPE(arg) == SVt_PVGV) {
3116 IO *io = GvIO((GV *)arg);
3121 tryrsfp = IoIFP(io);
3122 if (IoTYPE(io) == IoTYPE_PIPE) {
3123 /* reading from a child process doesn't
3124 nest -- when returning from reading
3125 the inner module, the outer one is
3126 unreadable (closed?) I've tried to
3127 save the gv to manage the lifespan of
3128 the pipe, but this didn't help. XXX */
3129 filter_child_proc = (GV *)arg;
3130 (void)SvREFCNT_inc(filter_child_proc);
3133 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3134 PerlIO_close(IoOFP(io));
3146 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3148 (void)SvREFCNT_inc(filter_sub);
3151 filter_state = SP[i];
3152 (void)SvREFCNT_inc(filter_state);
3156 tryrsfp = PerlIO_open("/dev/null",
3171 filter_has_file = 0;
3172 if (filter_child_proc) {
3173 SvREFCNT_dec(filter_child_proc);
3174 filter_child_proc = 0;
3177 SvREFCNT_dec(filter_state);
3181 SvREFCNT_dec(filter_sub);
3186 if (!path_is_absolute(name)
3187 #ifdef MACOS_TRADITIONAL
3188 /* We consider paths of the form :a:b ambiguous and interpret them first
3189 as global then as local
3191 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3194 char *dir = SvPVx(dirsv, n_a);
3195 #ifdef MACOS_TRADITIONAL
3199 MacPerl_CanonDir(name, buf2, 1);
3200 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3204 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3206 sv_setpv(namesv, unixdir);
3207 sv_catpv(namesv, unixname);
3209 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3212 TAINT_PROPER("require");
3213 tryname = SvPVX(namesv);
3214 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3216 if (tryname[0] == '.' && tryname[1] == '/')
3225 SAVECOPFILE_FREE(&PL_compiling);
3226 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3227 SvREFCNT_dec(namesv);
3229 if (PL_op->op_type == OP_REQUIRE) {
3230 char *msgstr = name;
3231 if (namesv) { /* did we lookup @INC? */
3232 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3233 SV *dirmsgsv = NEWSV(0, 0);
3234 AV *ar = GvAVn(PL_incgv);
3236 sv_catpvn(msg, " in @INC", 8);
3237 if (instr(SvPVX(msg), ".h "))
3238 sv_catpv(msg, " (change .h to .ph maybe?)");
3239 if (instr(SvPVX(msg), ".ph "))
3240 sv_catpv(msg, " (did you run h2ph?)");
3241 sv_catpv(msg, " (@INC contains:");
3242 for (i = 0; i <= AvFILL(ar); i++) {
3243 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3244 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3245 sv_catsv(msg, dirmsgsv);
3247 sv_catpvn(msg, ")", 1);
3248 SvREFCNT_dec(dirmsgsv);
3249 msgstr = SvPV_nolen(msg);
3251 DIE(aTHX_ "Can't locate %s", msgstr);
3257 SETERRNO(0, SS_NORMAL);
3259 /* Assume success here to prevent recursive requirement. */
3261 /* Check whether a hook in @INC has already filled %INC */
3262 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3263 (void)hv_store(GvHVn(PL_incgv), name, len,
3264 (hook_sv ? SvREFCNT_inc(hook_sv)
3265 : newSVpv(CopFILE(&PL_compiling), 0)),
3271 lex_start(sv_2mortal(newSVpvn("",0)));
3272 SAVEGENERICSV(PL_rsfp_filters);
3273 PL_rsfp_filters = Nullav;
3278 SAVESPTR(PL_compiling.cop_warnings);
3279 if (PL_dowarn & G_WARN_ALL_ON)
3280 PL_compiling.cop_warnings = pWARN_ALL ;
3281 else if (PL_dowarn & G_WARN_ALL_OFF)
3282 PL_compiling.cop_warnings = pWARN_NONE ;
3283 else if (PL_taint_warn)
3284 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3286 PL_compiling.cop_warnings = pWARN_STD ;
3287 SAVESPTR(PL_compiling.cop_io);
3288 PL_compiling.cop_io = Nullsv;
3290 if (filter_sub || filter_child_proc) {
3291 SV *datasv = filter_add(run_user_filter, Nullsv);
3292 IoLINES(datasv) = filter_has_file;
3293 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3294 IoTOP_GV(datasv) = (GV *)filter_state;
3295 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3298 /* switch to eval mode */
3299 push_return(PL_op->op_next);
3300 PUSHBLOCK(cx, CXt_EVAL, SP);
3301 PUSHEVAL(cx, name, Nullgv);
3303 SAVECOPLINE(&PL_compiling);
3304 CopLINE_set(&PL_compiling, 0);
3308 /* Store and reset encoding. */
3309 encoding = PL_encoding;
3310 PL_encoding = Nullsv;
3312 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3314 /* Restore encoding. */
3315 PL_encoding = encoding;
3322 return pp_require();
3328 register PERL_CONTEXT *cx;
3330 I32 gimme = GIMME_V, was = PL_sub_generation;
3331 char tbuf[TYPE_DIGITS(long) + 12];
3332 char *tmpbuf = tbuf;
3341 TAINT_PROPER("eval");
3347 /* switch to eval mode */
3349 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3350 SV *sv = sv_newmortal();
3351 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3352 (unsigned long)++PL_evalseq,
3353 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3357 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3358 SAVECOPFILE_FREE(&PL_compiling);
3359 CopFILE_set(&PL_compiling, tmpbuf+2);
3360 SAVECOPLINE(&PL_compiling);
3361 CopLINE_set(&PL_compiling, 1);
3362 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3363 deleting the eval's FILEGV from the stash before gv_check() runs
3364 (i.e. before run-time proper). To work around the coredump that
3365 ensues, we always turn GvMULTI_on for any globals that were
3366 introduced within evals. See force_ident(). GSAR 96-10-12 */
3367 safestr = savepv(tmpbuf);
3368 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3370 PL_hints = PL_op->op_targ;
3371 SAVESPTR(PL_compiling.cop_warnings);
3372 if (specialWARN(PL_curcop->cop_warnings))
3373 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3375 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3376 SAVEFREESV(PL_compiling.cop_warnings);
3378 SAVESPTR(PL_compiling.cop_io);
3379 if (specialCopIO(PL_curcop->cop_io))
3380 PL_compiling.cop_io = PL_curcop->cop_io;
3382 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3383 SAVEFREESV(PL_compiling.cop_io);
3385 /* special case: an eval '' executed within the DB package gets lexically
3386 * placed in the first non-DB CV rather than the current CV - this
3387 * allows the debugger to execute code, find lexicals etc, in the
3388 * scope of the code being debugged. Passing &seq gets find_runcv
3389 * to do the dirty work for us */
3390 runcv = find_runcv(&seq);
3392 push_return(PL_op->op_next);
3393 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3394 PUSHEVAL(cx, 0, Nullgv);
3396 /* prepare to compile string */
3398 if (PERLDB_LINE && PL_curstash != PL_debstash)
3399 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3401 ret = doeval(gimme, NULL, runcv, seq);
3402 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3403 && ret != PL_op->op_next) { /* Successive compilation. */
3404 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3406 return DOCATCH(ret);
3416 register PERL_CONTEXT *cx;
3418 U8 save_flags = PL_op -> op_flags;
3423 retop = pop_return();
3426 if (gimme == G_VOID)
3428 else if (gimme == G_SCALAR) {
3431 if (SvFLAGS(TOPs) & SVs_TEMP)
3434 *MARK = sv_mortalcopy(TOPs);
3438 *MARK = &PL_sv_undef;
3443 /* in case LEAVE wipes old return values */
3444 for (mark = newsp + 1; mark <= SP; mark++) {
3445 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3446 *mark = sv_mortalcopy(*mark);
3447 TAINT_NOT; /* Each item is independent */
3451 PL_curpm = newpm; /* Don't pop $1 et al till now */
3454 assert(CvDEPTH(PL_compcv) == 1);
3456 CvDEPTH(PL_compcv) = 0;
3459 if (optype == OP_REQUIRE &&
3460 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3462 /* Unassume the success we assumed earlier. */
3463 SV *nsv = cx->blk_eval.old_namesv;
3464 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3465 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3466 /* die_where() did LEAVE, or we won't be here */
3470 if (!(save_flags & OPf_SPECIAL))
3480 register PERL_CONTEXT *cx;
3481 I32 gimme = GIMME_V;
3486 push_return(cLOGOP->op_other->op_next);
3487 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3490 PL_in_eval = EVAL_INEVAL;
3493 return DOCATCH(PL_op->op_next);
3504 register PERL_CONTEXT *cx;
3509 retop = pop_return();
3512 if (gimme == G_VOID)
3514 else if (gimme == G_SCALAR) {
3517 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3520 *MARK = sv_mortalcopy(TOPs);
3524 *MARK = &PL_sv_undef;
3529 /* in case LEAVE wipes old return values */
3530 for (mark = newsp + 1; mark <= SP; mark++) {
3531 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3532 *mark = sv_mortalcopy(*mark);
3533 TAINT_NOT; /* Each item is independent */
3537 PL_curpm = newpm; /* Don't pop $1 et al till now */
3545 S_doparseform(pTHX_ SV *sv)
3548 register char *s = SvPV_force(sv, len);
3549 register char *send = s + len;
3550 register char *base = Nullch;
3551 register I32 skipspaces = 0;
3552 bool noblank = FALSE;
3553 bool repeat = FALSE;
3554 bool postspace = FALSE;
3560 int maxops = 2; /* FF_LINEMARK + FF_END) */
3563 Perl_croak(aTHX_ "Null picture in formline");
3565 /* estimate the buffer size needed */
3566 for (base = s; s <= send; s++) {
3567 if (*s == '\n' || *s == '@' || *s == '^')
3573 New(804, fops, maxops, U32);
3578 *fpc++ = FF_LINEMARK;
3579 noblank = repeat = FALSE;
3597 case ' ': case '\t':
3608 *fpc++ = FF_LITERAL;
3616 *fpc++ = (U16)skipspaces;
3620 *fpc++ = FF_NEWLINE;
3624 arg = fpc - linepc + 1;
3631 *fpc++ = FF_LINEMARK;
3632 noblank = repeat = FALSE;
3641 ischop = s[-1] == '^';
3647 arg = (s - base) - 1;
3649 *fpc++ = FF_LITERAL;
3658 *fpc++ = FF_LINEGLOB;
3660 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3661 arg = ischop ? 512 : 0;
3671 arg |= 256 + (s - f);
3673 *fpc++ = s - base; /* fieldsize for FETCH */
3674 *fpc++ = FF_DECIMAL;
3677 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3678 arg = ischop ? 512 : 0;
3680 s++; /* skip the '0' first */
3689 arg |= 256 + (s - f);
3691 *fpc++ = s - base; /* fieldsize for FETCH */
3692 *fpc++ = FF_0DECIMAL;
3697 bool ismore = FALSE;
3700 while (*++s == '>') ;
3701 prespace = FF_SPACE;
3703 else if (*s == '|') {
3704 while (*++s == '|') ;
3705 prespace = FF_HALFSPACE;
3710 while (*++s == '<') ;
3713 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3717 *fpc++ = s - base; /* fieldsize for FETCH */
3719 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3722 *fpc++ = (U16)prespace;
3736 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3738 { /* need to jump to the next word */
3740 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3741 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3742 s = SvPVX(sv) + SvCUR(sv) + z;
3744 Copy(fops, s, arg, U32);
3746 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3751 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3753 SV *datasv = FILTER_DATA(idx);
3754 int filter_has_file = IoLINES(datasv);
3755 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3756 SV *filter_state = (SV *)IoTOP_GV(datasv);
3757 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3760 /* I was having segfault trouble under Linux 2.2.5 after a
3761 parse error occured. (Had to hack around it with a test
3762 for PL_error_count == 0.) Solaris doesn't segfault --
3763 not sure where the trouble is yet. XXX */
3765 if (filter_has_file) {
3766 len = FILTER_READ(idx+1, buf_sv, maxlen);
3769 if (filter_sub && len >= 0) {
3780 PUSHs(sv_2mortal(newSViv(maxlen)));
3782 PUSHs(filter_state);
3785 count = call_sv(filter_sub, G_SCALAR);
3801 IoLINES(datasv) = 0;
3802 if (filter_child_proc) {
3803 SvREFCNT_dec(filter_child_proc);
3804 IoFMT_GV(datasv) = Nullgv;
3807 SvREFCNT_dec(filter_state);
3808 IoTOP_GV(datasv) = Nullgv;
3811 SvREFCNT_dec(filter_sub);
3812 IoBOTTOM_GV(datasv) = Nullgv;
3814 filter_del(run_user_filter);
3820 /* perhaps someone can come up with a better name for
3821 this? it is not really "absolute", per se ... */
3823 S_path_is_absolute(pTHX_ char *name)
3825 if (PERL_FILE_IS_ABSOLUTE(name)
3826 #ifdef MACOS_TRADITIONAL
3829 || (*name == '.' && (name[1] == '/' ||
3830 (name[1] == '.' && name[2] == '/'))))