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 != 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_ WARN_SYNTAX, "Not enough format arguments");
404 item = s = SvPV(sv, len);
407 itemsize = sv_len_utf8(sv);
408 if (itemsize != 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 != 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) {
904 && (gp_io = GvIO(PL_last_in_gv))
905 && SvIV(sv) == (IV)IoLINES(gp_io);
910 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
911 if (PL_op->op_flags & OPf_SPECIAL) {
919 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
932 if (GIMME == G_ARRAY) {
938 if (SvGMAGICAL(left))
940 if (SvGMAGICAL(right))
943 if (SvNIOKp(left) || !SvPOKp(left) ||
944 SvNIOKp(right) || !SvPOKp(right) ||
945 (looks_like_number(left) && *SvPVX(left) != '0' &&
946 looks_like_number(right) && *SvPVX(right) != '0'))
948 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
949 DIE(aTHX_ "Range iterator outside integer range");
960 sv = sv_2mortal(newSViv(i++));
965 SV *final = sv_mortalcopy(right);
967 char *tmps = SvPV(final, len);
969 sv = sv_mortalcopy(left);
971 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
973 if (strEQ(SvPVX(sv),tmps))
975 sv = sv_2mortal(newSVsv(sv));
982 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
984 if ((PL_op->op_private & OPpFLIP_LINENUM)
985 ? (GvIO(PL_last_in_gv)
986 && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
988 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
989 sv_catpv(targ, "E0");
1000 S_dopoptolabel(pTHX_ char *label)
1003 register PERL_CONTEXT *cx;
1005 for (i = cxstack_ix; i >= 0; i--) {
1007 switch (CxTYPE(cx)) {
1009 if (ckWARN(WARN_EXITING))
1010 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1014 if (ckWARN(WARN_EXITING))
1015 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1019 if (ckWARN(WARN_EXITING))
1020 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1024 if (ckWARN(WARN_EXITING))
1025 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1029 if (ckWARN(WARN_EXITING))
1030 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1034 if (!cx->blk_loop.label ||
1035 strNE(label, cx->blk_loop.label) ) {
1036 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1037 (long)i, cx->blk_loop.label));
1040 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1048 Perl_dowantarray(pTHX)
1050 I32 gimme = block_gimme();
1051 return (gimme == G_VOID) ? G_SCALAR : gimme;
1055 Perl_block_gimme(pTHX)
1059 cxix = dopoptosub(cxstack_ix);
1063 switch (cxstack[cxix].blk_gimme) {
1071 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1078 Perl_is_lvalue_sub(pTHX)
1082 cxix = dopoptosub(cxstack_ix);
1083 assert(cxix >= 0); /* We should only be called from inside subs */
1085 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1086 return cxstack[cxix].blk_sub.lval;
1092 S_dopoptosub(pTHX_ I32 startingblock)
1094 return dopoptosub_at(cxstack, startingblock);
1098 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1101 register PERL_CONTEXT *cx;
1102 for (i = startingblock; i >= 0; i--) {
1104 switch (CxTYPE(cx)) {
1110 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1118 S_dopoptoeval(pTHX_ I32 startingblock)
1121 register PERL_CONTEXT *cx;
1122 for (i = startingblock; i >= 0; i--) {
1124 switch (CxTYPE(cx)) {
1128 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1136 S_dopoptoloop(pTHX_ I32 startingblock)
1139 register PERL_CONTEXT *cx;
1140 for (i = startingblock; i >= 0; i--) {
1142 switch (CxTYPE(cx)) {
1144 if (ckWARN(WARN_EXITING))
1145 Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s",
1149 if (ckWARN(WARN_EXITING))
1150 Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s",
1154 if (ckWARN(WARN_EXITING))
1155 Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s",
1159 if (ckWARN(WARN_EXITING))
1160 Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s",
1164 if (ckWARN(WARN_EXITING))
1165 Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s",
1169 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1177 Perl_dounwind(pTHX_ I32 cxix)
1179 register PERL_CONTEXT *cx;
1182 while (cxstack_ix > cxix) {
1184 cx = &cxstack[cxstack_ix];
1185 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1186 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1187 /* Note: we don't need to restore the base context info till the end. */
1188 switch (CxTYPE(cx)) {
1191 continue; /* not break */
1213 Perl_qerror(pTHX_ SV *err)
1216 sv_catsv(ERRSV, err);
1218 sv_catsv(PL_errors, err);
1220 Perl_warn(aTHX_ "%"SVf, err);
1225 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1233 register PERL_CONTEXT *cx;
1238 if (PL_in_eval & EVAL_KEEPERR) {
1239 static char prefix[] = "\t(in cleanup) ";
1244 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1247 if (*e != *message || strNE(e,message))
1251 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1252 sv_catpvn(err, prefix, sizeof(prefix)-1);
1253 sv_catpvn(err, message, msglen);
1254 if (ckWARN(WARN_MISC)) {
1255 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1256 Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
1261 sv_setpvn(ERRSV, message, msglen);
1265 message = SvPVx(ERRSV, msglen);
1267 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1268 && PL_curstackinfo->si_prev)
1277 if (cxix < cxstack_ix)
1280 POPBLOCK(cx,PL_curpm);
1281 if (CxTYPE(cx) != CXt_EVAL) {
1282 PerlIO_write(Perl_error_log, "panic: die ", 11);
1283 PerlIO_write(Perl_error_log, message, msglen);
1288 if (gimme == G_SCALAR)
1289 *++newsp = &PL_sv_undef;
1290 PL_stack_sp = newsp;
1294 /* LEAVE could clobber PL_curcop (see save_re_context())
1295 * XXX it might be better to find a way to avoid messing with
1296 * PL_curcop in save_re_context() instead, but this is a more
1297 * minimal fix --GSAR */
1298 PL_curcop = cx->blk_oldcop;
1300 if (optype == OP_REQUIRE) {
1301 char* msg = SvPVx(ERRSV, n_a);
1302 DIE(aTHX_ "%sCompilation failed in require",
1303 *msg ? msg : "Unknown error\n");
1305 return pop_return();
1309 message = SvPVx(ERRSV, msglen);
1311 /* if STDERR is tied, print to it instead */
1312 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1313 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1316 XPUSHs(SvTIED_obj((SV*)io, mg));
1317 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1319 call_method("PRINT", G_SCALAR);
1324 /* SFIO can really mess with your errno */
1327 PerlIO *serr = Perl_error_log;
1329 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1330 (void)PerlIO_flush(serr);
1343 if (SvTRUE(left) != SvTRUE(right))
1355 RETURNOP(cLOGOP->op_other);
1364 RETURNOP(cLOGOP->op_other);
1370 register I32 cxix = dopoptosub(cxstack_ix);
1371 register PERL_CONTEXT *cx;
1372 register PERL_CONTEXT *ccstack = cxstack;
1373 PERL_SI *top_si = PL_curstackinfo;
1384 /* we may be in a higher stacklevel, so dig down deeper */
1385 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1386 top_si = top_si->si_prev;
1387 ccstack = top_si->si_cxstack;
1388 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1391 if (GIMME != G_ARRAY) {
1397 if (PL_DBsub && cxix >= 0 &&
1398 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1402 cxix = dopoptosub_at(ccstack, cxix - 1);
1405 cx = &ccstack[cxix];
1406 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1407 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1408 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1409 field below is defined for any cx. */
1410 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1411 cx = &ccstack[dbcxix];
1414 stashname = CopSTASHPV(cx->blk_oldcop);
1415 if (GIMME != G_ARRAY) {
1418 PUSHs(&PL_sv_undef);
1421 sv_setpv(TARG, stashname);
1430 PUSHs(&PL_sv_undef);
1432 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1433 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1434 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1437 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1438 /* So is ccstack[dbcxix]. */
1440 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1441 PUSHs(sv_2mortal(sv));
1442 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1445 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1446 PUSHs(sv_2mortal(newSViv(0)));
1448 gimme = (I32)cx->blk_gimme;
1449 if (gimme == G_VOID)
1450 PUSHs(&PL_sv_undef);
1452 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1453 if (CxTYPE(cx) == CXt_EVAL) {
1455 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1456 PUSHs(cx->blk_eval.cur_text);
1460 else if (cx->blk_eval.old_namesv) {
1461 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1464 /* eval BLOCK (try blocks have old_namesv == 0) */
1466 PUSHs(&PL_sv_undef);
1467 PUSHs(&PL_sv_undef);
1471 PUSHs(&PL_sv_undef);
1472 PUSHs(&PL_sv_undef);
1474 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1475 && CopSTASH_eq(PL_curcop, PL_debstash))
1477 AV *ary = cx->blk_sub.argarray;
1478 int off = AvARRAY(ary) - AvALLOC(ary);
1482 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1485 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1488 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1489 av_extend(PL_dbargs, AvFILLp(ary) + off);
1490 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1491 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1493 /* XXX only hints propagated via op_private are currently
1494 * visible (others are not easily accessible, since they
1495 * use the global PL_hints) */
1496 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1497 HINT_PRIVATE_MASK)));
1500 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1502 if (old_warnings == pWARN_NONE ||
1503 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1504 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1505 else if (old_warnings == pWARN_ALL ||
1506 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1507 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1509 mask = newSVsv(old_warnings);
1510 PUSHs(sv_2mortal(mask));
1525 sv_reset(tmps, CopSTASH(PL_curcop));
1537 PL_curcop = (COP*)PL_op;
1538 TAINT_NOT; /* Each statement is presumed innocent */
1539 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1542 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1546 register PERL_CONTEXT *cx;
1547 I32 gimme = G_ARRAY;
1554 DIE(aTHX_ "No DB::DB routine defined");
1556 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1557 /* don't do recursive DB::DB call */
1569 push_return(PL_op->op_next);
1570 PUSHBLOCK(cx, CXt_SUB, SP);
1573 (void)SvREFCNT_inc(cv);
1574 SAVEVPTR(PL_curpad);
1575 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1576 RETURNOP(CvSTART(cv));
1590 register PERL_CONTEXT *cx;
1591 I32 gimme = GIMME_V;
1593 U32 cxtype = CXt_LOOP;
1601 #ifdef USE_5005THREADS
1602 if (PL_op->op_flags & OPf_SPECIAL) {
1603 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1604 SAVEGENERICSV(*svp);
1608 #endif /* USE_5005THREADS */
1609 if (PL_op->op_targ) {
1610 #ifndef USE_ITHREADS
1611 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1614 SAVEPADSV(PL_op->op_targ);
1615 iterdata = INT2PTR(void*, PL_op->op_targ);
1616 cxtype |= CXp_PADVAR;
1621 svp = &GvSV(gv); /* symbol table variable */
1622 SAVEGENERICSV(*svp);
1625 iterdata = (void*)gv;
1631 PUSHBLOCK(cx, cxtype, SP);
1633 PUSHLOOP(cx, iterdata, MARK);
1635 PUSHLOOP(cx, svp, MARK);
1637 if (PL_op->op_flags & OPf_STACKED) {
1638 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1639 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1641 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1642 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1643 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1644 looks_like_number((SV*)cx->blk_loop.iterary) &&
1645 *SvPVX(cx->blk_loop.iterary) != '0'))
1647 if (SvNV(sv) < IV_MIN ||
1648 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1649 DIE(aTHX_ "Range iterator outside integer range");
1650 cx->blk_loop.iterix = SvIV(sv);
1651 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1654 cx->blk_loop.iterlval = newSVsv(sv);
1658 cx->blk_loop.iterary = PL_curstack;
1659 AvFILLp(PL_curstack) = SP - PL_stack_base;
1660 cx->blk_loop.iterix = MARK - PL_stack_base;
1669 register PERL_CONTEXT *cx;
1670 I32 gimme = GIMME_V;
1676 PUSHBLOCK(cx, CXt_LOOP, SP);
1677 PUSHLOOP(cx, 0, SP);
1685 register PERL_CONTEXT *cx;
1693 newsp = PL_stack_base + cx->blk_loop.resetsp;
1696 if (gimme == G_VOID)
1698 else if (gimme == G_SCALAR) {
1700 *++newsp = sv_mortalcopy(*SP);
1702 *++newsp = &PL_sv_undef;
1706 *++newsp = sv_mortalcopy(*++mark);
1707 TAINT_NOT; /* Each item is independent */
1713 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1714 PL_curpm = newpm; /* ... and pop $1 et al */
1726 register PERL_CONTEXT *cx;
1727 bool popsub2 = FALSE;
1728 bool clear_errsv = FALSE;
1735 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1736 if (cxstack_ix == PL_sortcxix
1737 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1739 if (cxstack_ix > PL_sortcxix)
1740 dounwind(PL_sortcxix);
1741 AvARRAY(PL_curstack)[1] = *SP;
1742 PL_stack_sp = PL_stack_base + 1;
1747 cxix = dopoptosub(cxstack_ix);
1749 DIE(aTHX_ "Can't return outside a subroutine");
1750 if (cxix < cxstack_ix)
1754 switch (CxTYPE(cx)) {
1759 if (!(PL_in_eval & EVAL_KEEPERR))
1765 if (optype == OP_REQUIRE &&
1766 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1768 /* Unassume the success we assumed earlier. */
1769 SV *nsv = cx->blk_eval.old_namesv;
1770 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1771 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1778 DIE(aTHX_ "panic: return");
1782 if (gimme == G_SCALAR) {
1785 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1787 *++newsp = SvREFCNT_inc(*SP);
1792 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1794 *++newsp = sv_mortalcopy(sv);
1799 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1802 *++newsp = sv_mortalcopy(*SP);
1805 *++newsp = &PL_sv_undef;
1807 else if (gimme == G_ARRAY) {
1808 while (++MARK <= SP) {
1809 *++newsp = (popsub2 && SvTEMP(*MARK))
1810 ? *MARK : sv_mortalcopy(*MARK);
1811 TAINT_NOT; /* Each item is independent */
1814 PL_stack_sp = newsp;
1816 /* Stack values are safe: */
1818 POPSUB(cx,sv); /* release CV and @_ ... */
1822 PL_curpm = newpm; /* ... and pop $1 et al */
1828 return pop_return();
1835 register PERL_CONTEXT *cx;
1845 if (PL_op->op_flags & OPf_SPECIAL) {
1846 cxix = dopoptoloop(cxstack_ix);
1848 DIE(aTHX_ "Can't \"last\" outside a loop block");
1851 cxix = dopoptolabel(cPVOP->op_pv);
1853 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1855 if (cxix < cxstack_ix)
1860 switch (CxTYPE(cx)) {
1863 newsp = PL_stack_base + cx->blk_loop.resetsp;
1864 nextop = cx->blk_loop.last_op->op_next;
1868 nextop = pop_return();
1872 nextop = pop_return();
1876 nextop = pop_return();
1879 DIE(aTHX_ "panic: last");
1883 if (gimme == G_SCALAR) {
1885 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1886 ? *SP : sv_mortalcopy(*SP);
1888 *++newsp = &PL_sv_undef;
1890 else if (gimme == G_ARRAY) {
1891 while (++MARK <= SP) {
1892 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1893 ? *MARK : sv_mortalcopy(*MARK);
1894 TAINT_NOT; /* Each item is independent */
1900 /* Stack values are safe: */
1903 POPLOOP(cx); /* release loop vars ... */
1907 POPSUB(cx,sv); /* release CV and @_ ... */
1910 PL_curpm = newpm; /* ... and pop $1 et al */
1920 register PERL_CONTEXT *cx;
1923 if (PL_op->op_flags & OPf_SPECIAL) {
1924 cxix = dopoptoloop(cxstack_ix);
1926 DIE(aTHX_ "Can't \"next\" outside a loop block");
1929 cxix = dopoptolabel(cPVOP->op_pv);
1931 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1933 if (cxix < cxstack_ix)
1936 /* clear off anything above the scope we're re-entering, but
1937 * save the rest until after a possible continue block */
1938 inner = PL_scopestack_ix;
1940 if (PL_scopestack_ix < inner)
1941 leave_scope(PL_scopestack[PL_scopestack_ix]);
1942 return cx->blk_loop.next_op;
1948 register PERL_CONTEXT *cx;
1951 if (PL_op->op_flags & OPf_SPECIAL) {
1952 cxix = dopoptoloop(cxstack_ix);
1954 DIE(aTHX_ "Can't \"redo\" outside a loop block");
1957 cxix = dopoptolabel(cPVOP->op_pv);
1959 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1961 if (cxix < cxstack_ix)
1965 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1966 LEAVE_SCOPE(oldsave);
1967 return cx->blk_loop.redo_op;
1971 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
1975 static char too_deep[] = "Target of goto is too deeply nested";
1978 Perl_croak(aTHX_ too_deep);
1979 if (o->op_type == OP_LEAVE ||
1980 o->op_type == OP_SCOPE ||
1981 o->op_type == OP_LEAVELOOP ||
1982 o->op_type == OP_LEAVETRY)
1984 *ops++ = cUNOPo->op_first;
1986 Perl_croak(aTHX_ too_deep);
1989 if (o->op_flags & OPf_KIDS) {
1990 /* First try all the kids at this level, since that's likeliest. */
1991 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1992 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1993 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1996 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1997 if (kid == PL_lastgotoprobe)
1999 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2001 (ops[-1]->op_type != OP_NEXTSTATE &&
2002 ops[-1]->op_type != OP_DBSTATE)))
2004 if ((o = dofindlabel(kid, label, ops, oplimit)))
2023 register PERL_CONTEXT *cx;
2024 #define GOTO_DEPTH 64
2025 OP *enterops[GOTO_DEPTH];
2027 int do_dump = (PL_op->op_type == OP_DUMP);
2028 static char must_have_label[] = "goto must have label";
2031 if (PL_op->op_flags & OPf_STACKED) {
2035 /* This egregious kludge implements goto &subroutine */
2036 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2038 register PERL_CONTEXT *cx;
2039 CV* cv = (CV*)SvRV(sv);
2045 if (!CvROOT(cv) && !CvXSUB(cv)) {
2050 /* autoloaded stub? */
2051 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2053 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2054 GvNAMELEN(gv), FALSE);
2055 if (autogv && (cv = GvCV(autogv)))
2057 tmpstr = sv_newmortal();
2058 gv_efullname3(tmpstr, gv, Nullch);
2059 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2061 DIE(aTHX_ "Goto undefined subroutine");
2064 /* First do some returnish stuff. */
2065 cxix = dopoptosub(cxstack_ix);
2067 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2068 if (cxix < cxstack_ix)
2072 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2074 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2075 /* put @_ back onto stack */
2076 AV* av = cx->blk_sub.argarray;
2078 items = AvFILLp(av) + 1;
2080 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2081 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2082 PL_stack_sp += items;
2083 #ifndef USE_5005THREADS
2084 SvREFCNT_dec(GvAV(PL_defgv));
2085 GvAV(PL_defgv) = cx->blk_sub.savearray;
2086 #endif /* USE_5005THREADS */
2087 /* abandon @_ if it got reified */
2089 (void)sv_2mortal((SV*)av); /* delay until return */
2091 av_extend(av, items-1);
2092 AvFLAGS(av) = AVf_REIFY;
2093 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2096 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2098 #ifdef USE_5005THREADS
2099 av = (AV*)PL_curpad[0];
2101 av = GvAV(PL_defgv);
2103 items = AvFILLp(av) + 1;
2105 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2106 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2107 PL_stack_sp += items;
2109 if (CxTYPE(cx) == CXt_SUB &&
2110 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2111 SvREFCNT_dec(cx->blk_sub.cv);
2112 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2113 LEAVE_SCOPE(oldsave);
2115 /* Now do some callish stuff. */
2118 #ifdef PERL_XSUB_OLDSTYLE
2119 if (CvOLDSTYLE(cv)) {
2120 I32 (*fp3)(int,int,int);
2125 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2126 items = (*fp3)(CvXSUBANY(cv).any_i32,
2127 mark - PL_stack_base + 1,
2129 SP = PL_stack_base + items;
2132 #endif /* PERL_XSUB_OLDSTYLE */
2137 PL_stack_sp--; /* There is no cv arg. */
2138 /* Push a mark for the start of arglist */
2140 (void)(*CvXSUB(cv))(aTHX_ cv);
2141 /* Pop the current context like a decent sub should */
2142 POPBLOCK(cx, PL_curpm);
2143 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2146 return pop_return();
2149 AV* padlist = CvPADLIST(cv);
2150 SV** svp = AvARRAY(padlist);
2151 if (CxTYPE(cx) == CXt_EVAL) {
2152 PL_in_eval = cx->blk_eval.old_in_eval;
2153 PL_eval_root = cx->blk_eval.old_eval_root;
2154 cx->cx_type = CXt_SUB;
2155 cx->blk_sub.hasargs = 0;
2157 cx->blk_sub.cv = cv;
2158 cx->blk_sub.olddepth = CvDEPTH(cv);
2160 if (CvDEPTH(cv) < 2)
2161 (void)SvREFCNT_inc(cv);
2162 else { /* save temporaries on recursion? */
2163 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2164 sub_crush_depth(cv);
2165 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2166 AV *newpad = newAV();
2167 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2168 I32 ix = AvFILLp((AV*)svp[1]);
2169 I32 names_fill = AvFILLp((AV*)svp[0]);
2170 svp = AvARRAY(svp[0]);
2171 for ( ;ix > 0; ix--) {
2172 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2173 char *name = SvPVX(svp[ix]);
2174 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2177 /* outer lexical or anon code */
2178 av_store(newpad, ix,
2179 SvREFCNT_inc(oldpad[ix]) );
2181 else { /* our own lexical */
2183 av_store(newpad, ix, sv = (SV*)newAV());
2184 else if (*name == '%')
2185 av_store(newpad, ix, sv = (SV*)newHV());
2187 av_store(newpad, ix, sv = NEWSV(0,0));
2191 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2192 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2195 av_store(newpad, ix, sv = NEWSV(0,0));
2199 if (cx->blk_sub.hasargs) {
2202 av_store(newpad, 0, (SV*)av);
2203 AvFLAGS(av) = AVf_REIFY;
2205 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2206 AvFILLp(padlist) = CvDEPTH(cv);
2207 svp = AvARRAY(padlist);
2210 #ifdef USE_5005THREADS
2211 if (!cx->blk_sub.hasargs) {
2212 AV* av = (AV*)PL_curpad[0];
2214 items = AvFILLp(av) + 1;
2216 /* Mark is at the end of the stack. */
2218 Copy(AvARRAY(av), SP + 1, items, SV*);
2223 #endif /* USE_5005THREADS */
2224 SAVEVPTR(PL_curpad);
2225 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2226 #ifndef USE_5005THREADS
2227 if (cx->blk_sub.hasargs)
2228 #endif /* USE_5005THREADS */
2230 AV* av = (AV*)PL_curpad[0];
2233 #ifndef USE_5005THREADS
2234 cx->blk_sub.savearray = GvAV(PL_defgv);
2235 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2236 #endif /* USE_5005THREADS */
2237 cx->blk_sub.oldcurpad = PL_curpad;
2238 cx->blk_sub.argarray = av;
2241 if (items >= AvMAX(av) + 1) {
2243 if (AvARRAY(av) != ary) {
2244 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2245 SvPVX(av) = (char*)ary;
2247 if (items >= AvMAX(av) + 1) {
2248 AvMAX(av) = items - 1;
2249 Renew(ary,items+1,SV*);
2251 SvPVX(av) = (char*)ary;
2254 Copy(mark,AvARRAY(av),items,SV*);
2255 AvFILLp(av) = items - 1;
2256 assert(!AvREAL(av));
2263 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2265 * We do not care about using sv to call CV;
2266 * it's for informational purposes only.
2268 SV *sv = GvSV(PL_DBsub);
2271 if (PERLDB_SUB_NN) {
2272 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2275 gv_efullname3(sv, CvGV(cv), Nullch);
2278 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2279 PUSHMARK( PL_stack_sp );
2280 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2284 RETURNOP(CvSTART(cv));
2288 label = SvPV(sv,n_a);
2289 if (!(do_dump || *label))
2290 DIE(aTHX_ must_have_label);
2293 else if (PL_op->op_flags & OPf_SPECIAL) {
2295 DIE(aTHX_ must_have_label);
2298 label = cPVOP->op_pv;
2300 if (label && *label) {
2302 bool leaving_eval = FALSE;
2303 PERL_CONTEXT *last_eval_cx = 0;
2307 PL_lastgotoprobe = 0;
2309 for (ix = cxstack_ix; ix >= 0; ix--) {
2311 switch (CxTYPE(cx)) {
2313 leaving_eval = TRUE;
2314 if (CxREALEVAL(cx)) {
2315 gotoprobe = (last_eval_cx ?
2316 last_eval_cx->blk_eval.old_eval_root :
2321 /* else fall through */
2323 gotoprobe = cx->blk_oldcop->op_sibling;
2329 gotoprobe = cx->blk_oldcop->op_sibling;
2331 gotoprobe = PL_main_root;
2334 if (CvDEPTH(cx->blk_sub.cv)) {
2335 gotoprobe = CvROOT(cx->blk_sub.cv);
2341 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2344 DIE(aTHX_ "panic: goto");
2345 gotoprobe = PL_main_root;
2349 retop = dofindlabel(gotoprobe, label,
2350 enterops, enterops + GOTO_DEPTH);
2354 PL_lastgotoprobe = gotoprobe;
2357 DIE(aTHX_ "Can't find label %s", label);
2359 /* if we're leaving an eval, check before we pop any frames
2360 that we're not going to punt, otherwise the error
2363 if (leaving_eval && *enterops && enterops[1]) {
2365 for (i = 1; enterops[i]; i++)
2366 if (enterops[i]->op_type == OP_ENTERITER)
2367 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2370 /* pop unwanted frames */
2372 if (ix < cxstack_ix) {
2379 oldsave = PL_scopestack[PL_scopestack_ix];
2380 LEAVE_SCOPE(oldsave);
2383 /* push wanted frames */
2385 if (*enterops && enterops[1]) {
2387 for (ix = 1; enterops[ix]; ix++) {
2388 PL_op = enterops[ix];
2389 /* Eventually we may want to stack the needed arguments
2390 * for each op. For now, we punt on the hard ones. */
2391 if (PL_op->op_type == OP_ENTERITER)
2392 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2393 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2401 if (!retop) retop = PL_main_start;
2403 PL_restartop = retop;
2404 PL_do_undump = TRUE;
2408 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2409 PL_do_undump = FALSE;
2425 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2427 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2430 PL_exit_flags |= PERL_EXIT_EXPECTED;
2432 PUSHs(&PL_sv_undef);
2440 NV value = SvNVx(GvSV(cCOP->cop_gv));
2441 register I32 match = I_32(value);
2444 if (((NV)match) > value)
2445 --match; /* was fractional--truncate other way */
2447 match -= cCOP->uop.scop.scop_offset;
2450 else if (match > cCOP->uop.scop.scop_max)
2451 match = cCOP->uop.scop.scop_max;
2452 PL_op = cCOP->uop.scop.scop_next[match];
2462 PL_op = PL_op->op_next; /* can't assume anything */
2465 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2466 match -= cCOP->uop.scop.scop_offset;
2469 else if (match > cCOP->uop.scop.scop_max)
2470 match = cCOP->uop.scop.scop_max;
2471 PL_op = cCOP->uop.scop.scop_next[match];
2480 S_save_lines(pTHX_ AV *array, SV *sv)
2482 register char *s = SvPVX(sv);
2483 register char *send = SvPVX(sv) + SvCUR(sv);
2485 register I32 line = 1;
2487 while (s && s < send) {
2488 SV *tmpstr = NEWSV(85,0);
2490 sv_upgrade(tmpstr, SVt_PVMG);
2491 t = strchr(s, '\n');
2497 sv_setpvn(tmpstr, s, t - s);
2498 av_store(array, line++, tmpstr);
2503 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2505 S_docatch_body(pTHX_ va_list args)
2507 return docatch_body();
2512 S_docatch_body(pTHX)
2519 S_docatch(pTHX_ OP *o)
2523 volatile PERL_SI *cursi = PL_curstackinfo;
2527 assert(CATCH_GET == TRUE);
2530 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2532 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2538 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2544 if (PL_restartop && cursi == PL_curstackinfo) {
2545 PL_op = PL_restartop;
2562 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2563 /* sv Text to convert to OP tree. */
2564 /* startop op_free() this to undo. */
2565 /* code Short string id of the caller. */
2567 dSP; /* Make POPBLOCK work. */
2570 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2574 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2575 char *tmpbuf = tbuf;
2581 /* switch to eval mode */
2583 if (PL_curcop == &PL_compiling) {
2584 SAVECOPSTASH_FREE(&PL_compiling);
2585 CopSTASH_set(&PL_compiling, PL_curstash);
2587 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2588 SV *sv = sv_newmortal();
2589 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2590 code, (unsigned long)++PL_evalseq,
2591 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2595 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2596 SAVECOPFILE_FREE(&PL_compiling);
2597 CopFILE_set(&PL_compiling, tmpbuf+2);
2598 SAVECOPLINE(&PL_compiling);
2599 CopLINE_set(&PL_compiling, 1);
2600 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2601 deleting the eval's FILEGV from the stash before gv_check() runs
2602 (i.e. before run-time proper). To work around the coredump that
2603 ensues, we always turn GvMULTI_on for any globals that were
2604 introduced within evals. See force_ident(). GSAR 96-10-12 */
2605 safestr = savepv(tmpbuf);
2606 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2608 #ifdef OP_IN_REGISTER
2613 PL_hints &= HINT_UTF8;
2616 PL_op->op_type = OP_ENTEREVAL;
2617 PL_op->op_flags = 0; /* Avoid uninit warning. */
2618 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2619 PUSHEVAL(cx, 0, Nullgv);
2620 rop = doeval(G_SCALAR, startop);
2621 POPBLOCK(cx,PL_curpm);
2624 (*startop)->op_type = OP_NULL;
2625 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2627 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2629 if (PL_curcop == &PL_compiling)
2630 PL_compiling.op_private = PL_hints;
2631 #ifdef OP_IN_REGISTER
2637 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2639 S_doeval(pTHX_ int gimme, OP** startop)
2647 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2648 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2653 /* set up a scratch pad */
2656 SAVEVPTR(PL_curpad);
2657 SAVESPTR(PL_comppad);
2658 SAVESPTR(PL_comppad_name);
2659 SAVEI32(PL_comppad_name_fill);
2660 SAVEI32(PL_min_intro_pending);
2661 SAVEI32(PL_max_intro_pending);
2664 for (i = cxstack_ix - 1; i >= 0; i--) {
2665 PERL_CONTEXT *cx = &cxstack[i];
2666 if (CxTYPE(cx) == CXt_EVAL)
2668 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2669 caller = cx->blk_sub.cv;
2674 SAVESPTR(PL_compcv);
2675 PL_compcv = (CV*)NEWSV(1104,0);
2676 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2677 CvEVAL_on(PL_compcv);
2678 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2679 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2681 #ifdef USE_5005THREADS
2682 CvOWNER(PL_compcv) = 0;
2683 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2684 MUTEX_INIT(CvMUTEXP(PL_compcv));
2685 #endif /* USE_5005THREADS */
2687 PL_comppad = newAV();
2688 av_push(PL_comppad, Nullsv);
2689 PL_curpad = AvARRAY(PL_comppad);
2690 PL_comppad_name = newAV();
2691 PL_comppad_name_fill = 0;
2692 PL_min_intro_pending = 0;
2694 #ifdef USE_5005THREADS
2695 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2696 PL_curpad[0] = (SV*)newAV();
2697 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2698 #endif /* USE_5005THREADS */
2700 comppadlist = newAV();
2701 AvREAL_off(comppadlist);
2702 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2703 av_store(comppadlist, 1, (SV*)PL_comppad);
2704 CvPADLIST(PL_compcv) = comppadlist;
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_ 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 "this is only v%d.%d.%d, stopped"
2921 " (did you mean v%"UVuf".%03"UVuf"?)",
2922 rev, ver, sver, PERL_REVISION, PERL_VERSION,
2923 PERL_SUBVERSION, rev, ver/100);
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);
2951 AV *ar = GvAVn(PL_incgv);
2955 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2958 namesv = NEWSV(806, 0);
2959 for (i = 0; i <= AvFILL(ar); i++) {
2960 SV *dirsv = *av_fetch(ar, i, TRUE);
2966 if (SvTYPE(SvRV(loader)) == SVt_PVAV
2967 && !sv_isobject(loader))
2969 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2972 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2973 PTR2UV(SvRV(dirsv)), name);
2974 tryname = SvPVX(namesv);
2985 if (sv_isobject(loader))
2986 count = call_method("INC", G_ARRAY);
2988 count = call_sv(loader, G_ARRAY);
2998 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3002 if (SvTYPE(arg) == SVt_PVGV) {
3003 IO *io = GvIO((GV *)arg);
3008 tryrsfp = IoIFP(io);
3009 if (IoTYPE(io) == IoTYPE_PIPE) {
3010 /* reading from a child process doesn't
3011 nest -- when returning from reading
3012 the inner module, the outer one is
3013 unreadable (closed?) I've tried to
3014 save the gv to manage the lifespan of
3015 the pipe, but this didn't help. XXX */
3016 filter_child_proc = (GV *)arg;
3017 (void)SvREFCNT_inc(filter_child_proc);
3020 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3021 PerlIO_close(IoOFP(io));
3033 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3035 (void)SvREFCNT_inc(filter_sub);
3038 filter_state = SP[i];
3039 (void)SvREFCNT_inc(filter_state);
3043 tryrsfp = PerlIO_open("/dev/null",
3058 filter_has_file = 0;
3059 if (filter_child_proc) {
3060 SvREFCNT_dec(filter_child_proc);
3061 filter_child_proc = 0;
3064 SvREFCNT_dec(filter_state);
3068 SvREFCNT_dec(filter_sub);
3073 if (!path_is_absolute(name)
3074 #ifdef MACOS_TRADITIONAL
3075 /* We consider paths of the form :a:b ambiguous and interpret them first
3076 as global then as local
3078 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3081 char *dir = SvPVx(dirsv, n_a);
3082 #ifdef MACOS_TRADITIONAL
3084 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3088 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3090 sv_setpv(namesv, unixdir);
3091 sv_catpv(namesv, unixname);
3093 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3096 TAINT_PROPER("require");
3097 tryname = SvPVX(namesv);
3098 #ifdef MACOS_TRADITIONAL
3100 /* Convert slashes in the name part, but not the directory part, to colons */
3102 for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3106 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3108 if (tryname[0] == '.' && tryname[1] == '/')
3117 SAVECOPFILE_FREE(&PL_compiling);
3118 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3119 SvREFCNT_dec(namesv);
3121 if (PL_op->op_type == OP_REQUIRE) {
3122 char *msgstr = name;
3123 if (namesv) { /* did we lookup @INC? */
3124 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3125 SV *dirmsgsv = NEWSV(0, 0);
3126 AV *ar = GvAVn(PL_incgv);
3128 sv_catpvn(msg, " in @INC", 8);
3129 if (instr(SvPVX(msg), ".h "))
3130 sv_catpv(msg, " (change .h to .ph maybe?)");
3131 if (instr(SvPVX(msg), ".ph "))
3132 sv_catpv(msg, " (did you run h2ph?)");
3133 sv_catpv(msg, " (@INC contains:");
3134 for (i = 0; i <= AvFILL(ar); i++) {
3135 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3136 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3137 sv_catsv(msg, dirmsgsv);
3139 sv_catpvn(msg, ")", 1);
3140 SvREFCNT_dec(dirmsgsv);
3141 msgstr = SvPV_nolen(msg);
3143 DIE(aTHX_ "Can't locate %s", msgstr);
3149 SETERRNO(0, SS$_NORMAL);
3151 /* Assume success here to prevent recursive requirement. */
3153 /* Check whether a hook in @INC has already filled %INC */
3154 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3155 (void)hv_store(GvHVn(PL_incgv), name, len,
3156 (hook_sv ? SvREFCNT_inc(hook_sv)
3157 : newSVpv(CopFILE(&PL_compiling), 0)),
3163 lex_start(sv_2mortal(newSVpvn("",0)));
3164 SAVEGENERICSV(PL_rsfp_filters);
3165 PL_rsfp_filters = Nullav;
3170 SAVESPTR(PL_compiling.cop_warnings);
3171 if (PL_dowarn & G_WARN_ALL_ON)
3172 PL_compiling.cop_warnings = pWARN_ALL ;
3173 else if (PL_dowarn & G_WARN_ALL_OFF)
3174 PL_compiling.cop_warnings = pWARN_NONE ;
3175 else if (PL_taint_warn)
3176 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3178 PL_compiling.cop_warnings = pWARN_STD ;
3179 SAVESPTR(PL_compiling.cop_io);
3180 PL_compiling.cop_io = Nullsv;
3182 if (filter_sub || filter_child_proc) {
3183 SV *datasv = filter_add(run_user_filter, Nullsv);
3184 IoLINES(datasv) = filter_has_file;
3185 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3186 IoTOP_GV(datasv) = (GV *)filter_state;
3187 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3190 /* switch to eval mode */
3191 push_return(PL_op->op_next);
3192 PUSHBLOCK(cx, CXt_EVAL, SP);
3193 PUSHEVAL(cx, name, Nullgv);
3195 SAVECOPLINE(&PL_compiling);
3196 CopLINE_set(&PL_compiling, 0);
3199 #ifdef USE_5005THREADS
3200 MUTEX_LOCK(&PL_eval_mutex);
3201 if (PL_eval_owner && PL_eval_owner != thr)
3202 while (PL_eval_owner)
3203 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3204 PL_eval_owner = thr;
3205 MUTEX_UNLOCK(&PL_eval_mutex);
3206 #endif /* USE_5005THREADS */
3208 /* Store and reset encoding. */
3209 encoding = PL_encoding;
3210 PL_encoding = Nullsv;
3212 op = DOCATCH(doeval(gimme, NULL));
3214 /* Restore encoding. */
3215 PL_encoding = encoding;
3222 return pp_require();
3228 register PERL_CONTEXT *cx;
3230 I32 gimme = GIMME_V, was = PL_sub_generation;
3231 char tbuf[TYPE_DIGITS(long) + 12];
3232 char *tmpbuf = tbuf;
3237 if (!SvPV(sv,len) || !len)
3239 TAINT_PROPER("eval");
3245 /* switch to eval mode */
3247 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3248 SV *sv = sv_newmortal();
3249 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3250 (unsigned long)++PL_evalseq,
3251 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3255 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3256 SAVECOPFILE_FREE(&PL_compiling);
3257 CopFILE_set(&PL_compiling, tmpbuf+2);
3258 SAVECOPLINE(&PL_compiling);
3259 CopLINE_set(&PL_compiling, 1);
3260 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3261 deleting the eval's FILEGV from the stash before gv_check() runs
3262 (i.e. before run-time proper). To work around the coredump that
3263 ensues, we always turn GvMULTI_on for any globals that were
3264 introduced within evals. See force_ident(). GSAR 96-10-12 */
3265 safestr = savepv(tmpbuf);
3266 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3268 PL_hints = PL_op->op_targ;
3269 SAVESPTR(PL_compiling.cop_warnings);
3270 if (specialWARN(PL_curcop->cop_warnings))
3271 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3273 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3274 SAVEFREESV(PL_compiling.cop_warnings);
3276 SAVESPTR(PL_compiling.cop_io);
3277 if (specialCopIO(PL_curcop->cop_io))
3278 PL_compiling.cop_io = PL_curcop->cop_io;
3280 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3281 SAVEFREESV(PL_compiling.cop_io);
3284 push_return(PL_op->op_next);
3285 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3286 PUSHEVAL(cx, 0, Nullgv);
3288 /* prepare to compile string */
3290 if (PERLDB_LINE && PL_curstash != PL_debstash)
3291 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3293 #ifdef USE_5005THREADS
3294 MUTEX_LOCK(&PL_eval_mutex);
3295 if (PL_eval_owner && PL_eval_owner != thr)
3296 while (PL_eval_owner)
3297 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3298 PL_eval_owner = thr;
3299 MUTEX_UNLOCK(&PL_eval_mutex);
3300 #endif /* USE_5005THREADS */
3301 ret = doeval(gimme, NULL);
3302 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3303 && ret != PL_op->op_next) { /* Successive compilation. */
3304 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3306 return DOCATCH(ret);
3316 register PERL_CONTEXT *cx;
3318 U8 save_flags = PL_op -> op_flags;
3323 retop = pop_return();
3326 if (gimme == G_VOID)
3328 else if (gimme == G_SCALAR) {
3331 if (SvFLAGS(TOPs) & SVs_TEMP)
3334 *MARK = sv_mortalcopy(TOPs);
3338 *MARK = &PL_sv_undef;
3343 /* in case LEAVE wipes old return values */
3344 for (mark = newsp + 1; mark <= SP; mark++) {
3345 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3346 *mark = sv_mortalcopy(*mark);
3347 TAINT_NOT; /* Each item is independent */
3351 PL_curpm = newpm; /* Don't pop $1 et al till now */
3354 assert(CvDEPTH(PL_compcv) == 1);
3356 CvDEPTH(PL_compcv) = 0;
3359 if (optype == OP_REQUIRE &&
3360 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3362 /* Unassume the success we assumed earlier. */
3363 SV *nsv = cx->blk_eval.old_namesv;
3364 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3365 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3366 /* die_where() did LEAVE, or we won't be here */
3370 if (!(save_flags & OPf_SPECIAL))
3380 register PERL_CONTEXT *cx;
3381 I32 gimme = GIMME_V;
3386 push_return(cLOGOP->op_other->op_next);
3387 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3390 PL_in_eval = EVAL_INEVAL;
3393 return DOCATCH(PL_op->op_next);
3403 register PERL_CONTEXT *cx;
3411 if (gimme == G_VOID)
3413 else if (gimme == G_SCALAR) {
3416 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3419 *MARK = sv_mortalcopy(TOPs);
3423 *MARK = &PL_sv_undef;
3428 /* in case LEAVE wipes old return values */
3429 for (mark = newsp + 1; mark <= SP; mark++) {
3430 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3431 *mark = sv_mortalcopy(*mark);
3432 TAINT_NOT; /* Each item is independent */
3436 PL_curpm = newpm; /* Don't pop $1 et al till now */
3444 S_doparseform(pTHX_ SV *sv)
3447 register char *s = SvPV_force(sv, len);
3448 register char *send = s + len;
3449 register char *base = Nullch;
3450 register I32 skipspaces = 0;
3451 bool noblank = FALSE;
3452 bool repeat = FALSE;
3453 bool postspace = FALSE;
3461 Perl_croak(aTHX_ "Null picture in formline");
3463 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3468 *fpc++ = FF_LINEMARK;
3469 noblank = repeat = FALSE;
3487 case ' ': case '\t':
3498 *fpc++ = FF_LITERAL;
3506 *fpc++ = skipspaces;
3510 *fpc++ = FF_NEWLINE;
3514 arg = fpc - linepc + 1;
3521 *fpc++ = FF_LINEMARK;
3522 noblank = repeat = FALSE;
3531 ischop = s[-1] == '^';
3537 arg = (s - base) - 1;
3539 *fpc++ = FF_LITERAL;
3548 *fpc++ = FF_LINEGLOB;
3550 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3551 arg = ischop ? 512 : 0;
3561 arg |= 256 + (s - f);
3563 *fpc++ = s - base; /* fieldsize for FETCH */
3564 *fpc++ = FF_DECIMAL;
3567 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3568 arg = ischop ? 512 : 0;
3570 s++; /* skip the '0' first */
3579 arg |= 256 + (s - f);
3581 *fpc++ = s - base; /* fieldsize for FETCH */
3582 *fpc++ = FF_0DECIMAL;
3587 bool ismore = FALSE;
3590 while (*++s == '>') ;
3591 prespace = FF_SPACE;
3593 else if (*s == '|') {
3594 while (*++s == '|') ;
3595 prespace = FF_HALFSPACE;
3600 while (*++s == '<') ;
3603 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3607 *fpc++ = s - base; /* fieldsize for FETCH */
3609 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3627 { /* need to jump to the next word */
3629 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3630 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3631 s = SvPVX(sv) + SvCUR(sv) + z;
3633 Copy(fops, s, arg, U16);
3635 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3640 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3642 SV *datasv = FILTER_DATA(idx);
3643 int filter_has_file = IoLINES(datasv);
3644 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3645 SV *filter_state = (SV *)IoTOP_GV(datasv);
3646 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3649 /* I was having segfault trouble under Linux 2.2.5 after a
3650 parse error occured. (Had to hack around it with a test
3651 for PL_error_count == 0.) Solaris doesn't segfault --
3652 not sure where the trouble is yet. XXX */
3654 if (filter_has_file) {
3655 len = FILTER_READ(idx+1, buf_sv, maxlen);
3658 if (filter_sub && len >= 0) {
3669 PUSHs(sv_2mortal(newSViv(maxlen)));
3671 PUSHs(filter_state);
3674 count = call_sv(filter_sub, G_SCALAR);
3690 IoLINES(datasv) = 0;
3691 if (filter_child_proc) {
3692 SvREFCNT_dec(filter_child_proc);
3693 IoFMT_GV(datasv) = Nullgv;
3696 SvREFCNT_dec(filter_state);
3697 IoTOP_GV(datasv) = Nullgv;
3700 SvREFCNT_dec(filter_sub);
3701 IoBOTTOM_GV(datasv) = Nullgv;
3703 filter_del(run_user_filter);
3709 /* perhaps someone can come up with a better name for
3710 this? it is not really "absolute", per se ... */
3712 S_path_is_absolute(pTHX_ char *name)
3714 if (PERL_FILE_IS_ABSOLUTE(name)
3715 #ifdef MACOS_TRADITIONAL
3716 || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3718 || (*name == '.' && (name[1] == '/' ||
3719 (name[1] == '.' && name[2] == '/'))))