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(U16)
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 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2340 gv_efullname3(sv, CvGV(cv), Nullch);
2343 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2344 PUSHMARK( PL_stack_sp );
2345 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2349 RETURNOP(CvSTART(cv));
2353 label = SvPV(sv,n_a);
2354 if (!(do_dump || *label))
2355 DIE(aTHX_ must_have_label);
2358 else if (PL_op->op_flags & OPf_SPECIAL) {
2360 DIE(aTHX_ must_have_label);
2363 label = cPVOP->op_pv;
2365 if (label && *label) {
2367 bool leaving_eval = FALSE;
2368 bool in_block = FALSE;
2369 PERL_CONTEXT *last_eval_cx = 0;
2373 PL_lastgotoprobe = 0;
2375 for (ix = cxstack_ix; ix >= 0; ix--) {
2377 switch (CxTYPE(cx)) {
2379 leaving_eval = TRUE;
2380 if (!CxTRYBLOCK(cx)) {
2381 gotoprobe = (last_eval_cx ?
2382 last_eval_cx->blk_eval.old_eval_root :
2387 /* else fall through */
2389 gotoprobe = cx->blk_oldcop->op_sibling;
2395 gotoprobe = cx->blk_oldcop->op_sibling;
2398 gotoprobe = PL_main_root;
2401 if (CvDEPTH(cx->blk_sub.cv)) {
2402 gotoprobe = CvROOT(cx->blk_sub.cv);
2408 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2411 DIE(aTHX_ "panic: goto");
2412 gotoprobe = PL_main_root;
2416 retop = dofindlabel(gotoprobe, label,
2417 enterops, enterops + GOTO_DEPTH);
2421 PL_lastgotoprobe = gotoprobe;
2424 DIE(aTHX_ "Can't find label %s", label);
2426 /* if we're leaving an eval, check before we pop any frames
2427 that we're not going to punt, otherwise the error
2430 if (leaving_eval && *enterops && enterops[1]) {
2432 for (i = 1; enterops[i]; i++)
2433 if (enterops[i]->op_type == OP_ENTERITER)
2434 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2437 /* pop unwanted frames */
2439 if (ix < cxstack_ix) {
2446 oldsave = PL_scopestack[PL_scopestack_ix];
2447 LEAVE_SCOPE(oldsave);
2450 /* push wanted frames */
2452 if (*enterops && enterops[1]) {
2454 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2455 for (; enterops[ix]; ix++) {
2456 PL_op = enterops[ix];
2457 /* Eventually we may want to stack the needed arguments
2458 * for each op. For now, we punt on the hard ones. */
2459 if (PL_op->op_type == OP_ENTERITER)
2460 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2461 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2469 if (!retop) retop = PL_main_start;
2471 PL_restartop = retop;
2472 PL_do_undump = TRUE;
2476 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2477 PL_do_undump = FALSE;
2493 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2495 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2498 PL_exit_flags |= PERL_EXIT_EXPECTED;
2500 PUSHs(&PL_sv_undef);
2508 NV value = SvNVx(GvSV(cCOP->cop_gv));
2509 register I32 match = I_32(value);
2512 if (((NV)match) > value)
2513 --match; /* was fractional--truncate other way */
2515 match -= cCOP->uop.scop.scop_offset;
2518 else if (match > cCOP->uop.scop.scop_max)
2519 match = cCOP->uop.scop.scop_max;
2520 PL_op = cCOP->uop.scop.scop_next[match];
2530 PL_op = PL_op->op_next; /* can't assume anything */
2533 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2534 match -= cCOP->uop.scop.scop_offset;
2537 else if (match > cCOP->uop.scop.scop_max)
2538 match = cCOP->uop.scop.scop_max;
2539 PL_op = cCOP->uop.scop.scop_next[match];
2548 S_save_lines(pTHX_ AV *array, SV *sv)
2550 register char *s = SvPVX(sv);
2551 register char *send = SvPVX(sv) + SvCUR(sv);
2553 register I32 line = 1;
2555 while (s && s < send) {
2556 SV *tmpstr = NEWSV(85,0);
2558 sv_upgrade(tmpstr, SVt_PVMG);
2559 t = strchr(s, '\n');
2565 sv_setpvn(tmpstr, s, t - s);
2566 av_store(array, line++, tmpstr);
2571 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2573 S_docatch_body(pTHX_ va_list args)
2575 return docatch_body();
2580 S_docatch_body(pTHX)
2587 S_docatch(pTHX_ OP *o)
2592 volatile PERL_SI *cursi = PL_curstackinfo;
2596 assert(CATCH_GET == TRUE);
2600 /* Normally, the leavetry at the end of this block of ops will
2601 * pop an op off the return stack and continue there. By setting
2602 * the op to Nullop, we force an exit from the inner runops()
2605 retop = pop_return();
2606 push_return(Nullop);
2608 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2610 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2616 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2622 /* die caught by an inner eval - continue inner loop */
2623 if (PL_restartop && cursi == PL_curstackinfo) {
2624 PL_op = PL_restartop;
2628 /* a die in this eval - continue in outer loop */
2644 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2645 /* sv Text to convert to OP tree. */
2646 /* startop op_free() this to undo. */
2647 /* code Short string id of the caller. */
2649 dSP; /* Make POPBLOCK work. */
2652 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2656 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2657 char *tmpbuf = tbuf;
2660 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2665 /* switch to eval mode */
2667 if (PL_curcop == &PL_compiling) {
2668 SAVECOPSTASH_FREE(&PL_compiling);
2669 CopSTASH_set(&PL_compiling, PL_curstash);
2671 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2672 SV *sv = sv_newmortal();
2673 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2674 code, (unsigned long)++PL_evalseq,
2675 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2679 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2680 SAVECOPFILE_FREE(&PL_compiling);
2681 CopFILE_set(&PL_compiling, tmpbuf+2);
2682 SAVECOPLINE(&PL_compiling);
2683 CopLINE_set(&PL_compiling, 1);
2684 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2685 deleting the eval's FILEGV from the stash before gv_check() runs
2686 (i.e. before run-time proper). To work around the coredump that
2687 ensues, we always turn GvMULTI_on for any globals that were
2688 introduced within evals. See force_ident(). GSAR 96-10-12 */
2689 safestr = savepv(tmpbuf);
2690 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2692 #ifdef OP_IN_REGISTER
2697 PL_hints &= HINT_UTF8;
2699 /* we get here either during compilation, or via pp_regcomp at runtime */
2700 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2702 runcv = find_runcv(NULL);
2705 PL_op->op_type = OP_ENTEREVAL;
2706 PL_op->op_flags = 0; /* Avoid uninit warning. */
2707 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2708 PUSHEVAL(cx, 0, Nullgv);
2711 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2713 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2714 POPBLOCK(cx,PL_curpm);
2717 (*startop)->op_type = OP_NULL;
2718 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2720 /* XXX DAPM do this properly one year */
2721 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2723 if (PL_curcop == &PL_compiling)
2724 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2725 #ifdef OP_IN_REGISTER
2733 =for apidoc find_runcv
2735 Locate the CV corresponding to the currently executing sub or eval.
2736 If db_seqp is non_null, skip CVs that are in the DB package and populate
2737 *db_seqp with the cop sequence number at the point that the DB:: code was
2738 entered. (allows debuggers to eval in the scope of the breakpoint rather
2739 than in in the scope of the debuger itself).
2745 Perl_find_runcv(pTHX_ U32 *db_seqp)
2752 *db_seqp = PL_curcop->cop_seq;
2753 for (si = PL_curstackinfo; si; si = si->si_prev) {
2754 for (ix = si->si_cxix; ix >= 0; ix--) {
2755 cx = &(si->si_cxstack[ix]);
2756 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2757 CV *cv = cx->blk_sub.cv;
2758 /* skip DB:: code */
2759 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2760 *db_seqp = cx->blk_oldcop->cop_seq;
2765 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2773 /* Compile a require/do, an eval '', or a /(?{...})/.
2774 * In the last case, startop is non-null, and contains the address of
2775 * a pointer that should be set to the just-compiled code.
2776 * outside is the lexically enclosing CV (if any) that invoked us.
2779 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2781 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2786 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2787 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2792 SAVESPTR(PL_compcv);
2793 PL_compcv = (CV*)NEWSV(1104,0);
2794 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2795 CvEVAL_on(PL_compcv);
2796 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2797 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2799 CvOUTSIDE_SEQ(PL_compcv) = seq;
2800 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2802 /* set up a scratch pad */
2804 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2807 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2809 /* make sure we compile in the right package */
2811 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2812 SAVESPTR(PL_curstash);
2813 PL_curstash = CopSTASH(PL_curcop);
2815 SAVESPTR(PL_beginav);
2816 PL_beginav = newAV();
2817 SAVEFREESV(PL_beginav);
2818 SAVEI32(PL_error_count);
2820 /* try to compile it */
2822 PL_eval_root = Nullop;
2824 PL_curcop = &PL_compiling;
2825 PL_curcop->cop_arybase = 0;
2826 if (saveop && saveop->op_flags & OPf_SPECIAL)
2827 PL_in_eval |= EVAL_KEEPERR;
2830 if (yyparse() || PL_error_count || !PL_eval_root) {
2834 I32 optype = 0; /* Might be reset by POPEVAL. */
2839 op_free(PL_eval_root);
2840 PL_eval_root = Nullop;
2842 SP = PL_stack_base + POPMARK; /* pop original mark */
2844 POPBLOCK(cx,PL_curpm);
2850 if (optype == OP_REQUIRE) {
2851 char* msg = SvPVx(ERRSV, n_a);
2852 DIE(aTHX_ "%sCompilation failed in require",
2853 *msg ? msg : "Unknown error\n");
2856 char* msg = SvPVx(ERRSV, n_a);
2858 POPBLOCK(cx,PL_curpm);
2860 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2861 (*msg ? msg : "Unknown error\n"));
2864 char* msg = SvPVx(ERRSV, n_a);
2866 sv_setpv(ERRSV, "Compilation error");
2871 CopLINE_set(&PL_compiling, 0);
2873 *startop = PL_eval_root;
2875 SAVEFREEOP(PL_eval_root);
2877 scalarvoid(PL_eval_root);
2878 else if (gimme & G_ARRAY)
2881 scalar(PL_eval_root);
2883 DEBUG_x(dump_eval());
2885 /* Register with debugger: */
2886 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2887 CV *cv = get_cv("DB::postponed", FALSE);
2891 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2893 call_sv((SV*)cv, G_DISCARD);
2897 /* compiled okay, so do it */
2899 CvDEPTH(PL_compcv) = 1;
2900 SP = PL_stack_base + POPMARK; /* pop original mark */
2901 PL_op = saveop; /* The caller may need it. */
2902 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2904 RETURNOP(PL_eval_start);
2908 S_doopen_pm(pTHX_ const char *name, const char *mode)
2910 #ifndef PERL_DISABLE_PMC
2911 STRLEN namelen = strlen(name);
2914 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2915 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2916 char *pmc = SvPV_nolen(pmcsv);
2919 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2920 fp = PerlIO_open(name, mode);
2923 if (PerlLIO_stat(name, &pmstat) < 0 ||
2924 pmstat.st_mtime < pmcstat.st_mtime)
2926 fp = PerlIO_open(pmc, mode);
2929 fp = PerlIO_open(name, mode);
2932 SvREFCNT_dec(pmcsv);
2935 fp = PerlIO_open(name, mode);
2939 return PerlIO_open(name, mode);
2940 #endif /* !PERL_DISABLE_PMC */
2946 register PERL_CONTEXT *cx;
2950 char *tryname = Nullch;
2951 SV *namesv = Nullsv;
2953 I32 gimme = GIMME_V;
2954 PerlIO *tryrsfp = 0;
2956 int filter_has_file = 0;
2957 GV *filter_child_proc = 0;
2958 SV *filter_state = 0;
2965 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2966 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2967 UV rev = 0, ver = 0, sver = 0;
2969 U8 *s = (U8*)SvPVX(sv);
2970 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2972 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2975 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2978 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2981 if (PERL_REVISION < rev
2982 || (PERL_REVISION == rev
2983 && (PERL_VERSION < ver
2984 || (PERL_VERSION == ver
2985 && PERL_SUBVERSION < sver))))
2987 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2988 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2989 PERL_VERSION, PERL_SUBVERSION);
2991 if (ckWARN(WARN_PORTABLE))
2992 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2993 "v-string in use/require non-portable");
2996 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2997 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2998 + ((NV)PERL_SUBVERSION/(NV)1000000)
2999 + 0.00000099 < SvNV(sv))
3003 NV nver = (nrev - rev) * 1000;
3004 UV ver = (UV)(nver + 0.0009);
3005 NV nsver = (nver - ver) * 1000;
3006 UV sver = (UV)(nsver + 0.0009);
3008 /* help out with the "use 5.6" confusion */
3009 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3010 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3011 " (did you mean v%"UVuf".%03"UVuf"?)--"
3012 "this is only v%d.%d.%d, stopped",
3013 rev, ver, sver, rev, ver/100,
3014 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3017 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3018 "this is only v%d.%d.%d, stopped",
3019 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3026 name = SvPV(sv, len);
3027 if (!(name && len > 0 && *name))
3028 DIE(aTHX_ "Null filename used");
3029 TAINT_PROPER("require");
3030 if (PL_op->op_type == OP_REQUIRE &&
3031 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3032 *svp != &PL_sv_undef)
3035 /* prepare to compile file */
3037 if (path_is_absolute(name)) {
3039 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3041 #ifdef MACOS_TRADITIONAL
3045 MacPerl_CanonDir(name, newname, 1);
3046 if (path_is_absolute(newname)) {
3048 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3053 AV *ar = GvAVn(PL_incgv);
3057 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3060 namesv = NEWSV(806, 0);
3061 for (i = 0; i <= AvFILL(ar); i++) {
3062 SV *dirsv = *av_fetch(ar, i, TRUE);
3068 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3069 && !sv_isobject(loader))
3071 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3074 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3075 PTR2UV(SvRV(dirsv)), name);
3076 tryname = SvPVX(namesv);
3087 if (sv_isobject(loader))
3088 count = call_method("INC", G_ARRAY);
3090 count = call_sv(loader, G_ARRAY);
3100 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3104 if (SvTYPE(arg) == SVt_PVGV) {
3105 IO *io = GvIO((GV *)arg);
3110 tryrsfp = IoIFP(io);
3111 if (IoTYPE(io) == IoTYPE_PIPE) {
3112 /* reading from a child process doesn't
3113 nest -- when returning from reading
3114 the inner module, the outer one is
3115 unreadable (closed?) I've tried to
3116 save the gv to manage the lifespan of
3117 the pipe, but this didn't help. XXX */
3118 filter_child_proc = (GV *)arg;
3119 (void)SvREFCNT_inc(filter_child_proc);
3122 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3123 PerlIO_close(IoOFP(io));
3135 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3137 (void)SvREFCNT_inc(filter_sub);
3140 filter_state = SP[i];
3141 (void)SvREFCNT_inc(filter_state);
3145 tryrsfp = PerlIO_open("/dev/null",
3160 filter_has_file = 0;
3161 if (filter_child_proc) {
3162 SvREFCNT_dec(filter_child_proc);
3163 filter_child_proc = 0;
3166 SvREFCNT_dec(filter_state);
3170 SvREFCNT_dec(filter_sub);
3175 if (!path_is_absolute(name)
3176 #ifdef MACOS_TRADITIONAL
3177 /* We consider paths of the form :a:b ambiguous and interpret them first
3178 as global then as local
3180 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3183 char *dir = SvPVx(dirsv, n_a);
3184 #ifdef MACOS_TRADITIONAL
3188 MacPerl_CanonDir(name, buf2, 1);
3189 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3193 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3195 sv_setpv(namesv, unixdir);
3196 sv_catpv(namesv, unixname);
3198 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3201 TAINT_PROPER("require");
3202 tryname = SvPVX(namesv);
3203 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3205 if (tryname[0] == '.' && tryname[1] == '/')
3214 SAVECOPFILE_FREE(&PL_compiling);
3215 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3216 SvREFCNT_dec(namesv);
3218 if (PL_op->op_type == OP_REQUIRE) {
3219 char *msgstr = name;
3220 if (namesv) { /* did we lookup @INC? */
3221 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3222 SV *dirmsgsv = NEWSV(0, 0);
3223 AV *ar = GvAVn(PL_incgv);
3225 sv_catpvn(msg, " in @INC", 8);
3226 if (instr(SvPVX(msg), ".h "))
3227 sv_catpv(msg, " (change .h to .ph maybe?)");
3228 if (instr(SvPVX(msg), ".ph "))
3229 sv_catpv(msg, " (did you run h2ph?)");
3230 sv_catpv(msg, " (@INC contains:");
3231 for (i = 0; i <= AvFILL(ar); i++) {
3232 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3233 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3234 sv_catsv(msg, dirmsgsv);
3236 sv_catpvn(msg, ")", 1);
3237 SvREFCNT_dec(dirmsgsv);
3238 msgstr = SvPV_nolen(msg);
3240 DIE(aTHX_ "Can't locate %s", msgstr);
3246 SETERRNO(0, SS_NORMAL);
3248 /* Assume success here to prevent recursive requirement. */
3250 /* Check whether a hook in @INC has already filled %INC */
3251 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3252 (void)hv_store(GvHVn(PL_incgv), name, len,
3253 (hook_sv ? SvREFCNT_inc(hook_sv)
3254 : newSVpv(CopFILE(&PL_compiling), 0)),
3260 lex_start(sv_2mortal(newSVpvn("",0)));
3261 SAVEGENERICSV(PL_rsfp_filters);
3262 PL_rsfp_filters = Nullav;
3267 SAVESPTR(PL_compiling.cop_warnings);
3268 if (PL_dowarn & G_WARN_ALL_ON)
3269 PL_compiling.cop_warnings = pWARN_ALL ;
3270 else if (PL_dowarn & G_WARN_ALL_OFF)
3271 PL_compiling.cop_warnings = pWARN_NONE ;
3272 else if (PL_taint_warn)
3273 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3275 PL_compiling.cop_warnings = pWARN_STD ;
3276 SAVESPTR(PL_compiling.cop_io);
3277 PL_compiling.cop_io = Nullsv;
3279 if (filter_sub || filter_child_proc) {
3280 SV *datasv = filter_add(run_user_filter, Nullsv);
3281 IoLINES(datasv) = filter_has_file;
3282 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3283 IoTOP_GV(datasv) = (GV *)filter_state;
3284 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3287 /* switch to eval mode */
3288 push_return(PL_op->op_next);
3289 PUSHBLOCK(cx, CXt_EVAL, SP);
3290 PUSHEVAL(cx, name, Nullgv);
3292 SAVECOPLINE(&PL_compiling);
3293 CopLINE_set(&PL_compiling, 0);
3297 /* Store and reset encoding. */
3298 encoding = PL_encoding;
3299 PL_encoding = Nullsv;
3301 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3303 /* Restore encoding. */
3304 PL_encoding = encoding;
3311 return pp_require();
3317 register PERL_CONTEXT *cx;
3319 I32 gimme = GIMME_V, was = PL_sub_generation;
3320 char tbuf[TYPE_DIGITS(long) + 12];
3321 char *tmpbuf = tbuf;
3330 TAINT_PROPER("eval");
3336 /* switch to eval mode */
3338 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3339 SV *sv = sv_newmortal();
3340 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3341 (unsigned long)++PL_evalseq,
3342 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3346 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3347 SAVECOPFILE_FREE(&PL_compiling);
3348 CopFILE_set(&PL_compiling, tmpbuf+2);
3349 SAVECOPLINE(&PL_compiling);
3350 CopLINE_set(&PL_compiling, 1);
3351 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3352 deleting the eval's FILEGV from the stash before gv_check() runs
3353 (i.e. before run-time proper). To work around the coredump that
3354 ensues, we always turn GvMULTI_on for any globals that were
3355 introduced within evals. See force_ident(). GSAR 96-10-12 */
3356 safestr = savepv(tmpbuf);
3357 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3359 PL_hints = PL_op->op_targ;
3360 SAVESPTR(PL_compiling.cop_warnings);
3361 if (specialWARN(PL_curcop->cop_warnings))
3362 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3364 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3365 SAVEFREESV(PL_compiling.cop_warnings);
3367 SAVESPTR(PL_compiling.cop_io);
3368 if (specialCopIO(PL_curcop->cop_io))
3369 PL_compiling.cop_io = PL_curcop->cop_io;
3371 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3372 SAVEFREESV(PL_compiling.cop_io);
3374 /* special case: an eval '' executed within the DB package gets lexically
3375 * placed in the first non-DB CV rather than the current CV - this
3376 * allows the debugger to execute code, find lexicals etc, in the
3377 * scope of the code being debugged. Passing &seq gets find_runcv
3378 * to do the dirty work for us */
3379 runcv = find_runcv(&seq);
3381 push_return(PL_op->op_next);
3382 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3383 PUSHEVAL(cx, 0, Nullgv);
3385 /* prepare to compile string */
3387 if (PERLDB_LINE && PL_curstash != PL_debstash)
3388 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3390 ret = doeval(gimme, NULL, runcv, seq);
3391 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3392 && ret != PL_op->op_next) { /* Successive compilation. */
3393 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3395 return DOCATCH(ret);
3405 register PERL_CONTEXT *cx;
3407 U8 save_flags = PL_op -> op_flags;
3412 retop = pop_return();
3415 if (gimme == G_VOID)
3417 else if (gimme == G_SCALAR) {
3420 if (SvFLAGS(TOPs) & SVs_TEMP)
3423 *MARK = sv_mortalcopy(TOPs);
3427 *MARK = &PL_sv_undef;
3432 /* in case LEAVE wipes old return values */
3433 for (mark = newsp + 1; mark <= SP; mark++) {
3434 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3435 *mark = sv_mortalcopy(*mark);
3436 TAINT_NOT; /* Each item is independent */
3440 PL_curpm = newpm; /* Don't pop $1 et al till now */
3443 assert(CvDEPTH(PL_compcv) == 1);
3445 CvDEPTH(PL_compcv) = 0;
3448 if (optype == OP_REQUIRE &&
3449 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3451 /* Unassume the success we assumed earlier. */
3452 SV *nsv = cx->blk_eval.old_namesv;
3453 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3454 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3455 /* die_where() did LEAVE, or we won't be here */
3459 if (!(save_flags & OPf_SPECIAL))
3469 register PERL_CONTEXT *cx;
3470 I32 gimme = GIMME_V;
3475 push_return(cLOGOP->op_other->op_next);
3476 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3479 PL_in_eval = EVAL_INEVAL;
3482 return DOCATCH(PL_op->op_next);
3493 register PERL_CONTEXT *cx;
3498 retop = pop_return();
3501 if (gimme == G_VOID)
3503 else if (gimme == G_SCALAR) {
3506 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3509 *MARK = sv_mortalcopy(TOPs);
3513 *MARK = &PL_sv_undef;
3518 /* in case LEAVE wipes old return values */
3519 for (mark = newsp + 1; mark <= SP; mark++) {
3520 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3521 *mark = sv_mortalcopy(*mark);
3522 TAINT_NOT; /* Each item is independent */
3526 PL_curpm = newpm; /* Don't pop $1 et al till now */
3534 S_doparseform(pTHX_ SV *sv)
3537 register char *s = SvPV_force(sv, len);
3538 register char *send = s + len;
3539 register char *base = Nullch;
3540 register I32 skipspaces = 0;
3541 bool noblank = FALSE;
3542 bool repeat = FALSE;
3543 bool postspace = FALSE;
3549 int maxops = 2; /* FF_LINEMARK + FF_END) */
3552 Perl_croak(aTHX_ "Null picture in formline");
3554 /* estimate the buffer size needed */
3555 for (base = s; s <= send; s++) {
3556 if (*s == '\n' || *s == '@' || *s == '^')
3562 New(804, fops, maxops, U16);
3567 *fpc++ = FF_LINEMARK;
3568 noblank = repeat = FALSE;
3586 case ' ': case '\t':
3597 *fpc++ = FF_LITERAL;
3605 *fpc++ = (U16)skipspaces;
3609 *fpc++ = FF_NEWLINE;
3613 arg = fpc - linepc + 1;
3620 *fpc++ = FF_LINEMARK;
3621 noblank = repeat = FALSE;
3630 ischop = s[-1] == '^';
3636 arg = (s - base) - 1;
3638 *fpc++ = FF_LITERAL;
3647 *fpc++ = FF_LINEGLOB;
3649 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3650 arg = ischop ? 512 : 0;
3660 arg |= 256 + (s - f);
3662 *fpc++ = s - base; /* fieldsize for FETCH */
3663 *fpc++ = FF_DECIMAL;
3666 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3667 arg = ischop ? 512 : 0;
3669 s++; /* skip the '0' first */
3678 arg |= 256 + (s - f);
3680 *fpc++ = s - base; /* fieldsize for FETCH */
3681 *fpc++ = FF_0DECIMAL;
3686 bool ismore = FALSE;
3689 while (*++s == '>') ;
3690 prespace = FF_SPACE;
3692 else if (*s == '|') {
3693 while (*++s == '|') ;
3694 prespace = FF_HALFSPACE;
3699 while (*++s == '<') ;
3702 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3706 *fpc++ = s - base; /* fieldsize for FETCH */
3708 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3711 *fpc++ = (U16)prespace;
3725 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3727 { /* need to jump to the next word */
3729 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3730 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3731 s = SvPVX(sv) + SvCUR(sv) + z;
3733 Copy(fops, s, arg, U16);
3735 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3740 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3742 SV *datasv = FILTER_DATA(idx);
3743 int filter_has_file = IoLINES(datasv);
3744 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3745 SV *filter_state = (SV *)IoTOP_GV(datasv);
3746 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3749 /* I was having segfault trouble under Linux 2.2.5 after a
3750 parse error occured. (Had to hack around it with a test
3751 for PL_error_count == 0.) Solaris doesn't segfault --
3752 not sure where the trouble is yet. XXX */
3754 if (filter_has_file) {
3755 len = FILTER_READ(idx+1, buf_sv, maxlen);
3758 if (filter_sub && len >= 0) {
3769 PUSHs(sv_2mortal(newSViv(maxlen)));
3771 PUSHs(filter_state);
3774 count = call_sv(filter_sub, G_SCALAR);
3790 IoLINES(datasv) = 0;
3791 if (filter_child_proc) {
3792 SvREFCNT_dec(filter_child_proc);
3793 IoFMT_GV(datasv) = Nullgv;
3796 SvREFCNT_dec(filter_state);
3797 IoTOP_GV(datasv) = Nullgv;
3800 SvREFCNT_dec(filter_sub);
3801 IoBOTTOM_GV(datasv) = Nullgv;
3803 filter_del(run_user_filter);
3809 /* perhaps someone can come up with a better name for
3810 this? it is not really "absolute", per se ... */
3812 S_path_is_absolute(pTHX_ char *name)
3814 if (PERL_FILE_IS_ABSOLUTE(name)
3815 #ifdef MACOS_TRADITIONAL
3818 || (*name == '.' && (name[1] == '/' ||
3819 (name[1] == '.' && name[2] == '/'))))