3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS) || defined(USE_5005THREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
160 rxres_restore(&cx->sb_rxres, rx);
161 PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
163 if (cx->sb_iters++) {
164 I32 saviters = cx->sb_iters;
165 if (cx->sb_iters > cx->sb_maxiters)
166 DIE(aTHX_ "Substitution loop");
168 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
169 cx->sb_rxtainted |= 2;
170 sv_catsv(dstr, POPs);
173 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
174 s == m, cx->sb_targ, NULL,
175 ((cx->sb_rflags & REXEC_COPY_STR)
176 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
177 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
179 SV *targ = cx->sb_targ;
181 sv_catpvn(dstr, s, cx->sb_strend - s);
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 (void)SvOOK_off(targ);
185 Safefree(SvPVX(targ));
186 SvPVX(targ) = SvPVX(dstr);
187 SvCUR_set(targ, SvCUR(dstr));
188 SvLEN_set(targ, SvLEN(dstr));
194 TAINT_IF(cx->sb_rxtainted & 1);
195 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
197 (void)SvPOK_only_UTF8(targ);
198 TAINT_IF(cx->sb_rxtainted);
202 LEAVE_SCOPE(cx->sb_oldsave);
204 RETURNOP(pm->op_next);
206 cx->sb_iters = saviters;
208 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
211 cx->sb_orig = orig = rx->subbeg;
213 cx->sb_strend = s + (cx->sb_strend - m);
215 cx->sb_m = m = rx->startp[0] + orig;
217 sv_catpvn(dstr, s, m-s);
218 cx->sb_s = rx->endp[0] + orig;
219 { /* Update the pos() information. */
220 SV *sv = cx->sb_targ;
223 if (SvTYPE(sv) < SVt_PVMG)
224 (void)SvUPGRADE(sv, SVt_PVMG);
225 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
226 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
227 mg = mg_find(sv, PERL_MAGIC_regex_global);
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
235 rxres_save(&cx->sb_rxres, rx);
236 RETURNOP(pm->op_pmreplstart);
240 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
245 if (!p || p[1] < rx->nparens) {
246 i = 6 + rx->nparens * 2;
254 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
255 RX_MATCH_COPIED_off(rx);
259 *p++ = PTR2UV(rx->subbeg);
260 *p++ = (UV)rx->sublen;
261 for (i = 0; i <= rx->nparens; ++i) {
262 *p++ = (UV)rx->startp[i];
263 *p++ = (UV)rx->endp[i];
268 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
273 if (RX_MATCH_COPIED(rx))
274 Safefree(rx->subbeg);
275 RX_MATCH_COPIED_set(rx, *p);
280 rx->subbeg = INT2PTR(char*,*p++);
281 rx->sublen = (I32)(*p++);
282 for (i = 0; i <= rx->nparens; ++i) {
283 rx->startp[i] = (I32)(*p++);
284 rx->endp[i] = (I32)(*p++);
289 Perl_rxres_free(pTHX_ void **rsp)
294 Safefree(INT2PTR(char*,*p));
302 dSP; dMARK; dORIGMARK;
303 register SV *tmpForm = *++MARK;
310 register SV *sv = Nullsv;
315 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
316 char *chophere = Nullch;
317 char *linemark = Nullch;
319 bool gotsome = FALSE;
321 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
322 bool item_is_utf = FALSE;
324 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
325 if (SvREADONLY(tmpForm)) {
326 SvREADONLY_off(tmpForm);
327 doparseform(tmpForm);
328 SvREADONLY_on(tmpForm);
331 doparseform(tmpForm);
334 SvPV_force(PL_formtarget, len);
335 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
337 f = SvPV(tmpForm, len);
338 /* need to jump to the next word */
339 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
348 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
349 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
350 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
351 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
352 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
354 case FF_CHECKNL: name = "CHECKNL"; break;
355 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
356 case FF_SPACE: name = "SPACE"; break;
357 case FF_HALFSPACE: name = "HALFSPACE"; break;
358 case FF_ITEM: name = "ITEM"; break;
359 case FF_CHOP: name = "CHOP"; break;
360 case FF_LINEGLOB: name = "LINEGLOB"; break;
361 case FF_NEWLINE: name = "NEWLINE"; break;
362 case FF_MORE: name = "MORE"; break;
363 case FF_LINEMARK: name = "LINEMARK"; break;
364 case FF_END: name = "END"; break;
365 case FF_0DECIMAL: name = "0DECIMAL"; break;
368 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
370 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
398 if (ckWARN(WARN_SYNTAX))
399 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
404 item = s = SvPV(sv, len);
407 itemsize = sv_len_utf8(sv);
408 if (itemsize != (I32)len) {
410 if (itemsize > fieldsize) {
411 itemsize = fieldsize;
412 itembytes = itemsize;
413 sv_pos_u2b(sv, &itembytes, 0);
417 send = chophere = s + itembytes;
427 sv_pos_b2u(sv, &itemsize);
432 if (itemsize > fieldsize)
433 itemsize = fieldsize;
434 send = chophere = s + itemsize;
446 item = s = SvPV(sv, len);
449 itemsize = sv_len_utf8(sv);
450 if (itemsize != (I32)len) {
452 if (itemsize <= fieldsize) {
453 send = chophere = s + itemsize;
464 itemsize = fieldsize;
465 itembytes = itemsize;
466 sv_pos_u2b(sv, &itembytes, 0);
467 send = chophere = s + itembytes;
468 while (s < send || (s == send && isSPACE(*s))) {
478 if (strchr(PL_chopset, *s))
483 itemsize = chophere - item;
484 sv_pos_b2u(sv, &itemsize);
491 if (itemsize <= fieldsize) {
492 send = chophere = s + itemsize;
503 itemsize = fieldsize;
504 send = chophere = s + itemsize;
505 while (s < send || (s == send && isSPACE(*s))) {
515 if (strchr(PL_chopset, *s))
520 itemsize = chophere - item;
525 arg = fieldsize - itemsize;
534 arg = fieldsize - itemsize;
548 if (UTF8_IS_CONTINUED(*s)) {
549 STRLEN skip = UTF8SKIP(s);
566 if ( !((*t++ = *s++) & ~31) )
574 int ch = *t++ = *s++;
577 if ( !((*t++ = *s++) & ~31) )
586 while (*s && isSPACE(*s))
593 item = s = SvPV(sv, len);
595 item_is_utf = FALSE; /* XXX is this correct? */
607 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
608 sv_catpvn(PL_formtarget, item, itemsize);
609 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
610 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
615 /* If the field is marked with ^ and the value is undefined,
618 if ((arg & 512) && !SvOK(sv)) {
626 /* Formats aren't yet marked for locales, so assume "yes". */
628 STORE_NUMERIC_STANDARD_SET_LOCAL();
629 #if defined(USE_LONG_DOUBLE)
631 sprintf(t, "%#*.*" PERL_PRIfldbl,
632 (int) fieldsize, (int) arg & 255, value);
634 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
639 (int) fieldsize, (int) arg & 255, value);
642 (int) fieldsize, value);
645 RESTORE_NUMERIC_STANDARD();
651 /* If the field is marked with ^ and the value is undefined,
654 if ((arg & 512) && !SvOK(sv)) {
662 /* Formats aren't yet marked for locales, so assume "yes". */
664 STORE_NUMERIC_STANDARD_SET_LOCAL();
665 #if defined(USE_LONG_DOUBLE)
667 sprintf(t, "%#0*.*" PERL_PRIfldbl,
668 (int) fieldsize, (int) arg & 255, value);
669 /* is this legal? I don't have long doubles */
671 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
675 sprintf(t, "%#0*.*f",
676 (int) fieldsize, (int) arg & 255, value);
679 (int) fieldsize, value);
682 RESTORE_NUMERIC_STANDARD();
689 while (t-- > linemark && *t == ' ') ;
697 if (arg) { /* repeat until fields exhausted? */
699 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
700 lines += FmLINES(PL_formtarget);
703 if (strnEQ(linemark, linemark - arg, arg))
704 DIE(aTHX_ "Runaway format");
706 FmLINES(PL_formtarget) = lines;
708 RETURNOP(cLISTOP->op_first);
721 while (*s && isSPACE(*s) && s < send)
725 arg = fieldsize - itemsize;
732 if (strnEQ(s," ",3)) {
733 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
744 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
745 FmLINES(PL_formtarget) += lines;
757 if (PL_stack_base + *PL_markstack_ptr == SP) {
759 if (GIMME_V == G_SCALAR)
760 XPUSHs(sv_2mortal(newSViv(0)));
761 RETURNOP(PL_op->op_next->op_next);
763 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
764 pp_pushmark(); /* push dst */
765 pp_pushmark(); /* push src */
766 ENTER; /* enter outer scope */
769 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
771 ENTER; /* enter inner scope */
774 src = PL_stack_base[*PL_markstack_ptr];
779 if (PL_op->op_type == OP_MAPSTART)
780 pp_pushmark(); /* push top */
781 return ((LOGOP*)PL_op->op_next)->op_other;
786 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
792 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
798 /* first, move source pointer to the next item in the source list */
799 ++PL_markstack_ptr[-1];
801 /* if there are new items, push them into the destination list */
803 /* might need to make room back there first */
804 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
805 /* XXX this implementation is very pessimal because the stack
806 * is repeatedly extended for every set of items. Is possible
807 * to do this without any stack extension or copying at all
808 * by maintaining a separate list over which the map iterates
809 * (like foreach does). --gsar */
811 /* everything in the stack after the destination list moves
812 * towards the end the stack by the amount of room needed */
813 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
815 /* items to shift up (accounting for the moved source pointer) */
816 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
818 /* This optimization is by Ben Tilly and it does
819 * things differently from what Sarathy (gsar)
820 * is describing. The downside of this optimization is
821 * that leaves "holes" (uninitialized and hopefully unused areas)
822 * to the Perl stack, but on the other hand this
823 * shouldn't be a problem. If Sarathy's idea gets
824 * implemented, this optimization should become
825 * irrelevant. --jhi */
827 shift = count; /* Avoid shifting too often --Ben Tilly */
832 PL_markstack_ptr[-1] += shift;
833 *PL_markstack_ptr += shift;
837 /* copy the new items down to the destination list */
838 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
840 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
842 LEAVE; /* exit inner scope */
845 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
848 (void)POPMARK; /* pop top */
849 LEAVE; /* exit outer scope */
850 (void)POPMARK; /* pop src */
851 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
852 (void)POPMARK; /* pop dst */
853 SP = PL_stack_base + POPMARK; /* pop original mark */
854 if (gimme == G_SCALAR) {
858 else if (gimme == G_ARRAY)
865 ENTER; /* enter inner scope */
868 /* set $_ to the new source item */
869 src = PL_stack_base[PL_markstack_ptr[-1]];
873 RETURNOP(cLOGOP->op_other);
881 if (GIMME == G_ARRAY)
883 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
884 return cLOGOP->op_other;
893 if (GIMME == G_ARRAY) {
894 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
898 SV *targ = PAD_SV(PL_op->op_targ);
901 if (PL_op->op_private & OPpFLIP_LINENUM) {
902 if (GvIO(PL_last_in_gv)) {
903 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
906 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
907 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
913 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
914 if (PL_op->op_flags & OPf_SPECIAL) {
922 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
935 if (GIMME == G_ARRAY) {
941 if (SvGMAGICAL(left))
943 if (SvGMAGICAL(right))
946 if (SvNIOKp(left) || !SvPOKp(left) ||
947 SvNIOKp(right) || !SvPOKp(right) ||
948 (looks_like_number(left) && *SvPVX(left) != '0' &&
949 looks_like_number(right) && *SvPVX(right) != '0'))
951 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
952 DIE(aTHX_ "Range iterator outside integer range");
963 sv = sv_2mortal(newSViv(i++));
968 SV *final = sv_mortalcopy(right);
970 char *tmps = SvPV(final, len);
972 sv = sv_mortalcopy(left);
974 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
976 if (strEQ(SvPVX(sv),tmps))
978 sv = sv_2mortal(newSVsv(sv));
985 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
989 if (PL_op->op_private & OPpFLIP_LINENUM) {
990 if (GvIO(PL_last_in_gv)) {
991 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
994 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
995 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1003 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1004 sv_catpv(targ, "E0");
1015 S_dopoptolabel(pTHX_ char *label)
1018 register PERL_CONTEXT *cx;
1020 for (i = cxstack_ix; i >= 0; i--) {
1022 switch (CxTYPE(cx)) {
1024 if (ckWARN(WARN_EXITING))
1025 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1029 if (ckWARN(WARN_EXITING))
1030 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1034 if (ckWARN(WARN_EXITING))
1035 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1039 if (ckWARN(WARN_EXITING))
1040 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1044 if (ckWARN(WARN_EXITING))
1045 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1049 if (!cx->blk_loop.label ||
1050 strNE(label, cx->blk_loop.label) ) {
1051 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1052 (long)i, cx->blk_loop.label));
1055 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1063 Perl_dowantarray(pTHX)
1065 I32 gimme = block_gimme();
1066 return (gimme == G_VOID) ? G_SCALAR : gimme;
1070 Perl_block_gimme(pTHX)
1074 cxix = dopoptosub(cxstack_ix);
1078 switch (cxstack[cxix].blk_gimme) {
1086 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1093 Perl_is_lvalue_sub(pTHX)
1097 cxix = dopoptosub(cxstack_ix);
1098 assert(cxix >= 0); /* We should only be called from inside subs */
1100 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1101 return cxstack[cxix].blk_sub.lval;
1107 S_dopoptosub(pTHX_ I32 startingblock)
1109 return dopoptosub_at(cxstack, startingblock);
1113 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1116 register PERL_CONTEXT *cx;
1117 for (i = startingblock; i >= 0; i--) {
1119 switch (CxTYPE(cx)) {
1125 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1133 S_dopoptoeval(pTHX_ I32 startingblock)
1136 register PERL_CONTEXT *cx;
1137 for (i = startingblock; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1143 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1151 S_dopoptoloop(pTHX_ I32 startingblock)
1154 register PERL_CONTEXT *cx;
1155 for (i = startingblock; i >= 0; i--) {
1157 switch (CxTYPE(cx)) {
1159 if (ckWARN(WARN_EXITING))
1160 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1164 if (ckWARN(WARN_EXITING))
1165 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1169 if (ckWARN(WARN_EXITING))
1170 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1174 if (ckWARN(WARN_EXITING))
1175 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1179 if (ckWARN(WARN_EXITING))
1180 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1184 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1192 Perl_dounwind(pTHX_ I32 cxix)
1194 register PERL_CONTEXT *cx;
1197 while (cxstack_ix > cxix) {
1199 cx = &cxstack[cxstack_ix];
1200 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1201 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1202 /* Note: we don't need to restore the base context info till the end. */
1203 switch (CxTYPE(cx)) {
1206 continue; /* not break */
1228 Perl_qerror(pTHX_ SV *err)
1231 sv_catsv(ERRSV, err);
1233 sv_catsv(PL_errors, err);
1235 Perl_warn(aTHX_ "%"SVf, err);
1240 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1248 register PERL_CONTEXT *cx;
1253 if (PL_in_eval & EVAL_KEEPERR) {
1254 static char prefix[] = "\t(in cleanup) ";
1259 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1262 if (*e != *message || strNE(e,message))
1266 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1267 sv_catpvn(err, prefix, sizeof(prefix)-1);
1268 sv_catpvn(err, message, msglen);
1269 if (ckWARN(WARN_MISC)) {
1270 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1271 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1276 sv_setpvn(ERRSV, message, msglen);
1280 message = SvPVx(ERRSV, msglen);
1282 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1283 && PL_curstackinfo->si_prev)
1292 if (cxix < cxstack_ix)
1295 POPBLOCK(cx,PL_curpm);
1296 if (CxTYPE(cx) != CXt_EVAL) {
1297 PerlIO_write(Perl_error_log, "panic: die ", 11);
1298 PerlIO_write(Perl_error_log, message, msglen);
1303 if (gimme == G_SCALAR)
1304 *++newsp = &PL_sv_undef;
1305 PL_stack_sp = newsp;
1309 /* LEAVE could clobber PL_curcop (see save_re_context())
1310 * XXX it might be better to find a way to avoid messing with
1311 * PL_curcop in save_re_context() instead, but this is a more
1312 * minimal fix --GSAR */
1313 PL_curcop = cx->blk_oldcop;
1315 if (optype == OP_REQUIRE) {
1316 char* msg = SvPVx(ERRSV, n_a);
1317 DIE(aTHX_ "%sCompilation failed in require",
1318 *msg ? msg : "Unknown error\n");
1320 return pop_return();
1324 message = SvPVx(ERRSV, msglen);
1326 /* if STDERR is tied, print to it instead */
1327 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1328 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1331 XPUSHs(SvTIED_obj((SV*)io, mg));
1332 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1334 call_method("PRINT", G_SCALAR);
1339 /* SFIO can really mess with your errno */
1342 PerlIO *serr = Perl_error_log;
1344 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1345 (void)PerlIO_flush(serr);
1358 if (SvTRUE(left) != SvTRUE(right))
1370 RETURNOP(cLOGOP->op_other);
1379 RETURNOP(cLOGOP->op_other);
1388 if (!sv || !SvANY(sv)) {
1389 RETURNOP(cLOGOP->op_other);
1392 switch (SvTYPE(sv)) {
1394 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1398 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1402 if (CvROOT(sv) || CvXSUB(sv))
1412 RETURNOP(cLOGOP->op_other);
1418 register I32 cxix = dopoptosub(cxstack_ix);
1419 register PERL_CONTEXT *cx;
1420 register PERL_CONTEXT *ccstack = cxstack;
1421 PERL_SI *top_si = PL_curstackinfo;
1432 /* we may be in a higher stacklevel, so dig down deeper */
1433 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1434 top_si = top_si->si_prev;
1435 ccstack = top_si->si_cxstack;
1436 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1439 if (GIMME != G_ARRAY) {
1445 if (PL_DBsub && cxix >= 0 &&
1446 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1450 cxix = dopoptosub_at(ccstack, cxix - 1);
1453 cx = &ccstack[cxix];
1454 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1455 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1456 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1457 field below is defined for any cx. */
1458 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1459 cx = &ccstack[dbcxix];
1462 stashname = CopSTASHPV(cx->blk_oldcop);
1463 if (GIMME != G_ARRAY) {
1466 PUSHs(&PL_sv_undef);
1469 sv_setpv(TARG, stashname);
1478 PUSHs(&PL_sv_undef);
1480 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1481 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1482 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1485 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1486 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1487 /* So is ccstack[dbcxix]. */
1490 gv_efullname3(sv, cvgv, Nullch);
1491 PUSHs(sv_2mortal(sv));
1492 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1495 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1496 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1500 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1501 PUSHs(sv_2mortal(newSViv(0)));
1503 gimme = (I32)cx->blk_gimme;
1504 if (gimme == G_VOID)
1505 PUSHs(&PL_sv_undef);
1507 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1508 if (CxTYPE(cx) == CXt_EVAL) {
1510 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1511 PUSHs(cx->blk_eval.cur_text);
1515 else if (cx->blk_eval.old_namesv) {
1516 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1519 /* eval BLOCK (try blocks have old_namesv == 0) */
1521 PUSHs(&PL_sv_undef);
1522 PUSHs(&PL_sv_undef);
1526 PUSHs(&PL_sv_undef);
1527 PUSHs(&PL_sv_undef);
1529 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1530 && CopSTASH_eq(PL_curcop, PL_debstash))
1532 AV *ary = cx->blk_sub.argarray;
1533 int off = AvARRAY(ary) - AvALLOC(ary);
1537 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1540 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1543 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1544 av_extend(PL_dbargs, AvFILLp(ary) + off);
1545 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1546 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1548 /* XXX only hints propagated via op_private are currently
1549 * visible (others are not easily accessible, since they
1550 * use the global PL_hints) */
1551 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1552 HINT_PRIVATE_MASK)));
1555 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1557 if (old_warnings == pWARN_NONE ||
1558 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1559 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1560 else if (old_warnings == pWARN_ALL ||
1561 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1562 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1564 mask = newSVsv(old_warnings);
1565 PUSHs(sv_2mortal(mask));
1580 sv_reset(tmps, CopSTASH(PL_curcop));
1590 /* like pp_nextstate, but used instead when the debugger is active */
1594 PL_curcop = (COP*)PL_op;
1595 TAINT_NOT; /* Each statement is presumed innocent */
1596 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1599 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1603 register PERL_CONTEXT *cx;
1604 I32 gimme = G_ARRAY;
1611 DIE(aTHX_ "No DB::DB routine defined");
1613 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1614 /* don't do recursive DB::DB call */
1626 push_return(PL_op->op_next);
1627 PUSHBLOCK(cx, CXt_SUB, SP);
1630 (void)SvREFCNT_inc(cv);
1631 PAD_SET_CUR(CvPADLIST(cv),1);
1632 RETURNOP(CvSTART(cv));
1646 register PERL_CONTEXT *cx;
1647 I32 gimme = GIMME_V;
1649 U32 cxtype = CXt_LOOP;
1657 #ifdef USE_5005THREADS
1658 if (PL_op->op_flags & OPf_SPECIAL) {
1659 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1660 SAVEGENERICSV(*svp);
1664 #endif /* USE_5005THREADS */
1665 if (PL_op->op_targ) {
1666 #ifndef USE_ITHREADS
1667 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1670 SAVEPADSV(PL_op->op_targ);
1671 iterdata = INT2PTR(void*, PL_op->op_targ);
1672 cxtype |= CXp_PADVAR;
1677 svp = &GvSV(gv); /* symbol table variable */
1678 SAVEGENERICSV(*svp);
1681 iterdata = (void*)gv;
1687 PUSHBLOCK(cx, cxtype, SP);
1689 PUSHLOOP(cx, iterdata, MARK);
1691 PUSHLOOP(cx, svp, MARK);
1693 if (PL_op->op_flags & OPf_STACKED) {
1694 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1695 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1697 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1698 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1699 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1700 looks_like_number((SV*)cx->blk_loop.iterary) &&
1701 *SvPVX(cx->blk_loop.iterary) != '0'))
1703 if (SvNV(sv) < IV_MIN ||
1704 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1705 DIE(aTHX_ "Range iterator outside integer range");
1706 cx->blk_loop.iterix = SvIV(sv);
1707 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1710 cx->blk_loop.iterlval = newSVsv(sv);
1714 cx->blk_loop.iterary = PL_curstack;
1715 AvFILLp(PL_curstack) = SP - PL_stack_base;
1716 cx->blk_loop.iterix = MARK - PL_stack_base;
1725 register PERL_CONTEXT *cx;
1726 I32 gimme = GIMME_V;
1732 PUSHBLOCK(cx, CXt_LOOP, SP);
1733 PUSHLOOP(cx, 0, SP);
1741 register PERL_CONTEXT *cx;
1749 newsp = PL_stack_base + cx->blk_loop.resetsp;
1752 if (gimme == G_VOID)
1754 else if (gimme == G_SCALAR) {
1756 *++newsp = sv_mortalcopy(*SP);
1758 *++newsp = &PL_sv_undef;
1762 *++newsp = sv_mortalcopy(*++mark);
1763 TAINT_NOT; /* Each item is independent */
1769 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1770 PL_curpm = newpm; /* ... and pop $1 et al */
1782 register PERL_CONTEXT *cx;
1783 bool popsub2 = FALSE;
1784 bool clear_errsv = FALSE;
1791 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1792 if (cxstack_ix == PL_sortcxix
1793 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1795 if (cxstack_ix > PL_sortcxix)
1796 dounwind(PL_sortcxix);
1797 AvARRAY(PL_curstack)[1] = *SP;
1798 PL_stack_sp = PL_stack_base + 1;
1803 cxix = dopoptosub(cxstack_ix);
1805 DIE(aTHX_ "Can't return outside a subroutine");
1806 if (cxix < cxstack_ix)
1810 switch (CxTYPE(cx)) {
1815 if (!(PL_in_eval & EVAL_KEEPERR))
1821 if (optype == OP_REQUIRE &&
1822 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1824 /* Unassume the success we assumed earlier. */
1825 SV *nsv = cx->blk_eval.old_namesv;
1826 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1827 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1834 DIE(aTHX_ "panic: return");
1838 if (gimme == G_SCALAR) {
1841 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1843 *++newsp = SvREFCNT_inc(*SP);
1848 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1850 *++newsp = sv_mortalcopy(sv);
1855 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1858 *++newsp = sv_mortalcopy(*SP);
1861 *++newsp = &PL_sv_undef;
1863 else if (gimme == G_ARRAY) {
1864 while (++MARK <= SP) {
1865 *++newsp = (popsub2 && SvTEMP(*MARK))
1866 ? *MARK : sv_mortalcopy(*MARK);
1867 TAINT_NOT; /* Each item is independent */
1870 PL_stack_sp = newsp;
1872 /* Stack values are safe: */
1874 POPSUB(cx,sv); /* release CV and @_ ... */
1878 PL_curpm = newpm; /* ... and pop $1 et al */
1884 return pop_return();
1891 register PERL_CONTEXT *cx;
1901 if (PL_op->op_flags & OPf_SPECIAL) {
1902 cxix = dopoptoloop(cxstack_ix);
1904 DIE(aTHX_ "Can't \"last\" outside a loop block");
1907 cxix = dopoptolabel(cPVOP->op_pv);
1909 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1911 if (cxix < cxstack_ix)
1916 switch (CxTYPE(cx)) {
1919 newsp = PL_stack_base + cx->blk_loop.resetsp;
1920 nextop = cx->blk_loop.last_op->op_next;
1924 nextop = pop_return();
1928 nextop = pop_return();
1932 nextop = pop_return();
1935 DIE(aTHX_ "panic: last");
1939 if (gimme == G_SCALAR) {
1941 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1942 ? *SP : sv_mortalcopy(*SP);
1944 *++newsp = &PL_sv_undef;
1946 else if (gimme == G_ARRAY) {
1947 while (++MARK <= SP) {
1948 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1949 ? *MARK : sv_mortalcopy(*MARK);
1950 TAINT_NOT; /* Each item is independent */
1956 /* Stack values are safe: */
1959 POPLOOP(cx); /* release loop vars ... */
1963 POPSUB(cx,sv); /* release CV and @_ ... */
1966 PL_curpm = newpm; /* ... and pop $1 et al */
1976 register PERL_CONTEXT *cx;
1979 if (PL_op->op_flags & OPf_SPECIAL) {
1980 cxix = dopoptoloop(cxstack_ix);
1982 DIE(aTHX_ "Can't \"next\" outside a loop block");
1985 cxix = dopoptolabel(cPVOP->op_pv);
1987 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1989 if (cxix < cxstack_ix)
1992 /* clear off anything above the scope we're re-entering, but
1993 * save the rest until after a possible continue block */
1994 inner = PL_scopestack_ix;
1996 if (PL_scopestack_ix < inner)
1997 leave_scope(PL_scopestack[PL_scopestack_ix]);
1998 return cx->blk_loop.next_op;
2004 register PERL_CONTEXT *cx;
2007 if (PL_op->op_flags & OPf_SPECIAL) {
2008 cxix = dopoptoloop(cxstack_ix);
2010 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2013 cxix = dopoptolabel(cPVOP->op_pv);
2015 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2017 if (cxix < cxstack_ix)
2021 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2022 LEAVE_SCOPE(oldsave);
2023 return cx->blk_loop.redo_op;
2027 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2031 static char too_deep[] = "Target of goto is too deeply nested";
2034 Perl_croak(aTHX_ too_deep);
2035 if (o->op_type == OP_LEAVE ||
2036 o->op_type == OP_SCOPE ||
2037 o->op_type == OP_LEAVELOOP ||
2038 o->op_type == OP_LEAVETRY)
2040 *ops++ = cUNOPo->op_first;
2042 Perl_croak(aTHX_ too_deep);
2045 if (o->op_flags & OPf_KIDS) {
2046 /* First try all the kids at this level, since that's likeliest. */
2047 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2048 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2049 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2052 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2053 if (kid == PL_lastgotoprobe)
2055 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2057 (ops[-1]->op_type != OP_NEXTSTATE &&
2058 ops[-1]->op_type != OP_DBSTATE)))
2060 if ((o = dofindlabel(kid, label, ops, oplimit)))
2079 register PERL_CONTEXT *cx;
2080 #define GOTO_DEPTH 64
2081 OP *enterops[GOTO_DEPTH];
2083 int do_dump = (PL_op->op_type == OP_DUMP);
2084 static char must_have_label[] = "goto must have label";
2087 if (PL_op->op_flags & OPf_STACKED) {
2091 /* This egregious kludge implements goto &subroutine */
2092 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2094 register PERL_CONTEXT *cx;
2095 CV* cv = (CV*)SvRV(sv);
2101 if (!CvROOT(cv) && !CvXSUB(cv)) {
2106 /* autoloaded stub? */
2107 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2109 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2110 GvNAMELEN(gv), FALSE);
2111 if (autogv && (cv = GvCV(autogv)))
2113 tmpstr = sv_newmortal();
2114 gv_efullname3(tmpstr, gv, Nullch);
2115 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2117 DIE(aTHX_ "Goto undefined subroutine");
2120 /* First do some returnish stuff. */
2121 cxix = dopoptosub(cxstack_ix);
2123 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2124 if (cxix < cxstack_ix)
2128 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2130 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2131 /* put @_ back onto stack */
2132 AV* av = cx->blk_sub.argarray;
2134 items = AvFILLp(av) + 1;
2136 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2137 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2138 PL_stack_sp += items;
2139 #ifndef USE_5005THREADS
2140 SvREFCNT_dec(GvAV(PL_defgv));
2141 GvAV(PL_defgv) = cx->blk_sub.savearray;
2142 #endif /* USE_5005THREADS */
2143 /* abandon @_ if it got reified */
2145 (void)sv_2mortal((SV*)av); /* delay until return */
2147 av_extend(av, items-1);
2148 AvFLAGS(av) = AVf_REIFY;
2149 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2152 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2154 #ifdef USE_5005THREADS
2155 av = (AV*)PAD_SVl(0);
2157 av = GvAV(PL_defgv);
2159 items = AvFILLp(av) + 1;
2161 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2162 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2163 PL_stack_sp += items;
2165 if (CxTYPE(cx) == CXt_SUB &&
2166 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2167 SvREFCNT_dec(cx->blk_sub.cv);
2168 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2169 LEAVE_SCOPE(oldsave);
2171 /* Now do some callish stuff. */
2174 #ifdef PERL_XSUB_OLDSTYLE
2175 if (CvOLDSTYLE(cv)) {
2176 I32 (*fp3)(int,int,int);
2181 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2182 items = (*fp3)(CvXSUBANY(cv).any_i32,
2183 mark - PL_stack_base + 1,
2185 SP = PL_stack_base + items;
2188 #endif /* PERL_XSUB_OLDSTYLE */
2193 PL_stack_sp--; /* There is no cv arg. */
2194 /* Push a mark for the start of arglist */
2196 (void)(*CvXSUB(cv))(aTHX_ cv);
2197 /* Pop the current context like a decent sub should */
2198 POPBLOCK(cx, PL_curpm);
2199 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2202 return pop_return();
2205 AV* padlist = CvPADLIST(cv);
2206 if (CxTYPE(cx) == CXt_EVAL) {
2207 PL_in_eval = cx->blk_eval.old_in_eval;
2208 PL_eval_root = cx->blk_eval.old_eval_root;
2209 cx->cx_type = CXt_SUB;
2210 cx->blk_sub.hasargs = 0;
2212 cx->blk_sub.cv = cv;
2213 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2216 if (CvDEPTH(cv) < 2)
2217 (void)SvREFCNT_inc(cv);
2219 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2220 sub_crush_depth(cv);
2221 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2223 #ifdef USE_5005THREADS
2224 if (!cx->blk_sub.hasargs) {
2225 AV* av = (AV*)PAD_SVl(0);
2227 items = AvFILLp(av) + 1;
2229 /* Mark is at the end of the stack. */
2231 Copy(AvARRAY(av), SP + 1, items, SV*);
2236 #endif /* USE_5005THREADS */
2237 PAD_SET_CUR(padlist, CvDEPTH(cv));
2238 #ifndef USE_5005THREADS
2239 if (cx->blk_sub.hasargs)
2240 #endif /* USE_5005THREADS */
2242 AV* av = (AV*)PAD_SVl(0);
2245 #ifndef USE_5005THREADS
2246 cx->blk_sub.savearray = GvAV(PL_defgv);
2247 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2248 #endif /* USE_5005THREADS */
2249 CX_CURPAD_SAVE(cx->blk_sub);
2250 cx->blk_sub.argarray = av;
2253 if (items >= AvMAX(av) + 1) {
2255 if (AvARRAY(av) != ary) {
2256 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2257 SvPVX(av) = (char*)ary;
2259 if (items >= AvMAX(av) + 1) {
2260 AvMAX(av) = items - 1;
2261 Renew(ary,items+1,SV*);
2263 SvPVX(av) = (char*)ary;
2266 Copy(mark,AvARRAY(av),items,SV*);
2267 AvFILLp(av) = items - 1;
2268 assert(!AvREAL(av));
2275 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2277 * We do not care about using sv to call CV;
2278 * it's for informational purposes only.
2280 SV *sv = GvSV(PL_DBsub);
2283 if (PERLDB_SUB_NN) {
2284 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2287 gv_efullname3(sv, CvGV(cv), Nullch);
2290 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2291 PUSHMARK( PL_stack_sp );
2292 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2296 RETURNOP(CvSTART(cv));
2300 label = SvPV(sv,n_a);
2301 if (!(do_dump || *label))
2302 DIE(aTHX_ must_have_label);
2305 else if (PL_op->op_flags & OPf_SPECIAL) {
2307 DIE(aTHX_ must_have_label);
2310 label = cPVOP->op_pv;
2312 if (label && *label) {
2314 bool leaving_eval = FALSE;
2315 PERL_CONTEXT *last_eval_cx = 0;
2319 PL_lastgotoprobe = 0;
2321 for (ix = cxstack_ix; ix >= 0; ix--) {
2323 switch (CxTYPE(cx)) {
2325 leaving_eval = TRUE;
2326 if (CxREALEVAL(cx)) {
2327 gotoprobe = (last_eval_cx ?
2328 last_eval_cx->blk_eval.old_eval_root :
2333 /* else fall through */
2335 gotoprobe = cx->blk_oldcop->op_sibling;
2341 gotoprobe = cx->blk_oldcop->op_sibling;
2343 gotoprobe = PL_main_root;
2346 if (CvDEPTH(cx->blk_sub.cv)) {
2347 gotoprobe = CvROOT(cx->blk_sub.cv);
2353 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2356 DIE(aTHX_ "panic: goto");
2357 gotoprobe = PL_main_root;
2361 retop = dofindlabel(gotoprobe, label,
2362 enterops, enterops + GOTO_DEPTH);
2366 PL_lastgotoprobe = gotoprobe;
2369 DIE(aTHX_ "Can't find label %s", label);
2371 /* if we're leaving an eval, check before we pop any frames
2372 that we're not going to punt, otherwise the error
2375 if (leaving_eval && *enterops && enterops[1]) {
2377 for (i = 1; enterops[i]; i++)
2378 if (enterops[i]->op_type == OP_ENTERITER)
2379 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2382 /* pop unwanted frames */
2384 if (ix < cxstack_ix) {
2391 oldsave = PL_scopestack[PL_scopestack_ix];
2392 LEAVE_SCOPE(oldsave);
2395 /* push wanted frames */
2397 if (*enterops && enterops[1]) {
2399 for (ix = 1; enterops[ix]; ix++) {
2400 PL_op = enterops[ix];
2401 /* Eventually we may want to stack the needed arguments
2402 * for each op. For now, we punt on the hard ones. */
2403 if (PL_op->op_type == OP_ENTERITER)
2404 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2405 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2413 if (!retop) retop = PL_main_start;
2415 PL_restartop = retop;
2416 PL_do_undump = TRUE;
2420 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2421 PL_do_undump = FALSE;
2437 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2439 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2442 PL_exit_flags |= PERL_EXIT_EXPECTED;
2444 PUSHs(&PL_sv_undef);
2452 NV value = SvNVx(GvSV(cCOP->cop_gv));
2453 register I32 match = I_32(value);
2456 if (((NV)match) > value)
2457 --match; /* was fractional--truncate other way */
2459 match -= cCOP->uop.scop.scop_offset;
2462 else if (match > cCOP->uop.scop.scop_max)
2463 match = cCOP->uop.scop.scop_max;
2464 PL_op = cCOP->uop.scop.scop_next[match];
2474 PL_op = PL_op->op_next; /* can't assume anything */
2477 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2478 match -= cCOP->uop.scop.scop_offset;
2481 else if (match > cCOP->uop.scop.scop_max)
2482 match = cCOP->uop.scop.scop_max;
2483 PL_op = cCOP->uop.scop.scop_next[match];
2492 S_save_lines(pTHX_ AV *array, SV *sv)
2494 register char *s = SvPVX(sv);
2495 register char *send = SvPVX(sv) + SvCUR(sv);
2497 register I32 line = 1;
2499 while (s && s < send) {
2500 SV *tmpstr = NEWSV(85,0);
2502 sv_upgrade(tmpstr, SVt_PVMG);
2503 t = strchr(s, '\n');
2509 sv_setpvn(tmpstr, s, t - s);
2510 av_store(array, line++, tmpstr);
2515 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2517 S_docatch_body(pTHX_ va_list args)
2519 return docatch_body();
2524 S_docatch_body(pTHX)
2531 S_docatch(pTHX_ OP *o)
2536 volatile PERL_SI *cursi = PL_curstackinfo;
2540 assert(CATCH_GET == TRUE);
2544 /* Normally, the leavetry at the end of this block of ops will
2545 * pop an op off the return stack and continue there. By setting
2546 * the op to Nullop, we force an exit from the inner runops()
2549 retop = pop_return();
2550 push_return(Nullop);
2552 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2554 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2560 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2566 /* die caught by an inner eval - continue inner loop */
2567 if (PL_restartop && cursi == PL_curstackinfo) {
2568 PL_op = PL_restartop;
2572 /* a die in this eval - continue in outer loop */
2588 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2589 /* sv Text to convert to OP tree. */
2590 /* startop op_free() this to undo. */
2591 /* code Short string id of the caller. */
2593 dSP; /* Make POPBLOCK work. */
2596 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2600 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2601 char *tmpbuf = tbuf;
2607 /* switch to eval mode */
2609 if (PL_curcop == &PL_compiling) {
2610 SAVECOPSTASH_FREE(&PL_compiling);
2611 CopSTASH_set(&PL_compiling, PL_curstash);
2613 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2614 SV *sv = sv_newmortal();
2615 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2616 code, (unsigned long)++PL_evalseq,
2617 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2621 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2622 SAVECOPFILE_FREE(&PL_compiling);
2623 CopFILE_set(&PL_compiling, tmpbuf+2);
2624 SAVECOPLINE(&PL_compiling);
2625 CopLINE_set(&PL_compiling, 1);
2626 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2627 deleting the eval's FILEGV from the stash before gv_check() runs
2628 (i.e. before run-time proper). To work around the coredump that
2629 ensues, we always turn GvMULTI_on for any globals that were
2630 introduced within evals. See force_ident(). GSAR 96-10-12 */
2631 safestr = savepv(tmpbuf);
2632 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2634 #ifdef OP_IN_REGISTER
2639 PL_hints &= HINT_UTF8;
2642 PL_op->op_type = OP_ENTEREVAL;
2643 PL_op->op_flags = 0; /* Avoid uninit warning. */
2644 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2645 PUSHEVAL(cx, 0, Nullgv);
2646 rop = doeval(G_SCALAR, startop);
2647 POPBLOCK(cx,PL_curpm);
2650 (*startop)->op_type = OP_NULL;
2651 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2653 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2655 if (PL_curcop == &PL_compiling)
2656 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2657 #ifdef OP_IN_REGISTER
2663 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2665 S_doeval(pTHX_ int gimme, OP** startop)
2672 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2673 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2679 for (i = cxstack_ix - 1; i >= 0; i--) {
2680 PERL_CONTEXT *cx = &cxstack[i];
2681 if (CxTYPE(cx) == CXt_EVAL)
2683 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2684 caller = cx->blk_sub.cv;
2689 SAVESPTR(PL_compcv);
2690 PL_compcv = (CV*)NEWSV(1104,0);
2691 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2692 CvEVAL_on(PL_compcv);
2693 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2694 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2696 #ifdef USE_5005THREADS
2697 CvOWNER(PL_compcv) = 0;
2698 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2699 MUTEX_INIT(CvMUTEXP(PL_compcv));
2700 #endif /* USE_5005THREADS */
2702 /* set up a scratch pad */
2704 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2707 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2709 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2712 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2714 /* make sure we compile in the right package */
2716 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2717 SAVESPTR(PL_curstash);
2718 PL_curstash = CopSTASH(PL_curcop);
2720 SAVESPTR(PL_beginav);
2721 PL_beginav = newAV();
2722 SAVEFREESV(PL_beginav);
2723 SAVEI32(PL_error_count);
2725 /* try to compile it */
2727 PL_eval_root = Nullop;
2729 PL_curcop = &PL_compiling;
2730 PL_curcop->cop_arybase = 0;
2731 if (saveop && saveop->op_flags & OPf_SPECIAL)
2732 PL_in_eval |= EVAL_KEEPERR;
2735 if (yyparse() || PL_error_count || !PL_eval_root) {
2739 I32 optype = 0; /* Might be reset by POPEVAL. */
2744 op_free(PL_eval_root);
2745 PL_eval_root = Nullop;
2747 SP = PL_stack_base + POPMARK; /* pop original mark */
2749 POPBLOCK(cx,PL_curpm);
2755 if (optype == OP_REQUIRE) {
2756 char* msg = SvPVx(ERRSV, n_a);
2757 DIE(aTHX_ "%sCompilation failed in require",
2758 *msg ? msg : "Unknown error\n");
2761 char* msg = SvPVx(ERRSV, n_a);
2763 POPBLOCK(cx,PL_curpm);
2765 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2766 (*msg ? msg : "Unknown error\n"));
2768 #ifdef USE_5005THREADS
2769 MUTEX_LOCK(&PL_eval_mutex);
2771 COND_SIGNAL(&PL_eval_cond);
2772 MUTEX_UNLOCK(&PL_eval_mutex);
2773 #endif /* USE_5005THREADS */
2776 CopLINE_set(&PL_compiling, 0);
2778 *startop = PL_eval_root;
2779 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2780 CvOUTSIDE(PL_compcv) = Nullcv;
2782 SAVEFREEOP(PL_eval_root);
2784 scalarvoid(PL_eval_root);
2785 else if (gimme & G_ARRAY)
2788 scalar(PL_eval_root);
2790 DEBUG_x(dump_eval());
2792 /* Register with debugger: */
2793 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2794 CV *cv = get_cv("DB::postponed", FALSE);
2798 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2800 call_sv((SV*)cv, G_DISCARD);
2804 /* compiled okay, so do it */
2806 CvDEPTH(PL_compcv) = 1;
2807 SP = PL_stack_base + POPMARK; /* pop original mark */
2808 PL_op = saveop; /* The caller may need it. */
2809 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2810 #ifdef USE_5005THREADS
2811 MUTEX_LOCK(&PL_eval_mutex);
2813 COND_SIGNAL(&PL_eval_cond);
2814 MUTEX_UNLOCK(&PL_eval_mutex);
2815 #endif /* USE_5005THREADS */
2817 RETURNOP(PL_eval_start);
2821 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2823 STRLEN namelen = strlen(name);
2826 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2827 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2828 char *pmc = SvPV_nolen(pmcsv);
2831 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2832 fp = PerlIO_open(name, mode);
2835 if (PerlLIO_stat(name, &pmstat) < 0 ||
2836 pmstat.st_mtime < pmcstat.st_mtime)
2838 fp = PerlIO_open(pmc, mode);
2841 fp = PerlIO_open(name, mode);
2844 SvREFCNT_dec(pmcsv);
2847 fp = PerlIO_open(name, mode);
2855 register PERL_CONTEXT *cx;
2859 char *tryname = Nullch;
2860 SV *namesv = Nullsv;
2862 I32 gimme = GIMME_V;
2863 PerlIO *tryrsfp = 0;
2865 int filter_has_file = 0;
2866 GV *filter_child_proc = 0;
2867 SV *filter_state = 0;
2874 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2875 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2876 UV rev = 0, ver = 0, sver = 0;
2878 U8 *s = (U8*)SvPVX(sv);
2879 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2881 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2884 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2887 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2890 if (PERL_REVISION < rev
2891 || (PERL_REVISION == rev
2892 && (PERL_VERSION < ver
2893 || (PERL_VERSION == ver
2894 && PERL_SUBVERSION < sver))))
2896 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2897 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2898 PERL_VERSION, PERL_SUBVERSION);
2900 if (ckWARN(WARN_PORTABLE))
2901 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2902 "v-string in use/require non-portable");
2905 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2906 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2907 + ((NV)PERL_SUBVERSION/(NV)1000000)
2908 + 0.00000099 < SvNV(sv))
2912 NV nver = (nrev - rev) * 1000;
2913 UV ver = (UV)(nver + 0.0009);
2914 NV nsver = (nver - ver) * 1000;
2915 UV sver = (UV)(nsver + 0.0009);
2917 /* help out with the "use 5.6" confusion */
2918 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2919 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2920 " (did you mean v%"UVuf".%03"UVuf"?)--"
2921 "this is only v%d.%d.%d, stopped",
2922 rev, ver, sver, rev, ver/100,
2923 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2926 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2927 "this is only v%d.%d.%d, stopped",
2928 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2935 name = SvPV(sv, len);
2936 if (!(name && len > 0 && *name))
2937 DIE(aTHX_ "Null filename used");
2938 TAINT_PROPER("require");
2939 if (PL_op->op_type == OP_REQUIRE &&
2940 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2941 *svp != &PL_sv_undef)
2944 /* prepare to compile file */
2946 if (path_is_absolute(name)) {
2948 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2950 #ifdef MACOS_TRADITIONAL
2954 MacPerl_CanonDir(name, newname, 1);
2955 if (path_is_absolute(newname)) {
2957 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2962 AV *ar = GvAVn(PL_incgv);
2966 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2969 namesv = NEWSV(806, 0);
2970 for (i = 0; i <= AvFILL(ar); i++) {
2971 SV *dirsv = *av_fetch(ar, i, TRUE);
2977 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2978 && !sv_isobject(loader))
2980 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2983 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2984 PTR2UV(SvRV(dirsv)), name);
2985 tryname = SvPVX(namesv);
2996 if (sv_isobject(loader))
2997 count = call_method("INC", G_ARRAY);
2999 count = call_sv(loader, G_ARRAY);
3009 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3013 if (SvTYPE(arg) == SVt_PVGV) {
3014 IO *io = GvIO((GV *)arg);
3019 tryrsfp = IoIFP(io);
3020 if (IoTYPE(io) == IoTYPE_PIPE) {
3021 /* reading from a child process doesn't
3022 nest -- when returning from reading
3023 the inner module, the outer one is
3024 unreadable (closed?) I've tried to
3025 save the gv to manage the lifespan of
3026 the pipe, but this didn't help. XXX */
3027 filter_child_proc = (GV *)arg;
3028 (void)SvREFCNT_inc(filter_child_proc);
3031 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3032 PerlIO_close(IoOFP(io));
3044 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3046 (void)SvREFCNT_inc(filter_sub);
3049 filter_state = SP[i];
3050 (void)SvREFCNT_inc(filter_state);
3054 tryrsfp = PerlIO_open("/dev/null",
3069 filter_has_file = 0;
3070 if (filter_child_proc) {
3071 SvREFCNT_dec(filter_child_proc);
3072 filter_child_proc = 0;
3075 SvREFCNT_dec(filter_state);
3079 SvREFCNT_dec(filter_sub);
3084 if (!path_is_absolute(name)
3085 #ifdef MACOS_TRADITIONAL
3086 /* We consider paths of the form :a:b ambiguous and interpret them first
3087 as global then as local
3089 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3092 char *dir = SvPVx(dirsv, n_a);
3093 #ifdef MACOS_TRADITIONAL
3097 MacPerl_CanonDir(name, buf2, 1);
3098 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3102 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3104 sv_setpv(namesv, unixdir);
3105 sv_catpv(namesv, unixname);
3107 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3110 TAINT_PROPER("require");
3111 tryname = SvPVX(namesv);
3112 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3114 if (tryname[0] == '.' && tryname[1] == '/')
3123 SAVECOPFILE_FREE(&PL_compiling);
3124 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3125 SvREFCNT_dec(namesv);
3127 if (PL_op->op_type == OP_REQUIRE) {
3128 char *msgstr = name;
3129 if (namesv) { /* did we lookup @INC? */
3130 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3131 SV *dirmsgsv = NEWSV(0, 0);
3132 AV *ar = GvAVn(PL_incgv);
3134 sv_catpvn(msg, " in @INC", 8);
3135 if (instr(SvPVX(msg), ".h "))
3136 sv_catpv(msg, " (change .h to .ph maybe?)");
3137 if (instr(SvPVX(msg), ".ph "))
3138 sv_catpv(msg, " (did you run h2ph?)");
3139 sv_catpv(msg, " (@INC contains:");
3140 for (i = 0; i <= AvFILL(ar); i++) {
3141 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3142 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3143 sv_catsv(msg, dirmsgsv);
3145 sv_catpvn(msg, ")", 1);
3146 SvREFCNT_dec(dirmsgsv);
3147 msgstr = SvPV_nolen(msg);
3149 DIE(aTHX_ "Can't locate %s", msgstr);
3155 SETERRNO(0, SS_NORMAL);
3157 /* Assume success here to prevent recursive requirement. */
3159 /* Check whether a hook in @INC has already filled %INC */
3160 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3161 (void)hv_store(GvHVn(PL_incgv), name, len,
3162 (hook_sv ? SvREFCNT_inc(hook_sv)
3163 : newSVpv(CopFILE(&PL_compiling), 0)),
3169 lex_start(sv_2mortal(newSVpvn("",0)));
3170 SAVEGENERICSV(PL_rsfp_filters);
3171 PL_rsfp_filters = Nullav;
3176 SAVESPTR(PL_compiling.cop_warnings);
3177 if (PL_dowarn & G_WARN_ALL_ON)
3178 PL_compiling.cop_warnings = pWARN_ALL ;
3179 else if (PL_dowarn & G_WARN_ALL_OFF)
3180 PL_compiling.cop_warnings = pWARN_NONE ;
3181 else if (PL_taint_warn)
3182 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3184 PL_compiling.cop_warnings = pWARN_STD ;
3185 SAVESPTR(PL_compiling.cop_io);
3186 PL_compiling.cop_io = Nullsv;
3188 if (filter_sub || filter_child_proc) {
3189 SV *datasv = filter_add(run_user_filter, Nullsv);
3190 IoLINES(datasv) = filter_has_file;
3191 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3192 IoTOP_GV(datasv) = (GV *)filter_state;
3193 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3196 /* switch to eval mode */
3197 push_return(PL_op->op_next);
3198 PUSHBLOCK(cx, CXt_EVAL, SP);
3199 PUSHEVAL(cx, name, Nullgv);
3201 SAVECOPLINE(&PL_compiling);
3202 CopLINE_set(&PL_compiling, 0);
3205 #ifdef USE_5005THREADS
3206 MUTEX_LOCK(&PL_eval_mutex);
3207 if (PL_eval_owner && PL_eval_owner != thr)
3208 while (PL_eval_owner)
3209 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3210 PL_eval_owner = thr;
3211 MUTEX_UNLOCK(&PL_eval_mutex);
3212 #endif /* USE_5005THREADS */
3214 /* Store and reset encoding. */
3215 encoding = PL_encoding;
3216 PL_encoding = Nullsv;
3218 op = DOCATCH(doeval(gimme, NULL));
3220 /* Restore encoding. */
3221 PL_encoding = encoding;
3228 return pp_require();
3234 register PERL_CONTEXT *cx;
3236 I32 gimme = GIMME_V, was = PL_sub_generation;
3237 char tbuf[TYPE_DIGITS(long) + 12];
3238 char *tmpbuf = tbuf;
3245 TAINT_PROPER("eval");
3251 /* switch to eval mode */
3253 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3254 SV *sv = sv_newmortal();
3255 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3256 (unsigned long)++PL_evalseq,
3257 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3261 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3262 SAVECOPFILE_FREE(&PL_compiling);
3263 CopFILE_set(&PL_compiling, tmpbuf+2);
3264 SAVECOPLINE(&PL_compiling);
3265 CopLINE_set(&PL_compiling, 1);
3266 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3267 deleting the eval's FILEGV from the stash before gv_check() runs
3268 (i.e. before run-time proper). To work around the coredump that
3269 ensues, we always turn GvMULTI_on for any globals that were
3270 introduced within evals. See force_ident(). GSAR 96-10-12 */
3271 safestr = savepv(tmpbuf);
3272 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3274 PL_hints = PL_op->op_targ;
3275 SAVESPTR(PL_compiling.cop_warnings);
3276 if (specialWARN(PL_curcop->cop_warnings))
3277 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3279 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3280 SAVEFREESV(PL_compiling.cop_warnings);
3282 SAVESPTR(PL_compiling.cop_io);
3283 if (specialCopIO(PL_curcop->cop_io))
3284 PL_compiling.cop_io = PL_curcop->cop_io;
3286 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3287 SAVEFREESV(PL_compiling.cop_io);
3290 push_return(PL_op->op_next);
3291 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3292 PUSHEVAL(cx, 0, Nullgv);
3294 /* prepare to compile string */
3296 if (PERLDB_LINE && PL_curstash != PL_debstash)
3297 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3299 #ifdef USE_5005THREADS
3300 MUTEX_LOCK(&PL_eval_mutex);
3301 if (PL_eval_owner && PL_eval_owner != thr)
3302 while (PL_eval_owner)
3303 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3304 PL_eval_owner = thr;
3305 MUTEX_UNLOCK(&PL_eval_mutex);
3306 #endif /* USE_5005THREADS */
3307 ret = doeval(gimme, NULL);
3308 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3309 && ret != PL_op->op_next) { /* Successive compilation. */
3310 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3312 return DOCATCH(ret);
3322 register PERL_CONTEXT *cx;
3324 U8 save_flags = PL_op -> op_flags;
3329 retop = pop_return();
3332 if (gimme == G_VOID)
3334 else if (gimme == G_SCALAR) {
3337 if (SvFLAGS(TOPs) & SVs_TEMP)
3340 *MARK = sv_mortalcopy(TOPs);
3344 *MARK = &PL_sv_undef;
3349 /* in case LEAVE wipes old return values */
3350 for (mark = newsp + 1; mark <= SP; mark++) {
3351 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3352 *mark = sv_mortalcopy(*mark);
3353 TAINT_NOT; /* Each item is independent */
3357 PL_curpm = newpm; /* Don't pop $1 et al till now */
3360 assert(CvDEPTH(PL_compcv) == 1);
3362 CvDEPTH(PL_compcv) = 0;
3365 if (optype == OP_REQUIRE &&
3366 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3368 /* Unassume the success we assumed earlier. */
3369 SV *nsv = cx->blk_eval.old_namesv;
3370 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3371 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3372 /* die_where() did LEAVE, or we won't be here */
3376 if (!(save_flags & OPf_SPECIAL))
3386 register PERL_CONTEXT *cx;
3387 I32 gimme = GIMME_V;
3392 push_return(cLOGOP->op_other->op_next);
3393 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3396 PL_in_eval = EVAL_INEVAL;
3399 return DOCATCH(PL_op->op_next);
3410 register PERL_CONTEXT *cx;
3415 retop = pop_return();
3418 if (gimme == G_VOID)
3420 else if (gimme == G_SCALAR) {
3423 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3426 *MARK = sv_mortalcopy(TOPs);
3430 *MARK = &PL_sv_undef;
3435 /* in case LEAVE wipes old return values */
3436 for (mark = newsp + 1; mark <= SP; mark++) {
3437 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3438 *mark = sv_mortalcopy(*mark);
3439 TAINT_NOT; /* Each item is independent */
3443 PL_curpm = newpm; /* Don't pop $1 et al till now */
3451 S_doparseform(pTHX_ SV *sv)
3454 register char *s = SvPV_force(sv, len);
3455 register char *send = s + len;
3456 register char *base = Nullch;
3457 register I32 skipspaces = 0;
3458 bool noblank = FALSE;
3459 bool repeat = FALSE;
3460 bool postspace = FALSE;
3468 Perl_croak(aTHX_ "Null picture in formline");
3470 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3475 *fpc++ = FF_LINEMARK;
3476 noblank = repeat = FALSE;
3494 case ' ': case '\t':
3505 *fpc++ = FF_LITERAL;
3513 *fpc++ = (U16)skipspaces;
3517 *fpc++ = FF_NEWLINE;
3521 arg = fpc - linepc + 1;
3528 *fpc++ = FF_LINEMARK;
3529 noblank = repeat = FALSE;
3538 ischop = s[-1] == '^';
3544 arg = (s - base) - 1;
3546 *fpc++ = FF_LITERAL;
3555 *fpc++ = FF_LINEGLOB;
3557 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3558 arg = ischop ? 512 : 0;
3568 arg |= 256 + (s - f);
3570 *fpc++ = s - base; /* fieldsize for FETCH */
3571 *fpc++ = FF_DECIMAL;
3574 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3575 arg = ischop ? 512 : 0;
3577 s++; /* skip the '0' first */
3586 arg |= 256 + (s - f);
3588 *fpc++ = s - base; /* fieldsize for FETCH */
3589 *fpc++ = FF_0DECIMAL;
3594 bool ismore = FALSE;
3597 while (*++s == '>') ;
3598 prespace = FF_SPACE;
3600 else if (*s == '|') {
3601 while (*++s == '|') ;
3602 prespace = FF_HALFSPACE;
3607 while (*++s == '<') ;
3610 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3614 *fpc++ = s - base; /* fieldsize for FETCH */
3616 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3619 *fpc++ = (U16)prespace;
3634 { /* need to jump to the next word */
3636 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3637 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3638 s = SvPVX(sv) + SvCUR(sv) + z;
3640 Copy(fops, s, arg, U16);
3642 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3647 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3649 SV *datasv = FILTER_DATA(idx);
3650 int filter_has_file = IoLINES(datasv);
3651 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3652 SV *filter_state = (SV *)IoTOP_GV(datasv);
3653 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3656 /* I was having segfault trouble under Linux 2.2.5 after a
3657 parse error occured. (Had to hack around it with a test
3658 for PL_error_count == 0.) Solaris doesn't segfault --
3659 not sure where the trouble is yet. XXX */
3661 if (filter_has_file) {
3662 len = FILTER_READ(idx+1, buf_sv, maxlen);
3665 if (filter_sub && len >= 0) {
3676 PUSHs(sv_2mortal(newSViv(maxlen)));
3678 PUSHs(filter_state);
3681 count = call_sv(filter_sub, G_SCALAR);
3697 IoLINES(datasv) = 0;
3698 if (filter_child_proc) {
3699 SvREFCNT_dec(filter_child_proc);
3700 IoFMT_GV(datasv) = Nullgv;
3703 SvREFCNT_dec(filter_state);
3704 IoTOP_GV(datasv) = Nullgv;
3707 SvREFCNT_dec(filter_sub);
3708 IoBOTTOM_GV(datasv) = Nullgv;
3710 filter_del(run_user_filter);
3716 /* perhaps someone can come up with a better name for
3717 this? it is not really "absolute", per se ... */
3719 S_path_is_absolute(pTHX_ char *name)
3721 if (PERL_FILE_IS_ABSOLUTE(name)
3722 #ifdef MACOS_TRADITIONAL
3725 || (*name == '.' && (name[1] == '/' ||
3726 (name[1] == '.' && name[2] == '/'))))