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))
683 item = s = SvPV(sv, len);
685 if ((item_is_utf8 = DO_UTF8(sv)))
686 itemsize = sv_len_utf8(sv);
688 bool chopped = FALSE;
701 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
703 SvUTF8_on(PL_formtarget);
704 sv_catsv(PL_formtarget, sv);
706 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
707 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
708 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
715 /* If the field is marked with ^ and the value is undefined,
718 if ((arg & 512) && !SvOK(sv)) {
726 /* Formats aren't yet marked for locales, so assume "yes". */
728 STORE_NUMERIC_STANDARD_SET_LOCAL();
729 #if defined(USE_LONG_DOUBLE)
731 sprintf(t, "%#*.*" PERL_PRIfldbl,
732 (int) fieldsize, (int) arg & 255, value);
734 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
739 (int) fieldsize, (int) arg & 255, value);
742 (int) fieldsize, value);
745 RESTORE_NUMERIC_STANDARD();
751 /* If the field is marked with ^ and the value is undefined,
754 if ((arg & 512) && !SvOK(sv)) {
762 /* Formats aren't yet marked for locales, so assume "yes". */
764 STORE_NUMERIC_STANDARD_SET_LOCAL();
765 #if defined(USE_LONG_DOUBLE)
767 sprintf(t, "%#0*.*" PERL_PRIfldbl,
768 (int) fieldsize, (int) arg & 255, value);
769 /* is this legal? I don't have long doubles */
771 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
775 sprintf(t, "%#0*.*f",
776 (int) fieldsize, (int) arg & 255, value);
779 (int) fieldsize, value);
782 RESTORE_NUMERIC_STANDARD();
789 while (t-- > linemark && *t == ' ') ;
797 if (arg) { /* repeat until fields exhausted? */
799 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
800 lines += FmLINES(PL_formtarget);
803 if (strnEQ(linemark, linemark - arg, arg))
804 DIE(aTHX_ "Runaway format");
807 SvUTF8_on(PL_formtarget);
808 FmLINES(PL_formtarget) = lines;
810 RETURNOP(cLISTOP->op_first);
823 while (*s && isSPACE(*s) && s < send)
827 arg = fieldsize - itemsize;
834 if (strnEQ(s," ",3)) {
835 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
846 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
848 SvUTF8_on(PL_formtarget);
849 FmLINES(PL_formtarget) += lines;
861 if (PL_stack_base + *PL_markstack_ptr == SP) {
863 if (GIMME_V == G_SCALAR)
864 XPUSHs(sv_2mortal(newSViv(0)));
865 RETURNOP(PL_op->op_next->op_next);
867 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
868 pp_pushmark(); /* push dst */
869 pp_pushmark(); /* push src */
870 ENTER; /* enter outer scope */
873 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
875 ENTER; /* enter inner scope */
878 src = PL_stack_base[*PL_markstack_ptr];
883 if (PL_op->op_type == OP_MAPSTART)
884 pp_pushmark(); /* push top */
885 return ((LOGOP*)PL_op->op_next)->op_other;
890 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
896 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
902 /* first, move source pointer to the next item in the source list */
903 ++PL_markstack_ptr[-1];
905 /* if there are new items, push them into the destination list */
907 /* might need to make room back there first */
908 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
909 /* XXX this implementation is very pessimal because the stack
910 * is repeatedly extended for every set of items. Is possible
911 * to do this without any stack extension or copying at all
912 * by maintaining a separate list over which the map iterates
913 * (like foreach does). --gsar */
915 /* everything in the stack after the destination list moves
916 * towards the end the stack by the amount of room needed */
917 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
919 /* items to shift up (accounting for the moved source pointer) */
920 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
922 /* This optimization is by Ben Tilly and it does
923 * things differently from what Sarathy (gsar)
924 * is describing. The downside of this optimization is
925 * that leaves "holes" (uninitialized and hopefully unused areas)
926 * to the Perl stack, but on the other hand this
927 * shouldn't be a problem. If Sarathy's idea gets
928 * implemented, this optimization should become
929 * irrelevant. --jhi */
931 shift = count; /* Avoid shifting too often --Ben Tilly */
936 PL_markstack_ptr[-1] += shift;
937 *PL_markstack_ptr += shift;
941 /* copy the new items down to the destination list */
942 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
944 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
946 LEAVE; /* exit inner scope */
949 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
952 (void)POPMARK; /* pop top */
953 LEAVE; /* exit outer scope */
954 (void)POPMARK; /* pop src */
955 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
956 (void)POPMARK; /* pop dst */
957 SP = PL_stack_base + POPMARK; /* pop original mark */
958 if (gimme == G_SCALAR) {
962 else if (gimme == G_ARRAY)
969 ENTER; /* enter inner scope */
972 /* set $_ to the new source item */
973 src = PL_stack_base[PL_markstack_ptr[-1]];
977 RETURNOP(cLOGOP->op_other);
985 if (GIMME == G_ARRAY)
987 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
988 return cLOGOP->op_other;
997 if (GIMME == G_ARRAY) {
998 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1002 SV *targ = PAD_SV(PL_op->op_targ);
1005 if (PL_op->op_private & OPpFLIP_LINENUM) {
1006 if (GvIO(PL_last_in_gv)) {
1007 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1010 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1011 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1017 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1018 if (PL_op->op_flags & OPf_SPECIAL) {
1026 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1039 if (GIMME == G_ARRAY) {
1045 if (SvGMAGICAL(left))
1047 if (SvGMAGICAL(right))
1050 /* This code tries to decide if "$left .. $right" should use the
1051 magical string increment, or if the range is numeric (we make
1052 an exception for .."0" [#18165]). AMS 20021031. */
1054 if (SvNIOKp(left) || !SvPOKp(left) ||
1055 SvNIOKp(right) || !SvPOKp(right) ||
1056 (looks_like_number(left) && *SvPVX(left) != '0' &&
1057 looks_like_number(right)))
1059 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1060 DIE(aTHX_ "Range iterator outside integer range");
1071 sv = sv_2mortal(newSViv(i++));
1076 SV *final = sv_mortalcopy(right);
1078 char *tmps = SvPV(final, len);
1080 sv = sv_mortalcopy(left);
1082 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1084 if (strEQ(SvPVX(sv),tmps))
1086 sv = sv_2mortal(newSVsv(sv));
1093 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1097 if (PL_op->op_private & OPpFLIP_LINENUM) {
1098 if (GvIO(PL_last_in_gv)) {
1099 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1102 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1103 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1111 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1112 sv_catpv(targ, "E0");
1122 static char *context_name[] = {
1133 S_dopoptolabel(pTHX_ char *label)
1136 register PERL_CONTEXT *cx;
1138 for (i = cxstack_ix; i >= 0; i--) {
1140 switch (CxTYPE(cx)) {
1146 if (ckWARN(WARN_EXITING))
1147 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1148 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1149 if (CxTYPE(cx) == CXt_NULL)
1153 if (!cx->blk_loop.label ||
1154 strNE(label, cx->blk_loop.label) ) {
1155 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1156 (long)i, cx->blk_loop.label));
1159 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1167 Perl_dowantarray(pTHX)
1169 I32 gimme = block_gimme();
1170 return (gimme == G_VOID) ? G_SCALAR : gimme;
1174 Perl_block_gimme(pTHX)
1178 cxix = dopoptosub(cxstack_ix);
1182 switch (cxstack[cxix].blk_gimme) {
1190 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1197 Perl_is_lvalue_sub(pTHX)
1201 cxix = dopoptosub(cxstack_ix);
1202 assert(cxix >= 0); /* We should only be called from inside subs */
1204 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1205 return cxstack[cxix].blk_sub.lval;
1211 S_dopoptosub(pTHX_ I32 startingblock)
1213 return dopoptosub_at(cxstack, startingblock);
1217 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1220 register PERL_CONTEXT *cx;
1221 for (i = startingblock; i >= 0; i--) {
1223 switch (CxTYPE(cx)) {
1229 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1237 S_dopoptoeval(pTHX_ I32 startingblock)
1240 register PERL_CONTEXT *cx;
1241 for (i = startingblock; i >= 0; i--) {
1243 switch (CxTYPE(cx)) {
1247 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1255 S_dopoptoloop(pTHX_ I32 startingblock)
1258 register PERL_CONTEXT *cx;
1259 for (i = startingblock; i >= 0; i--) {
1261 switch (CxTYPE(cx)) {
1267 if (ckWARN(WARN_EXITING))
1268 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1269 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1270 if ((CxTYPE(cx)) == CXt_NULL)
1274 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1282 Perl_dounwind(pTHX_ I32 cxix)
1284 register PERL_CONTEXT *cx;
1287 while (cxstack_ix > cxix) {
1289 cx = &cxstack[cxstack_ix];
1290 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1291 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1292 /* Note: we don't need to restore the base context info till the end. */
1293 switch (CxTYPE(cx)) {
1296 continue; /* not break */
1318 Perl_qerror(pTHX_ SV *err)
1321 sv_catsv(ERRSV, err);
1323 sv_catsv(PL_errors, err);
1325 Perl_warn(aTHX_ "%"SVf, err);
1330 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1336 register PERL_CONTEXT *cx;
1341 if (PL_in_eval & EVAL_KEEPERR) {
1342 static char prefix[] = "\t(in cleanup) ";
1347 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1350 if (*e != *message || strNE(e,message))
1354 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1355 sv_catpvn(err, prefix, sizeof(prefix)-1);
1356 sv_catpvn(err, message, msglen);
1357 if (ckWARN(WARN_MISC)) {
1358 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1359 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1364 sv_setpvn(ERRSV, message, msglen);
1368 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1369 && PL_curstackinfo->si_prev)
1378 if (cxix < cxstack_ix)
1381 POPBLOCK(cx,PL_curpm);
1382 if (CxTYPE(cx) != CXt_EVAL) {
1384 message = SvPVx(ERRSV, msglen);
1385 PerlIO_write(Perl_error_log, "panic: die ", 11);
1386 PerlIO_write(Perl_error_log, message, msglen);
1391 if (gimme == G_SCALAR)
1392 *++newsp = &PL_sv_undef;
1393 PL_stack_sp = newsp;
1397 /* LEAVE could clobber PL_curcop (see save_re_context())
1398 * XXX it might be better to find a way to avoid messing with
1399 * PL_curcop in save_re_context() instead, but this is a more
1400 * minimal fix --GSAR */
1401 PL_curcop = cx->blk_oldcop;
1403 if (optype == OP_REQUIRE) {
1404 char* msg = SvPVx(ERRSV, n_a);
1405 DIE(aTHX_ "%sCompilation failed in require",
1406 *msg ? msg : "Unknown error\n");
1408 return pop_return();
1412 message = SvPVx(ERRSV, msglen);
1414 write_to_stderr(message, msglen);
1423 if (SvTRUE(left) != SvTRUE(right))
1435 RETURNOP(cLOGOP->op_other);
1444 RETURNOP(cLOGOP->op_other);
1453 if (!sv || !SvANY(sv)) {
1454 RETURNOP(cLOGOP->op_other);
1457 switch (SvTYPE(sv)) {
1459 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1463 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1467 if (CvROOT(sv) || CvXSUB(sv))
1477 RETURNOP(cLOGOP->op_other);
1483 register I32 cxix = dopoptosub(cxstack_ix);
1484 register PERL_CONTEXT *cx;
1485 register PERL_CONTEXT *ccstack = cxstack;
1486 PERL_SI *top_si = PL_curstackinfo;
1497 /* we may be in a higher stacklevel, so dig down deeper */
1498 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1499 top_si = top_si->si_prev;
1500 ccstack = top_si->si_cxstack;
1501 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1504 if (GIMME != G_ARRAY) {
1510 if (PL_DBsub && cxix >= 0 &&
1511 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1515 cxix = dopoptosub_at(ccstack, cxix - 1);
1518 cx = &ccstack[cxix];
1519 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1520 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1521 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1522 field below is defined for any cx. */
1523 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1524 cx = &ccstack[dbcxix];
1527 stashname = CopSTASHPV(cx->blk_oldcop);
1528 if (GIMME != G_ARRAY) {
1531 PUSHs(&PL_sv_undef);
1534 sv_setpv(TARG, stashname);
1543 PUSHs(&PL_sv_undef);
1545 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1546 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1547 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1550 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1551 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1552 /* So is ccstack[dbcxix]. */
1555 gv_efullname3(sv, cvgv, Nullch);
1556 PUSHs(sv_2mortal(sv));
1557 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1560 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1561 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1565 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1566 PUSHs(sv_2mortal(newSViv(0)));
1568 gimme = (I32)cx->blk_gimme;
1569 if (gimme == G_VOID)
1570 PUSHs(&PL_sv_undef);
1572 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1573 if (CxTYPE(cx) == CXt_EVAL) {
1575 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1576 PUSHs(cx->blk_eval.cur_text);
1580 else if (cx->blk_eval.old_namesv) {
1581 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1584 /* eval BLOCK (try blocks have old_namesv == 0) */
1586 PUSHs(&PL_sv_undef);
1587 PUSHs(&PL_sv_undef);
1591 PUSHs(&PL_sv_undef);
1592 PUSHs(&PL_sv_undef);
1594 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1595 && CopSTASH_eq(PL_curcop, PL_debstash))
1597 AV *ary = cx->blk_sub.argarray;
1598 int off = AvARRAY(ary) - AvALLOC(ary);
1602 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1605 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1608 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1609 av_extend(PL_dbargs, AvFILLp(ary) + off);
1610 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1611 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1613 /* XXX only hints propagated via op_private are currently
1614 * visible (others are not easily accessible, since they
1615 * use the global PL_hints) */
1616 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1617 HINT_PRIVATE_MASK)));
1620 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1622 if (old_warnings == pWARN_NONE ||
1623 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1624 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1625 else if (old_warnings == pWARN_ALL ||
1626 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1627 /* Get the bit mask for $warnings::Bits{all}, because
1628 * it could have been extended by warnings::register */
1630 HV *bits = get_hv("warnings::Bits", FALSE);
1631 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1632 mask = newSVsv(*bits_all);
1635 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1639 mask = newSVsv(old_warnings);
1640 PUSHs(sv_2mortal(mask));
1655 sv_reset(tmps, CopSTASH(PL_curcop));
1665 /* like pp_nextstate, but used instead when the debugger is active */
1669 PL_curcop = (COP*)PL_op;
1670 TAINT_NOT; /* Each statement is presumed innocent */
1671 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1674 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1675 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1679 register PERL_CONTEXT *cx;
1680 I32 gimme = G_ARRAY;
1687 DIE(aTHX_ "No DB::DB routine defined");
1689 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1690 /* don't do recursive DB::DB call */
1702 push_return(PL_op->op_next);
1703 PUSHBLOCK(cx, CXt_SUB, SP);
1706 (void)SvREFCNT_inc(cv);
1707 PAD_SET_CUR(CvPADLIST(cv),1);
1708 RETURNOP(CvSTART(cv));
1722 register PERL_CONTEXT *cx;
1723 I32 gimme = GIMME_V;
1725 U32 cxtype = CXt_LOOP;
1733 if (PL_op->op_targ) {
1734 #ifndef USE_ITHREADS
1735 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1738 SAVEPADSV(PL_op->op_targ);
1739 iterdata = INT2PTR(void*, PL_op->op_targ);
1740 cxtype |= CXp_PADVAR;
1745 svp = &GvSV(gv); /* symbol table variable */
1746 SAVEGENERICSV(*svp);
1749 iterdata = (void*)gv;
1755 PUSHBLOCK(cx, cxtype, SP);
1757 PUSHLOOP(cx, iterdata, MARK);
1759 PUSHLOOP(cx, svp, MARK);
1761 if (PL_op->op_flags & OPf_STACKED) {
1762 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1763 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1765 /* See comment in pp_flop() */
1766 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1767 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1768 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1769 looks_like_number((SV*)cx->blk_loop.iterary)))
1771 if (SvNV(sv) < IV_MIN ||
1772 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1773 DIE(aTHX_ "Range iterator outside integer range");
1774 cx->blk_loop.iterix = SvIV(sv);
1775 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1778 cx->blk_loop.iterlval = newSVsv(sv);
1782 cx->blk_loop.iterary = PL_curstack;
1783 AvFILLp(PL_curstack) = SP - PL_stack_base;
1784 cx->blk_loop.iterix = MARK - PL_stack_base;
1793 register PERL_CONTEXT *cx;
1794 I32 gimme = GIMME_V;
1800 PUSHBLOCK(cx, CXt_LOOP, SP);
1801 PUSHLOOP(cx, 0, SP);
1809 register PERL_CONTEXT *cx;
1817 newsp = PL_stack_base + cx->blk_loop.resetsp;
1820 if (gimme == G_VOID)
1822 else if (gimme == G_SCALAR) {
1824 *++newsp = sv_mortalcopy(*SP);
1826 *++newsp = &PL_sv_undef;
1830 *++newsp = sv_mortalcopy(*++mark);
1831 TAINT_NOT; /* Each item is independent */
1837 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1838 PL_curpm = newpm; /* ... and pop $1 et al */
1850 register PERL_CONTEXT *cx;
1851 bool popsub2 = FALSE;
1852 bool clear_errsv = FALSE;
1859 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1860 if (cxstack_ix == PL_sortcxix
1861 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1863 if (cxstack_ix > PL_sortcxix)
1864 dounwind(PL_sortcxix);
1865 AvARRAY(PL_curstack)[1] = *SP;
1866 PL_stack_sp = PL_stack_base + 1;
1871 cxix = dopoptosub(cxstack_ix);
1873 DIE(aTHX_ "Can't return outside a subroutine");
1874 if (cxix < cxstack_ix)
1878 switch (CxTYPE(cx)) {
1883 if (!(PL_in_eval & EVAL_KEEPERR))
1889 if (optype == OP_REQUIRE &&
1890 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1892 /* Unassume the success we assumed earlier. */
1893 SV *nsv = cx->blk_eval.old_namesv;
1894 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1895 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1902 DIE(aTHX_ "panic: return");
1906 if (gimme == G_SCALAR) {
1909 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1911 *++newsp = SvREFCNT_inc(*SP);
1916 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1918 *++newsp = sv_mortalcopy(sv);
1923 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1926 *++newsp = sv_mortalcopy(*SP);
1929 *++newsp = &PL_sv_undef;
1931 else if (gimme == G_ARRAY) {
1932 while (++MARK <= SP) {
1933 *++newsp = (popsub2 && SvTEMP(*MARK))
1934 ? *MARK : sv_mortalcopy(*MARK);
1935 TAINT_NOT; /* Each item is independent */
1938 PL_stack_sp = newsp;
1941 /* Stack values are safe: */
1943 POPSUB(cx,sv); /* release CV and @_ ... */
1947 PL_curpm = newpm; /* ... and pop $1 et al */
1952 return pop_return();
1959 register PERL_CONTEXT *cx;
1969 if (PL_op->op_flags & OPf_SPECIAL) {
1970 cxix = dopoptoloop(cxstack_ix);
1972 DIE(aTHX_ "Can't \"last\" outside a loop block");
1975 cxix = dopoptolabel(cPVOP->op_pv);
1977 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1979 if (cxix < cxstack_ix)
1984 switch (CxTYPE(cx)) {
1987 newsp = PL_stack_base + cx->blk_loop.resetsp;
1988 nextop = cx->blk_loop.last_op->op_next;
1992 nextop = pop_return();
1996 nextop = pop_return();
2000 nextop = pop_return();
2003 DIE(aTHX_ "panic: last");
2007 if (gimme == G_SCALAR) {
2009 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2010 ? *SP : sv_mortalcopy(*SP);
2012 *++newsp = &PL_sv_undef;
2014 else if (gimme == G_ARRAY) {
2015 while (++MARK <= SP) {
2016 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2017 ? *MARK : sv_mortalcopy(*MARK);
2018 TAINT_NOT; /* Each item is independent */
2025 /* Stack values are safe: */
2028 POPLOOP(cx); /* release loop vars ... */
2032 POPSUB(cx,sv); /* release CV and @_ ... */
2035 PL_curpm = newpm; /* ... and pop $1 et al */
2044 register PERL_CONTEXT *cx;
2047 if (PL_op->op_flags & OPf_SPECIAL) {
2048 cxix = dopoptoloop(cxstack_ix);
2050 DIE(aTHX_ "Can't \"next\" outside a loop block");
2053 cxix = dopoptolabel(cPVOP->op_pv);
2055 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2057 if (cxix < cxstack_ix)
2060 /* clear off anything above the scope we're re-entering, but
2061 * save the rest until after a possible continue block */
2062 inner = PL_scopestack_ix;
2064 if (PL_scopestack_ix < inner)
2065 leave_scope(PL_scopestack[PL_scopestack_ix]);
2066 return cx->blk_loop.next_op;
2072 register PERL_CONTEXT *cx;
2075 if (PL_op->op_flags & OPf_SPECIAL) {
2076 cxix = dopoptoloop(cxstack_ix);
2078 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2081 cxix = dopoptolabel(cPVOP->op_pv);
2083 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2085 if (cxix < cxstack_ix)
2089 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2090 LEAVE_SCOPE(oldsave);
2091 return cx->blk_loop.redo_op;
2095 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2099 static char too_deep[] = "Target of goto is too deeply nested";
2102 Perl_croak(aTHX_ too_deep);
2103 if (o->op_type == OP_LEAVE ||
2104 o->op_type == OP_SCOPE ||
2105 o->op_type == OP_LEAVELOOP ||
2106 o->op_type == OP_LEAVESUB ||
2107 o->op_type == OP_LEAVETRY)
2109 *ops++ = cUNOPo->op_first;
2111 Perl_croak(aTHX_ too_deep);
2114 if (o->op_flags & OPf_KIDS) {
2115 /* First try all the kids at this level, since that's likeliest. */
2116 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2117 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2118 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2121 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2122 if (kid == PL_lastgotoprobe)
2124 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2127 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2128 ops[-1]->op_type == OP_DBSTATE)
2133 if ((o = dofindlabel(kid, label, ops, oplimit)))
2152 register PERL_CONTEXT *cx;
2153 #define GOTO_DEPTH 64
2154 OP *enterops[GOTO_DEPTH];
2156 int do_dump = (PL_op->op_type == OP_DUMP);
2157 static char must_have_label[] = "goto must have label";
2160 if (PL_op->op_flags & OPf_STACKED) {
2164 /* This egregious kludge implements goto &subroutine */
2165 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2167 register PERL_CONTEXT *cx;
2168 CV* cv = (CV*)SvRV(sv);
2174 if (!CvROOT(cv) && !CvXSUB(cv)) {
2179 /* autoloaded stub? */
2180 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2182 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2183 GvNAMELEN(gv), FALSE);
2184 if (autogv && (cv = GvCV(autogv)))
2186 tmpstr = sv_newmortal();
2187 gv_efullname3(tmpstr, gv, Nullch);
2188 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2190 DIE(aTHX_ "Goto undefined subroutine");
2193 /* First do some returnish stuff. */
2194 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2196 cxix = dopoptosub(cxstack_ix);
2198 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2199 if (cxix < cxstack_ix)
2203 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2205 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2206 /* put @_ back onto stack */
2207 AV* av = cx->blk_sub.argarray;
2209 items = AvFILLp(av) + 1;
2211 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2212 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2213 PL_stack_sp += items;
2214 SvREFCNT_dec(GvAV(PL_defgv));
2215 GvAV(PL_defgv) = cx->blk_sub.savearray;
2216 /* abandon @_ if it got reified */
2218 (void)sv_2mortal((SV*)av); /* delay until return */
2220 av_extend(av, items-1);
2221 AvFLAGS(av) = AVf_REIFY;
2222 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2227 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2229 av = GvAV(PL_defgv);
2230 items = AvFILLp(av) + 1;
2232 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2233 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2234 PL_stack_sp += items;
2236 if (CxTYPE(cx) == CXt_SUB &&
2237 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2238 SvREFCNT_dec(cx->blk_sub.cv);
2239 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2240 LEAVE_SCOPE(oldsave);
2242 /* Now do some callish stuff. */
2244 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2246 #ifdef PERL_XSUB_OLDSTYLE
2247 if (CvOLDSTYLE(cv)) {
2248 I32 (*fp3)(int,int,int);
2253 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2254 items = (*fp3)(CvXSUBANY(cv).any_i32,
2255 mark - PL_stack_base + 1,
2257 SP = PL_stack_base + items;
2260 #endif /* PERL_XSUB_OLDSTYLE */
2265 PL_stack_sp--; /* There is no cv arg. */
2266 /* Push a mark for the start of arglist */
2268 (void)(*CvXSUB(cv))(aTHX_ cv);
2269 /* Pop the current context like a decent sub should */
2270 POPBLOCK(cx, PL_curpm);
2271 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2274 return pop_return();
2277 AV* padlist = CvPADLIST(cv);
2278 if (CxTYPE(cx) == CXt_EVAL) {
2279 PL_in_eval = cx->blk_eval.old_in_eval;
2280 PL_eval_root = cx->blk_eval.old_eval_root;
2281 cx->cx_type = CXt_SUB;
2282 cx->blk_sub.hasargs = 0;
2284 cx->blk_sub.cv = cv;
2285 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2288 if (CvDEPTH(cv) < 2)
2289 (void)SvREFCNT_inc(cv);
2291 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2292 sub_crush_depth(cv);
2293 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2295 PAD_SET_CUR(padlist, CvDEPTH(cv));
2296 if (cx->blk_sub.hasargs)
2298 AV* av = (AV*)PAD_SVl(0);
2301 cx->blk_sub.savearray = GvAV(PL_defgv);
2302 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2303 CX_CURPAD_SAVE(cx->blk_sub);
2304 cx->blk_sub.argarray = av;
2307 if (items >= AvMAX(av) + 1) {
2309 if (AvARRAY(av) != ary) {
2310 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2311 SvPVX(av) = (char*)ary;
2313 if (items >= AvMAX(av) + 1) {
2314 AvMAX(av) = items - 1;
2315 Renew(ary,items+1,SV*);
2317 SvPVX(av) = (char*)ary;
2320 Copy(mark,AvARRAY(av),items,SV*);
2321 AvFILLp(av) = items - 1;
2322 assert(!AvREAL(av));
2329 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2331 * We do not care about using sv to call CV;
2332 * it's for informational purposes only.
2334 SV *sv = GvSV(PL_DBsub);
2337 if (PERLDB_SUB_NN) {
2338 (void)SvUPGRADE(sv, SVt_PVIV);
2341 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2344 gv_efullname3(sv, CvGV(cv), Nullch);
2347 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2348 PUSHMARK( PL_stack_sp );
2349 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2353 RETURNOP(CvSTART(cv));
2357 label = SvPV(sv,n_a);
2358 if (!(do_dump || *label))
2359 DIE(aTHX_ must_have_label);
2362 else if (PL_op->op_flags & OPf_SPECIAL) {
2364 DIE(aTHX_ must_have_label);
2367 label = cPVOP->op_pv;
2369 if (label && *label) {
2371 bool leaving_eval = FALSE;
2372 bool in_block = FALSE;
2373 PERL_CONTEXT *last_eval_cx = 0;
2377 PL_lastgotoprobe = 0;
2379 for (ix = cxstack_ix; ix >= 0; ix--) {
2381 switch (CxTYPE(cx)) {
2383 leaving_eval = TRUE;
2384 if (!CxTRYBLOCK(cx)) {
2385 gotoprobe = (last_eval_cx ?
2386 last_eval_cx->blk_eval.old_eval_root :
2391 /* else fall through */
2393 gotoprobe = cx->blk_oldcop->op_sibling;
2399 gotoprobe = cx->blk_oldcop->op_sibling;
2402 gotoprobe = PL_main_root;
2405 if (CvDEPTH(cx->blk_sub.cv)) {
2406 gotoprobe = CvROOT(cx->blk_sub.cv);
2412 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2415 DIE(aTHX_ "panic: goto");
2416 gotoprobe = PL_main_root;
2420 retop = dofindlabel(gotoprobe, label,
2421 enterops, enterops + GOTO_DEPTH);
2425 PL_lastgotoprobe = gotoprobe;
2428 DIE(aTHX_ "Can't find label %s", label);
2430 /* if we're leaving an eval, check before we pop any frames
2431 that we're not going to punt, otherwise the error
2434 if (leaving_eval && *enterops && enterops[1]) {
2436 for (i = 1; enterops[i]; i++)
2437 if (enterops[i]->op_type == OP_ENTERITER)
2438 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2441 /* pop unwanted frames */
2443 if (ix < cxstack_ix) {
2450 oldsave = PL_scopestack[PL_scopestack_ix];
2451 LEAVE_SCOPE(oldsave);
2454 /* push wanted frames */
2456 if (*enterops && enterops[1]) {
2458 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2459 for (; enterops[ix]; ix++) {
2460 PL_op = enterops[ix];
2461 /* Eventually we may want to stack the needed arguments
2462 * for each op. For now, we punt on the hard ones. */
2463 if (PL_op->op_type == OP_ENTERITER)
2464 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2465 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2473 if (!retop) retop = PL_main_start;
2475 PL_restartop = retop;
2476 PL_do_undump = TRUE;
2480 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2481 PL_do_undump = FALSE;
2497 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2499 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2502 PL_exit_flags |= PERL_EXIT_EXPECTED;
2504 PUSHs(&PL_sv_undef);
2512 NV value = SvNVx(GvSV(cCOP->cop_gv));
2513 register I32 match = I_32(value);
2516 if (((NV)match) > value)
2517 --match; /* was fractional--truncate other way */
2519 match -= cCOP->uop.scop.scop_offset;
2522 else if (match > cCOP->uop.scop.scop_max)
2523 match = cCOP->uop.scop.scop_max;
2524 PL_op = cCOP->uop.scop.scop_next[match];
2534 PL_op = PL_op->op_next; /* can't assume anything */
2537 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2538 match -= cCOP->uop.scop.scop_offset;
2541 else if (match > cCOP->uop.scop.scop_max)
2542 match = cCOP->uop.scop.scop_max;
2543 PL_op = cCOP->uop.scop.scop_next[match];
2552 S_save_lines(pTHX_ AV *array, SV *sv)
2554 register char *s = SvPVX(sv);
2555 register char *send = SvPVX(sv) + SvCUR(sv);
2557 register I32 line = 1;
2559 while (s && s < send) {
2560 SV *tmpstr = NEWSV(85,0);
2562 sv_upgrade(tmpstr, SVt_PVMG);
2563 t = strchr(s, '\n');
2569 sv_setpvn(tmpstr, s, t - s);
2570 av_store(array, line++, tmpstr);
2575 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2577 S_docatch_body(pTHX_ va_list args)
2579 return docatch_body();
2584 S_docatch_body(pTHX)
2591 S_docatch(pTHX_ OP *o)
2596 volatile PERL_SI *cursi = PL_curstackinfo;
2600 assert(CATCH_GET == TRUE);
2604 /* Normally, the leavetry at the end of this block of ops will
2605 * pop an op off the return stack and continue there. By setting
2606 * the op to Nullop, we force an exit from the inner runops()
2609 retop = pop_return();
2610 push_return(Nullop);
2612 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2614 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2620 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2626 /* die caught by an inner eval - continue inner loop */
2627 if (PL_restartop && cursi == PL_curstackinfo) {
2628 PL_op = PL_restartop;
2632 /* a die in this eval - continue in outer loop */
2648 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2649 /* sv Text to convert to OP tree. */
2650 /* startop op_free() this to undo. */
2651 /* code Short string id of the caller. */
2653 dSP; /* Make POPBLOCK work. */
2656 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2660 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2661 char *tmpbuf = tbuf;
2664 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2669 /* switch to eval mode */
2671 if (PL_curcop == &PL_compiling) {
2672 SAVECOPSTASH_FREE(&PL_compiling);
2673 CopSTASH_set(&PL_compiling, PL_curstash);
2675 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2676 SV *sv = sv_newmortal();
2677 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2678 code, (unsigned long)++PL_evalseq,
2679 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2683 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2684 SAVECOPFILE_FREE(&PL_compiling);
2685 CopFILE_set(&PL_compiling, tmpbuf+2);
2686 SAVECOPLINE(&PL_compiling);
2687 CopLINE_set(&PL_compiling, 1);
2688 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2689 deleting the eval's FILEGV from the stash before gv_check() runs
2690 (i.e. before run-time proper). To work around the coredump that
2691 ensues, we always turn GvMULTI_on for any globals that were
2692 introduced within evals. See force_ident(). GSAR 96-10-12 */
2693 safestr = savepv(tmpbuf);
2694 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2696 #ifdef OP_IN_REGISTER
2701 PL_hints &= HINT_UTF8;
2703 /* we get here either during compilation, or via pp_regcomp at runtime */
2704 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2706 runcv = find_runcv(NULL);
2709 PL_op->op_type = OP_ENTEREVAL;
2710 PL_op->op_flags = 0; /* Avoid uninit warning. */
2711 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2712 PUSHEVAL(cx, 0, Nullgv);
2715 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2717 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2718 POPBLOCK(cx,PL_curpm);
2721 (*startop)->op_type = OP_NULL;
2722 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2724 /* XXX DAPM do this properly one year */
2725 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2727 if (PL_curcop == &PL_compiling)
2728 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2729 #ifdef OP_IN_REGISTER
2737 =for apidoc find_runcv
2739 Locate the CV corresponding to the currently executing sub or eval.
2740 If db_seqp is non_null, skip CVs that are in the DB package and populate
2741 *db_seqp with the cop sequence number at the point that the DB:: code was
2742 entered. (allows debuggers to eval in the scope of the breakpoint rather
2743 than in in the scope of the debuger itself).
2749 Perl_find_runcv(pTHX_ U32 *db_seqp)
2756 *db_seqp = PL_curcop->cop_seq;
2757 for (si = PL_curstackinfo; si; si = si->si_prev) {
2758 for (ix = si->si_cxix; ix >= 0; ix--) {
2759 cx = &(si->si_cxstack[ix]);
2760 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2761 CV *cv = cx->blk_sub.cv;
2762 /* skip DB:: code */
2763 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2764 *db_seqp = cx->blk_oldcop->cop_seq;
2769 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2777 /* Compile a require/do, an eval '', or a /(?{...})/.
2778 * In the last case, startop is non-null, and contains the address of
2779 * a pointer that should be set to the just-compiled code.
2780 * outside is the lexically enclosing CV (if any) that invoked us.
2783 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2785 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2790 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2791 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2796 SAVESPTR(PL_compcv);
2797 PL_compcv = (CV*)NEWSV(1104,0);
2798 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2799 CvEVAL_on(PL_compcv);
2800 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2801 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2803 CvOUTSIDE_SEQ(PL_compcv) = seq;
2804 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2806 /* set up a scratch pad */
2808 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2811 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2813 /* make sure we compile in the right package */
2815 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2816 SAVESPTR(PL_curstash);
2817 PL_curstash = CopSTASH(PL_curcop);
2819 SAVESPTR(PL_beginav);
2820 PL_beginav = newAV();
2821 SAVEFREESV(PL_beginav);
2822 SAVEI32(PL_error_count);
2824 /* try to compile it */
2826 PL_eval_root = Nullop;
2828 PL_curcop = &PL_compiling;
2829 PL_curcop->cop_arybase = 0;
2830 if (saveop && saveop->op_flags & OPf_SPECIAL)
2831 PL_in_eval |= EVAL_KEEPERR;
2834 if (yyparse() || PL_error_count || !PL_eval_root) {
2835 SV **newsp; /* Used by POPBLOCK. */
2837 I32 optype = 0; /* Might be reset by POPEVAL. */
2842 op_free(PL_eval_root);
2843 PL_eval_root = Nullop;
2845 SP = PL_stack_base + POPMARK; /* pop original mark */
2847 POPBLOCK(cx,PL_curpm);
2853 if (optype == OP_REQUIRE) {
2854 char* msg = SvPVx(ERRSV, n_a);
2855 DIE(aTHX_ "%sCompilation failed in require",
2856 *msg ? msg : "Unknown error\n");
2859 char* msg = SvPVx(ERRSV, n_a);
2861 POPBLOCK(cx,PL_curpm);
2863 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2864 (*msg ? msg : "Unknown error\n"));
2867 char* msg = SvPVx(ERRSV, n_a);
2869 sv_setpv(ERRSV, "Compilation error");
2874 CopLINE_set(&PL_compiling, 0);
2876 *startop = PL_eval_root;
2878 SAVEFREEOP(PL_eval_root);
2880 /* Set the context for this new optree.
2881 * If the last op is an OP_REQUIRE, force scalar context.
2882 * Otherwise, propagate the context from the eval(). */
2883 if (PL_eval_root->op_type == OP_LEAVEEVAL
2884 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2885 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2887 scalar(PL_eval_root);
2888 else if (gimme & G_VOID)
2889 scalarvoid(PL_eval_root);
2890 else if (gimme & G_ARRAY)
2893 scalar(PL_eval_root);
2895 DEBUG_x(dump_eval());
2897 /* Register with debugger: */
2898 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2899 CV *cv = get_cv("DB::postponed", FALSE);
2903 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2905 call_sv((SV*)cv, G_DISCARD);
2909 /* compiled okay, so do it */
2911 CvDEPTH(PL_compcv) = 1;
2912 SP = PL_stack_base + POPMARK; /* pop original mark */
2913 PL_op = saveop; /* The caller may need it. */
2914 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2916 RETURNOP(PL_eval_start);
2920 S_doopen_pm(pTHX_ const char *name, const char *mode)
2922 #ifndef PERL_DISABLE_PMC
2923 STRLEN namelen = strlen(name);
2926 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2927 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2928 char *pmc = SvPV_nolen(pmcsv);
2931 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2932 fp = PerlIO_open(name, mode);
2935 if (PerlLIO_stat(name, &pmstat) < 0 ||
2936 pmstat.st_mtime < pmcstat.st_mtime)
2938 fp = PerlIO_open(pmc, mode);
2941 fp = PerlIO_open(name, mode);
2944 SvREFCNT_dec(pmcsv);
2947 fp = PerlIO_open(name, mode);
2951 return PerlIO_open(name, mode);
2952 #endif /* !PERL_DISABLE_PMC */
2958 register PERL_CONTEXT *cx;
2962 char *tryname = Nullch;
2963 SV *namesv = Nullsv;
2965 I32 gimme = GIMME_V;
2966 PerlIO *tryrsfp = 0;
2968 int filter_has_file = 0;
2969 GV *filter_child_proc = 0;
2970 SV *filter_state = 0;
2977 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2978 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2979 UV rev = 0, ver = 0, sver = 0;
2981 U8 *s = (U8*)SvPVX(sv);
2982 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2984 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2987 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2990 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2993 if (PERL_REVISION < rev
2994 || (PERL_REVISION == rev
2995 && (PERL_VERSION < ver
2996 || (PERL_VERSION == ver
2997 && PERL_SUBVERSION < sver))))
2999 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3000 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3001 PERL_VERSION, PERL_SUBVERSION);
3003 if (ckWARN(WARN_PORTABLE))
3004 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3005 "v-string in use/require non-portable");
3008 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3009 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3010 + ((NV)PERL_SUBVERSION/(NV)1000000)
3011 + 0.00000099 < SvNV(sv))
3015 NV nver = (nrev - rev) * 1000;
3016 UV ver = (UV)(nver + 0.0009);
3017 NV nsver = (nver - ver) * 1000;
3018 UV sver = (UV)(nsver + 0.0009);
3020 /* help out with the "use 5.6" confusion */
3021 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3022 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3023 " (did you mean v%"UVuf".%03"UVuf"?)--"
3024 "this is only v%d.%d.%d, stopped",
3025 rev, ver, sver, rev, ver/100,
3026 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3029 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3030 "this is only v%d.%d.%d, stopped",
3031 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3038 name = SvPV(sv, len);
3039 if (!(name && len > 0 && *name))
3040 DIE(aTHX_ "Null filename used");
3041 TAINT_PROPER("require");
3042 if (PL_op->op_type == OP_REQUIRE &&
3043 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3044 *svp != &PL_sv_undef)
3047 /* prepare to compile file */
3049 if (path_is_absolute(name)) {
3051 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3053 #ifdef MACOS_TRADITIONAL
3057 MacPerl_CanonDir(name, newname, 1);
3058 if (path_is_absolute(newname)) {
3060 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3065 AV *ar = GvAVn(PL_incgv);
3069 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3072 namesv = NEWSV(806, 0);
3073 for (i = 0; i <= AvFILL(ar); i++) {
3074 SV *dirsv = *av_fetch(ar, i, TRUE);
3080 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3081 && !sv_isobject(loader))
3083 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3086 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3087 PTR2UV(SvRV(dirsv)), name);
3088 tryname = SvPVX(namesv);
3099 if (sv_isobject(loader))
3100 count = call_method("INC", G_ARRAY);
3102 count = call_sv(loader, G_ARRAY);
3112 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3116 if (SvTYPE(arg) == SVt_PVGV) {
3117 IO *io = GvIO((GV *)arg);
3122 tryrsfp = IoIFP(io);
3123 if (IoTYPE(io) == IoTYPE_PIPE) {
3124 /* reading from a child process doesn't
3125 nest -- when returning from reading
3126 the inner module, the outer one is
3127 unreadable (closed?) I've tried to
3128 save the gv to manage the lifespan of
3129 the pipe, but this didn't help. XXX */
3130 filter_child_proc = (GV *)arg;
3131 (void)SvREFCNT_inc(filter_child_proc);
3134 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3135 PerlIO_close(IoOFP(io));
3147 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3149 (void)SvREFCNT_inc(filter_sub);
3152 filter_state = SP[i];
3153 (void)SvREFCNT_inc(filter_state);
3157 tryrsfp = PerlIO_open("/dev/null",
3172 filter_has_file = 0;
3173 if (filter_child_proc) {
3174 SvREFCNT_dec(filter_child_proc);
3175 filter_child_proc = 0;
3178 SvREFCNT_dec(filter_state);
3182 SvREFCNT_dec(filter_sub);
3187 if (!path_is_absolute(name)
3188 #ifdef MACOS_TRADITIONAL
3189 /* We consider paths of the form :a:b ambiguous and interpret them first
3190 as global then as local
3192 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3195 char *dir = SvPVx(dirsv, n_a);
3196 #ifdef MACOS_TRADITIONAL
3200 MacPerl_CanonDir(name, buf2, 1);
3201 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3205 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3207 sv_setpv(namesv, unixdir);
3208 sv_catpv(namesv, unixname);
3210 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3213 TAINT_PROPER("require");
3214 tryname = SvPVX(namesv);
3215 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3217 if (tryname[0] == '.' && tryname[1] == '/')
3226 SAVECOPFILE_FREE(&PL_compiling);
3227 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3228 SvREFCNT_dec(namesv);
3230 if (PL_op->op_type == OP_REQUIRE) {
3231 char *msgstr = name;
3232 if (namesv) { /* did we lookup @INC? */
3233 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3234 SV *dirmsgsv = NEWSV(0, 0);
3235 AV *ar = GvAVn(PL_incgv);
3237 sv_catpvn(msg, " in @INC", 8);
3238 if (instr(SvPVX(msg), ".h "))
3239 sv_catpv(msg, " (change .h to .ph maybe?)");
3240 if (instr(SvPVX(msg), ".ph "))
3241 sv_catpv(msg, " (did you run h2ph?)");
3242 sv_catpv(msg, " (@INC contains:");
3243 for (i = 0; i <= AvFILL(ar); i++) {
3244 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3245 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3246 sv_catsv(msg, dirmsgsv);
3248 sv_catpvn(msg, ")", 1);
3249 SvREFCNT_dec(dirmsgsv);
3250 msgstr = SvPV_nolen(msg);
3252 DIE(aTHX_ "Can't locate %s", msgstr);
3258 SETERRNO(0, SS_NORMAL);
3260 /* Assume success here to prevent recursive requirement. */
3262 /* Check whether a hook in @INC has already filled %INC */
3263 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3264 (void)hv_store(GvHVn(PL_incgv), name, len,
3265 (hook_sv ? SvREFCNT_inc(hook_sv)
3266 : newSVpv(CopFILE(&PL_compiling), 0)),
3272 lex_start(sv_2mortal(newSVpvn("",0)));
3273 SAVEGENERICSV(PL_rsfp_filters);
3274 PL_rsfp_filters = Nullav;
3279 SAVESPTR(PL_compiling.cop_warnings);
3280 if (PL_dowarn & G_WARN_ALL_ON)
3281 PL_compiling.cop_warnings = pWARN_ALL ;
3282 else if (PL_dowarn & G_WARN_ALL_OFF)
3283 PL_compiling.cop_warnings = pWARN_NONE ;
3284 else if (PL_taint_warn)
3285 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3287 PL_compiling.cop_warnings = pWARN_STD ;
3288 SAVESPTR(PL_compiling.cop_io);
3289 PL_compiling.cop_io = Nullsv;
3291 if (filter_sub || filter_child_proc) {
3292 SV *datasv = filter_add(run_user_filter, Nullsv);
3293 IoLINES(datasv) = filter_has_file;
3294 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3295 IoTOP_GV(datasv) = (GV *)filter_state;
3296 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3299 /* switch to eval mode */
3300 push_return(PL_op->op_next);
3301 PUSHBLOCK(cx, CXt_EVAL, SP);
3302 PUSHEVAL(cx, name, Nullgv);
3304 SAVECOPLINE(&PL_compiling);
3305 CopLINE_set(&PL_compiling, 0);
3309 /* Store and reset encoding. */
3310 encoding = PL_encoding;
3311 PL_encoding = Nullsv;
3313 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3315 /* Restore encoding. */
3316 PL_encoding = encoding;
3323 return pp_require();
3329 register PERL_CONTEXT *cx;
3331 I32 gimme = GIMME_V, was = PL_sub_generation;
3332 char tbuf[TYPE_DIGITS(long) + 12];
3333 char *tmpbuf = tbuf;
3342 TAINT_PROPER("eval");
3348 /* switch to eval mode */
3350 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3351 SV *sv = sv_newmortal();
3352 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3353 (unsigned long)++PL_evalseq,
3354 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3358 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3359 SAVECOPFILE_FREE(&PL_compiling);
3360 CopFILE_set(&PL_compiling, tmpbuf+2);
3361 SAVECOPLINE(&PL_compiling);
3362 CopLINE_set(&PL_compiling, 1);
3363 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3364 deleting the eval's FILEGV from the stash before gv_check() runs
3365 (i.e. before run-time proper). To work around the coredump that
3366 ensues, we always turn GvMULTI_on for any globals that were
3367 introduced within evals. See force_ident(). GSAR 96-10-12 */
3368 safestr = savepv(tmpbuf);
3369 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3371 PL_hints = PL_op->op_targ;
3372 SAVESPTR(PL_compiling.cop_warnings);
3373 if (specialWARN(PL_curcop->cop_warnings))
3374 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3376 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3377 SAVEFREESV(PL_compiling.cop_warnings);
3379 SAVESPTR(PL_compiling.cop_io);
3380 if (specialCopIO(PL_curcop->cop_io))
3381 PL_compiling.cop_io = PL_curcop->cop_io;
3383 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3384 SAVEFREESV(PL_compiling.cop_io);
3386 /* special case: an eval '' executed within the DB package gets lexically
3387 * placed in the first non-DB CV rather than the current CV - this
3388 * allows the debugger to execute code, find lexicals etc, in the
3389 * scope of the code being debugged. Passing &seq gets find_runcv
3390 * to do the dirty work for us */
3391 runcv = find_runcv(&seq);
3393 push_return(PL_op->op_next);
3394 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3395 PUSHEVAL(cx, 0, Nullgv);
3397 /* prepare to compile string */
3399 if (PERLDB_LINE && PL_curstash != PL_debstash)
3400 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3402 ret = doeval(gimme, NULL, runcv, seq);
3403 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3404 && ret != PL_op->op_next) { /* Successive compilation. */
3405 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3407 return DOCATCH(ret);
3417 register PERL_CONTEXT *cx;
3419 U8 save_flags = PL_op -> op_flags;
3424 retop = pop_return();
3427 if (gimme == G_VOID)
3429 else if (gimme == G_SCALAR) {
3432 if (SvFLAGS(TOPs) & SVs_TEMP)
3435 *MARK = sv_mortalcopy(TOPs);
3439 *MARK = &PL_sv_undef;
3444 /* in case LEAVE wipes old return values */
3445 for (mark = newsp + 1; mark <= SP; mark++) {
3446 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3447 *mark = sv_mortalcopy(*mark);
3448 TAINT_NOT; /* Each item is independent */
3452 PL_curpm = newpm; /* Don't pop $1 et al till now */
3455 assert(CvDEPTH(PL_compcv) == 1);
3457 CvDEPTH(PL_compcv) = 0;
3460 if (optype == OP_REQUIRE &&
3461 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3463 /* Unassume the success we assumed earlier. */
3464 SV *nsv = cx->blk_eval.old_namesv;
3465 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3466 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3467 /* die_where() did LEAVE, or we won't be here */
3471 if (!(save_flags & OPf_SPECIAL))
3481 register PERL_CONTEXT *cx;
3482 I32 gimme = GIMME_V;
3487 push_return(cLOGOP->op_other->op_next);
3488 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3491 PL_in_eval = EVAL_INEVAL;
3494 return DOCATCH(PL_op->op_next);
3505 register PERL_CONTEXT *cx;
3510 retop = pop_return();
3513 if (gimme == G_VOID)
3515 else if (gimme == G_SCALAR) {
3518 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3521 *MARK = sv_mortalcopy(TOPs);
3525 *MARK = &PL_sv_undef;
3530 /* in case LEAVE wipes old return values */
3531 for (mark = newsp + 1; mark <= SP; mark++) {
3532 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3533 *mark = sv_mortalcopy(*mark);
3534 TAINT_NOT; /* Each item is independent */
3538 PL_curpm = newpm; /* Don't pop $1 et al till now */
3546 S_doparseform(pTHX_ SV *sv)
3549 register char *s = SvPV_force(sv, len);
3550 register char *send = s + len;
3551 register char *base = Nullch;
3552 register I32 skipspaces = 0;
3553 bool noblank = FALSE;
3554 bool repeat = FALSE;
3555 bool postspace = FALSE;
3561 int maxops = 2; /* FF_LINEMARK + FF_END) */
3564 Perl_croak(aTHX_ "Null picture in formline");
3566 /* estimate the buffer size needed */
3567 for (base = s; s <= send; s++) {
3568 if (*s == '\n' || *s == '@' || *s == '^')
3574 New(804, fops, maxops, U32);
3579 *fpc++ = FF_LINEMARK;
3580 noblank = repeat = FALSE;
3598 case ' ': case '\t':
3609 *fpc++ = FF_LITERAL;
3617 *fpc++ = (U16)skipspaces;
3621 *fpc++ = FF_NEWLINE;
3625 arg = fpc - linepc + 1;
3632 *fpc++ = FF_LINEMARK;
3633 noblank = repeat = FALSE;
3642 ischop = s[-1] == '^';
3648 arg = (s - base) - 1;
3650 *fpc++ = FF_LITERAL;
3659 *fpc++ = FF_LINEGLOB;
3661 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3662 arg = ischop ? 512 : 0;
3672 arg |= 256 + (s - f);
3674 *fpc++ = s - base; /* fieldsize for FETCH */
3675 *fpc++ = FF_DECIMAL;
3678 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3679 arg = ischop ? 512 : 0;
3681 s++; /* skip the '0' first */
3690 arg |= 256 + (s - f);
3692 *fpc++ = s - base; /* fieldsize for FETCH */
3693 *fpc++ = FF_0DECIMAL;
3698 bool ismore = FALSE;
3701 while (*++s == '>') ;
3702 prespace = FF_SPACE;
3704 else if (*s == '|') {
3705 while (*++s == '|') ;
3706 prespace = FF_HALFSPACE;
3711 while (*++s == '<') ;
3714 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3718 *fpc++ = s - base; /* fieldsize for FETCH */
3720 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3723 *fpc++ = (U16)prespace;
3737 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3739 { /* need to jump to the next word */
3741 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3742 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3743 s = SvPVX(sv) + SvCUR(sv) + z;
3745 Copy(fops, s, arg, U32);
3747 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3752 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3754 SV *datasv = FILTER_DATA(idx);
3755 int filter_has_file = IoLINES(datasv);
3756 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3757 SV *filter_state = (SV *)IoTOP_GV(datasv);
3758 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3761 /* I was having segfault trouble under Linux 2.2.5 after a
3762 parse error occured. (Had to hack around it with a test
3763 for PL_error_count == 0.) Solaris doesn't segfault --
3764 not sure where the trouble is yet. XXX */
3766 if (filter_has_file) {
3767 len = FILTER_READ(idx+1, buf_sv, maxlen);
3770 if (filter_sub && len >= 0) {
3781 PUSHs(sv_2mortal(newSViv(maxlen)));
3783 PUSHs(filter_state);
3786 count = call_sv(filter_sub, G_SCALAR);
3802 IoLINES(datasv) = 0;
3803 if (filter_child_proc) {
3804 SvREFCNT_dec(filter_child_proc);
3805 IoFMT_GV(datasv) = Nullgv;
3808 SvREFCNT_dec(filter_state);
3809 IoTOP_GV(datasv) = Nullgv;
3812 SvREFCNT_dec(filter_sub);
3813 IoBOTTOM_GV(datasv) = Nullgv;
3815 filter_del(run_user_filter);
3821 /* perhaps someone can come up with a better name for
3822 this? it is not really "absolute", per se ... */
3824 S_path_is_absolute(pTHX_ char *name)
3826 if (PERL_FILE_IS_ABSOLUTE(name)
3827 #ifdef MACOS_TRADITIONAL
3830 || (*name == '.' && (name[1] == '/' ||
3831 (name[1] == '.' && name[2] == '/'))))