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));
1592 PL_curcop = (COP*)PL_op;
1593 TAINT_NOT; /* Each statement is presumed innocent */
1594 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1597 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1601 register PERL_CONTEXT *cx;
1602 I32 gimme = G_ARRAY;
1609 DIE(aTHX_ "No DB::DB routine defined");
1611 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1612 /* don't do recursive DB::DB call */
1624 push_return(PL_op->op_next);
1625 PUSHBLOCK(cx, CXt_SUB, SP);
1628 (void)SvREFCNT_inc(cv);
1629 SAVEVPTR(PL_curpad);
1630 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1631 RETURNOP(CvSTART(cv));
1645 register PERL_CONTEXT *cx;
1646 I32 gimme = GIMME_V;
1648 U32 cxtype = CXt_LOOP;
1656 #ifdef USE_5005THREADS
1657 if (PL_op->op_flags & OPf_SPECIAL) {
1658 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1659 SAVEGENERICSV(*svp);
1663 #endif /* USE_5005THREADS */
1664 if (PL_op->op_targ) {
1665 #ifndef USE_ITHREADS
1666 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1669 SAVEPADSV(PL_op->op_targ);
1670 iterdata = INT2PTR(void*, PL_op->op_targ);
1671 cxtype |= CXp_PADVAR;
1676 svp = &GvSV(gv); /* symbol table variable */
1677 SAVEGENERICSV(*svp);
1680 iterdata = (void*)gv;
1686 PUSHBLOCK(cx, cxtype, SP);
1688 PUSHLOOP(cx, iterdata, MARK);
1690 PUSHLOOP(cx, svp, MARK);
1692 if (PL_op->op_flags & OPf_STACKED) {
1693 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1694 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1696 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1697 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1698 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1699 looks_like_number((SV*)cx->blk_loop.iterary) &&
1700 *SvPVX(cx->blk_loop.iterary) != '0'))
1702 if (SvNV(sv) < IV_MIN ||
1703 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1704 DIE(aTHX_ "Range iterator outside integer range");
1705 cx->blk_loop.iterix = SvIV(sv);
1706 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1709 cx->blk_loop.iterlval = newSVsv(sv);
1713 cx->blk_loop.iterary = PL_curstack;
1714 AvFILLp(PL_curstack) = SP - PL_stack_base;
1715 cx->blk_loop.iterix = MARK - PL_stack_base;
1724 register PERL_CONTEXT *cx;
1725 I32 gimme = GIMME_V;
1731 PUSHBLOCK(cx, CXt_LOOP, SP);
1732 PUSHLOOP(cx, 0, SP);
1740 register PERL_CONTEXT *cx;
1748 newsp = PL_stack_base + cx->blk_loop.resetsp;
1751 if (gimme == G_VOID)
1753 else if (gimme == G_SCALAR) {
1755 *++newsp = sv_mortalcopy(*SP);
1757 *++newsp = &PL_sv_undef;
1761 *++newsp = sv_mortalcopy(*++mark);
1762 TAINT_NOT; /* Each item is independent */
1768 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1769 PL_curpm = newpm; /* ... and pop $1 et al */
1781 register PERL_CONTEXT *cx;
1782 bool popsub2 = FALSE;
1783 bool clear_errsv = FALSE;
1790 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1791 if (cxstack_ix == PL_sortcxix
1792 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1794 if (cxstack_ix > PL_sortcxix)
1795 dounwind(PL_sortcxix);
1796 AvARRAY(PL_curstack)[1] = *SP;
1797 PL_stack_sp = PL_stack_base + 1;
1802 cxix = dopoptosub(cxstack_ix);
1804 DIE(aTHX_ "Can't return outside a subroutine");
1805 if (cxix < cxstack_ix)
1809 switch (CxTYPE(cx)) {
1814 if (!(PL_in_eval & EVAL_KEEPERR))
1820 if (optype == OP_REQUIRE &&
1821 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1823 /* Unassume the success we assumed earlier. */
1824 SV *nsv = cx->blk_eval.old_namesv;
1825 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1826 DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1833 DIE(aTHX_ "panic: return");
1837 if (gimme == G_SCALAR) {
1840 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1842 *++newsp = SvREFCNT_inc(*SP);
1847 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1849 *++newsp = sv_mortalcopy(sv);
1854 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1857 *++newsp = sv_mortalcopy(*SP);
1860 *++newsp = &PL_sv_undef;
1862 else if (gimme == G_ARRAY) {
1863 while (++MARK <= SP) {
1864 *++newsp = (popsub2 && SvTEMP(*MARK))
1865 ? *MARK : sv_mortalcopy(*MARK);
1866 TAINT_NOT; /* Each item is independent */
1869 PL_stack_sp = newsp;
1871 /* Stack values are safe: */
1873 POPSUB(cx,sv); /* release CV and @_ ... */
1877 PL_curpm = newpm; /* ... and pop $1 et al */
1883 return pop_return();
1890 register PERL_CONTEXT *cx;
1900 if (PL_op->op_flags & OPf_SPECIAL) {
1901 cxix = dopoptoloop(cxstack_ix);
1903 DIE(aTHX_ "Can't \"last\" outside a loop block");
1906 cxix = dopoptolabel(cPVOP->op_pv);
1908 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1910 if (cxix < cxstack_ix)
1915 switch (CxTYPE(cx)) {
1918 newsp = PL_stack_base + cx->blk_loop.resetsp;
1919 nextop = cx->blk_loop.last_op->op_next;
1923 nextop = pop_return();
1927 nextop = pop_return();
1931 nextop = pop_return();
1934 DIE(aTHX_ "panic: last");
1938 if (gimme == G_SCALAR) {
1940 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1941 ? *SP : sv_mortalcopy(*SP);
1943 *++newsp = &PL_sv_undef;
1945 else if (gimme == G_ARRAY) {
1946 while (++MARK <= SP) {
1947 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1948 ? *MARK : sv_mortalcopy(*MARK);
1949 TAINT_NOT; /* Each item is independent */
1955 /* Stack values are safe: */
1958 POPLOOP(cx); /* release loop vars ... */
1962 POPSUB(cx,sv); /* release CV and @_ ... */
1965 PL_curpm = newpm; /* ... and pop $1 et al */
1975 register PERL_CONTEXT *cx;
1978 if (PL_op->op_flags & OPf_SPECIAL) {
1979 cxix = dopoptoloop(cxstack_ix);
1981 DIE(aTHX_ "Can't \"next\" outside a loop block");
1984 cxix = dopoptolabel(cPVOP->op_pv);
1986 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1988 if (cxix < cxstack_ix)
1991 /* clear off anything above the scope we're re-entering, but
1992 * save the rest until after a possible continue block */
1993 inner = PL_scopestack_ix;
1995 if (PL_scopestack_ix < inner)
1996 leave_scope(PL_scopestack[PL_scopestack_ix]);
1997 return cx->blk_loop.next_op;
2003 register PERL_CONTEXT *cx;
2006 if (PL_op->op_flags & OPf_SPECIAL) {
2007 cxix = dopoptoloop(cxstack_ix);
2009 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2012 cxix = dopoptolabel(cPVOP->op_pv);
2014 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2016 if (cxix < cxstack_ix)
2020 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2021 LEAVE_SCOPE(oldsave);
2022 return cx->blk_loop.redo_op;
2026 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2030 static char too_deep[] = "Target of goto is too deeply nested";
2033 Perl_croak(aTHX_ too_deep);
2034 if (o->op_type == OP_LEAVE ||
2035 o->op_type == OP_SCOPE ||
2036 o->op_type == OP_LEAVELOOP ||
2037 o->op_type == OP_LEAVETRY)
2039 *ops++ = cUNOPo->op_first;
2041 Perl_croak(aTHX_ too_deep);
2044 if (o->op_flags & OPf_KIDS) {
2045 /* First try all the kids at this level, since that's likeliest. */
2046 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2047 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2048 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2051 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2052 if (kid == PL_lastgotoprobe)
2054 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2056 (ops[-1]->op_type != OP_NEXTSTATE &&
2057 ops[-1]->op_type != OP_DBSTATE)))
2059 if ((o = dofindlabel(kid, label, ops, oplimit)))
2078 register PERL_CONTEXT *cx;
2079 #define GOTO_DEPTH 64
2080 OP *enterops[GOTO_DEPTH];
2082 int do_dump = (PL_op->op_type == OP_DUMP);
2083 static char must_have_label[] = "goto must have label";
2086 if (PL_op->op_flags & OPf_STACKED) {
2090 /* This egregious kludge implements goto &subroutine */
2091 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2093 register PERL_CONTEXT *cx;
2094 CV* cv = (CV*)SvRV(sv);
2100 if (!CvROOT(cv) && !CvXSUB(cv)) {
2105 /* autoloaded stub? */
2106 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2108 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2109 GvNAMELEN(gv), FALSE);
2110 if (autogv && (cv = GvCV(autogv)))
2112 tmpstr = sv_newmortal();
2113 gv_efullname3(tmpstr, gv, Nullch);
2114 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2116 DIE(aTHX_ "Goto undefined subroutine");
2119 /* First do some returnish stuff. */
2120 cxix = dopoptosub(cxstack_ix);
2122 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2123 if (cxix < cxstack_ix)
2127 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2129 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2130 /* put @_ back onto stack */
2131 AV* av = cx->blk_sub.argarray;
2133 items = AvFILLp(av) + 1;
2135 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2136 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2137 PL_stack_sp += items;
2138 #ifndef USE_5005THREADS
2139 SvREFCNT_dec(GvAV(PL_defgv));
2140 GvAV(PL_defgv) = cx->blk_sub.savearray;
2141 #endif /* USE_5005THREADS */
2142 /* abandon @_ if it got reified */
2144 (void)sv_2mortal((SV*)av); /* delay until return */
2146 av_extend(av, items-1);
2147 AvFLAGS(av) = AVf_REIFY;
2148 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
2151 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2153 #ifdef USE_5005THREADS
2154 av = (AV*)PL_curpad[0];
2156 av = GvAV(PL_defgv);
2158 items = AvFILLp(av) + 1;
2160 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2161 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2162 PL_stack_sp += items;
2164 if (CxTYPE(cx) == CXt_SUB &&
2165 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2166 SvREFCNT_dec(cx->blk_sub.cv);
2167 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2168 LEAVE_SCOPE(oldsave);
2170 /* Now do some callish stuff. */
2173 #ifdef PERL_XSUB_OLDSTYLE
2174 if (CvOLDSTYLE(cv)) {
2175 I32 (*fp3)(int,int,int);
2180 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2181 items = (*fp3)(CvXSUBANY(cv).any_i32,
2182 mark - PL_stack_base + 1,
2184 SP = PL_stack_base + items;
2187 #endif /* PERL_XSUB_OLDSTYLE */
2192 PL_stack_sp--; /* There is no cv arg. */
2193 /* Push a mark for the start of arglist */
2195 (void)(*CvXSUB(cv))(aTHX_ cv);
2196 /* Pop the current context like a decent sub should */
2197 POPBLOCK(cx, PL_curpm);
2198 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2201 return pop_return();
2204 AV* padlist = CvPADLIST(cv);
2205 SV** svp = AvARRAY(padlist);
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);
2215 if (CvDEPTH(cv) < 2)
2216 (void)SvREFCNT_inc(cv);
2217 else { /* save temporaries on recursion? */
2218 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2219 sub_crush_depth(cv);
2220 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2221 AV *newpad = newAV();
2222 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2223 I32 ix = AvFILLp((AV*)svp[1]);
2224 I32 names_fill = AvFILLp((AV*)svp[0]);
2225 svp = AvARRAY(svp[0]);
2226 for ( ;ix > 0; ix--) {
2227 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2228 char *name = SvPVX(svp[ix]);
2229 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2232 /* outer lexical or anon code */
2233 av_store(newpad, ix,
2234 SvREFCNT_inc(oldpad[ix]) );
2236 else { /* our own lexical */
2238 av_store(newpad, ix, sv = (SV*)newAV());
2239 else if (*name == '%')
2240 av_store(newpad, ix, sv = (SV*)newHV());
2242 av_store(newpad, ix, sv = NEWSV(0,0));
2246 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2247 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2250 av_store(newpad, ix, sv = NEWSV(0,0));
2254 if (cx->blk_sub.hasargs) {
2257 av_store(newpad, 0, (SV*)av);
2258 AvFLAGS(av) = AVf_REIFY;
2260 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2261 AvFILLp(padlist) = CvDEPTH(cv);
2262 svp = AvARRAY(padlist);
2265 #ifdef USE_5005THREADS
2266 if (!cx->blk_sub.hasargs) {
2267 AV* av = (AV*)PL_curpad[0];
2269 items = AvFILLp(av) + 1;
2271 /* Mark is at the end of the stack. */
2273 Copy(AvARRAY(av), SP + 1, items, SV*);
2278 #endif /* USE_5005THREADS */
2279 SAVEVPTR(PL_curpad);
2280 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2281 #ifndef USE_5005THREADS
2282 if (cx->blk_sub.hasargs)
2283 #endif /* USE_5005THREADS */
2285 AV* av = (AV*)PL_curpad[0];
2288 #ifndef USE_5005THREADS
2289 cx->blk_sub.savearray = GvAV(PL_defgv);
2290 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2291 #endif /* USE_5005THREADS */
2292 cx->blk_sub.oldcurpad = PL_curpad;
2293 cx->blk_sub.argarray = av;
2296 if (items >= AvMAX(av) + 1) {
2298 if (AvARRAY(av) != ary) {
2299 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2300 SvPVX(av) = (char*)ary;
2302 if (items >= AvMAX(av) + 1) {
2303 AvMAX(av) = items - 1;
2304 Renew(ary,items+1,SV*);
2306 SvPVX(av) = (char*)ary;
2309 Copy(mark,AvARRAY(av),items,SV*);
2310 AvFILLp(av) = items - 1;
2311 assert(!AvREAL(av));
2318 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2320 * We do not care about using sv to call CV;
2321 * it's for informational purposes only.
2323 SV *sv = GvSV(PL_DBsub);
2326 if (PERLDB_SUB_NN) {
2327 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2330 gv_efullname3(sv, CvGV(cv), Nullch);
2333 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2334 PUSHMARK( PL_stack_sp );
2335 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2339 RETURNOP(CvSTART(cv));
2343 label = SvPV(sv,n_a);
2344 if (!(do_dump || *label))
2345 DIE(aTHX_ must_have_label);
2348 else if (PL_op->op_flags & OPf_SPECIAL) {
2350 DIE(aTHX_ must_have_label);
2353 label = cPVOP->op_pv;
2355 if (label && *label) {
2357 bool leaving_eval = FALSE;
2358 PERL_CONTEXT *last_eval_cx = 0;
2362 PL_lastgotoprobe = 0;
2364 for (ix = cxstack_ix; ix >= 0; ix--) {
2366 switch (CxTYPE(cx)) {
2368 leaving_eval = TRUE;
2369 if (CxREALEVAL(cx)) {
2370 gotoprobe = (last_eval_cx ?
2371 last_eval_cx->blk_eval.old_eval_root :
2376 /* else fall through */
2378 gotoprobe = cx->blk_oldcop->op_sibling;
2384 gotoprobe = cx->blk_oldcop->op_sibling;
2386 gotoprobe = PL_main_root;
2389 if (CvDEPTH(cx->blk_sub.cv)) {
2390 gotoprobe = CvROOT(cx->blk_sub.cv);
2396 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2399 DIE(aTHX_ "panic: goto");
2400 gotoprobe = PL_main_root;
2404 retop = dofindlabel(gotoprobe, label,
2405 enterops, enterops + GOTO_DEPTH);
2409 PL_lastgotoprobe = gotoprobe;
2412 DIE(aTHX_ "Can't find label %s", label);
2414 /* if we're leaving an eval, check before we pop any frames
2415 that we're not going to punt, otherwise the error
2418 if (leaving_eval && *enterops && enterops[1]) {
2420 for (i = 1; enterops[i]; i++)
2421 if (enterops[i]->op_type == OP_ENTERITER)
2422 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2425 /* pop unwanted frames */
2427 if (ix < cxstack_ix) {
2434 oldsave = PL_scopestack[PL_scopestack_ix];
2435 LEAVE_SCOPE(oldsave);
2438 /* push wanted frames */
2440 if (*enterops && enterops[1]) {
2442 for (ix = 1; enterops[ix]; ix++) {
2443 PL_op = enterops[ix];
2444 /* Eventually we may want to stack the needed arguments
2445 * for each op. For now, we punt on the hard ones. */
2446 if (PL_op->op_type == OP_ENTERITER)
2447 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2448 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2456 if (!retop) retop = PL_main_start;
2458 PL_restartop = retop;
2459 PL_do_undump = TRUE;
2463 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2464 PL_do_undump = FALSE;
2480 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2482 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2485 PL_exit_flags |= PERL_EXIT_EXPECTED;
2487 PUSHs(&PL_sv_undef);
2495 NV value = SvNVx(GvSV(cCOP->cop_gv));
2496 register I32 match = I_32(value);
2499 if (((NV)match) > value)
2500 --match; /* was fractional--truncate other way */
2502 match -= cCOP->uop.scop.scop_offset;
2505 else if (match > cCOP->uop.scop.scop_max)
2506 match = cCOP->uop.scop.scop_max;
2507 PL_op = cCOP->uop.scop.scop_next[match];
2517 PL_op = PL_op->op_next; /* can't assume anything */
2520 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2521 match -= cCOP->uop.scop.scop_offset;
2524 else if (match > cCOP->uop.scop.scop_max)
2525 match = cCOP->uop.scop.scop_max;
2526 PL_op = cCOP->uop.scop.scop_next[match];
2535 S_save_lines(pTHX_ AV *array, SV *sv)
2537 register char *s = SvPVX(sv);
2538 register char *send = SvPVX(sv) + SvCUR(sv);
2540 register I32 line = 1;
2542 while (s && s < send) {
2543 SV *tmpstr = NEWSV(85,0);
2545 sv_upgrade(tmpstr, SVt_PVMG);
2546 t = strchr(s, '\n');
2552 sv_setpvn(tmpstr, s, t - s);
2553 av_store(array, line++, tmpstr);
2558 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2560 S_docatch_body(pTHX_ va_list args)
2562 return docatch_body();
2567 S_docatch_body(pTHX)
2574 S_docatch(pTHX_ OP *o)
2579 volatile PERL_SI *cursi = PL_curstackinfo;
2583 assert(CATCH_GET == TRUE);
2587 /* Normally, the leavetry at the end of this block of ops will
2588 * pop an op off the return stack and continue there. By setting
2589 * the op to Nullop, we force an exit from the inner runops()
2592 retop = pop_return();
2593 push_return(Nullop);
2595 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2597 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2603 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2609 /* die caught by an inner eval - continue inner loop */
2610 if (PL_restartop && cursi == PL_curstackinfo) {
2611 PL_op = PL_restartop;
2615 /* a die in this eval - continue in outer loop */
2631 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2632 /* sv Text to convert to OP tree. */
2633 /* startop op_free() this to undo. */
2634 /* code Short string id of the caller. */
2636 dSP; /* Make POPBLOCK work. */
2639 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2643 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2644 char *tmpbuf = tbuf;
2650 /* switch to eval mode */
2652 if (PL_curcop == &PL_compiling) {
2653 SAVECOPSTASH_FREE(&PL_compiling);
2654 CopSTASH_set(&PL_compiling, PL_curstash);
2656 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2657 SV *sv = sv_newmortal();
2658 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2659 code, (unsigned long)++PL_evalseq,
2660 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2664 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2665 SAVECOPFILE_FREE(&PL_compiling);
2666 CopFILE_set(&PL_compiling, tmpbuf+2);
2667 SAVECOPLINE(&PL_compiling);
2668 CopLINE_set(&PL_compiling, 1);
2669 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2670 deleting the eval's FILEGV from the stash before gv_check() runs
2671 (i.e. before run-time proper). To work around the coredump that
2672 ensues, we always turn GvMULTI_on for any globals that were
2673 introduced within evals. See force_ident(). GSAR 96-10-12 */
2674 safestr = savepv(tmpbuf);
2675 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2677 #ifdef OP_IN_REGISTER
2682 PL_hints &= HINT_UTF8;
2685 PL_op->op_type = OP_ENTEREVAL;
2686 PL_op->op_flags = 0; /* Avoid uninit warning. */
2687 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2688 PUSHEVAL(cx, 0, Nullgv);
2689 rop = doeval(G_SCALAR, startop);
2690 POPBLOCK(cx,PL_curpm);
2693 (*startop)->op_type = OP_NULL;
2694 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2696 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2698 if (PL_curcop == &PL_compiling)
2699 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2700 #ifdef OP_IN_REGISTER
2706 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2708 S_doeval(pTHX_ int gimme, OP** startop)
2716 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2717 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2722 /* set up a scratch pad */
2725 SAVEVPTR(PL_curpad);
2726 SAVESPTR(PL_comppad);
2727 SAVESPTR(PL_comppad_name);
2728 SAVEI32(PL_comppad_name_fill);
2729 SAVEI32(PL_min_intro_pending);
2730 SAVEI32(PL_max_intro_pending);
2733 for (i = cxstack_ix - 1; i >= 0; i--) {
2734 PERL_CONTEXT *cx = &cxstack[i];
2735 if (CxTYPE(cx) == CXt_EVAL)
2737 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2738 caller = cx->blk_sub.cv;
2743 SAVESPTR(PL_compcv);
2744 PL_compcv = (CV*)NEWSV(1104,0);
2745 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2746 CvEVAL_on(PL_compcv);
2747 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2748 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2750 #ifdef USE_5005THREADS
2751 CvOWNER(PL_compcv) = 0;
2752 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2753 MUTEX_INIT(CvMUTEXP(PL_compcv));
2754 #endif /* USE_5005THREADS */
2756 PL_comppad = newAV();
2757 av_push(PL_comppad, Nullsv);
2758 PL_curpad = AvARRAY(PL_comppad);
2759 PL_comppad_name = newAV();
2760 PL_comppad_name_fill = 0;
2761 PL_min_intro_pending = 0;
2763 #ifdef USE_5005THREADS
2764 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2765 PL_curpad[0] = (SV*)newAV();
2766 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2767 #endif /* USE_5005THREADS */
2769 comppadlist = newAV();
2770 AvREAL_off(comppadlist);
2771 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2772 av_store(comppadlist, 1, (SV*)PL_comppad);
2773 CvPADLIST(PL_compcv) = comppadlist;
2776 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2778 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2781 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2783 /* make sure we compile in the right package */
2785 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2786 SAVESPTR(PL_curstash);
2787 PL_curstash = CopSTASH(PL_curcop);
2789 SAVESPTR(PL_beginav);
2790 PL_beginav = newAV();
2791 SAVEFREESV(PL_beginav);
2792 SAVEI32(PL_error_count);
2794 /* try to compile it */
2796 PL_eval_root = Nullop;
2798 PL_curcop = &PL_compiling;
2799 PL_curcop->cop_arybase = 0;
2800 if (saveop && saveop->op_flags & OPf_SPECIAL)
2801 PL_in_eval |= EVAL_KEEPERR;
2804 if (yyparse() || PL_error_count || !PL_eval_root) {
2808 I32 optype = 0; /* Might be reset by POPEVAL. */
2813 op_free(PL_eval_root);
2814 PL_eval_root = Nullop;
2816 SP = PL_stack_base + POPMARK; /* pop original mark */
2818 POPBLOCK(cx,PL_curpm);
2824 if (optype == OP_REQUIRE) {
2825 char* msg = SvPVx(ERRSV, n_a);
2826 DIE(aTHX_ "%sCompilation failed in require",
2827 *msg ? msg : "Unknown error\n");
2830 char* msg = SvPVx(ERRSV, n_a);
2832 POPBLOCK(cx,PL_curpm);
2834 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2835 (*msg ? msg : "Unknown error\n"));
2837 #ifdef USE_5005THREADS
2838 MUTEX_LOCK(&PL_eval_mutex);
2840 COND_SIGNAL(&PL_eval_cond);
2841 MUTEX_UNLOCK(&PL_eval_mutex);
2842 #endif /* USE_5005THREADS */
2845 CopLINE_set(&PL_compiling, 0);
2847 *startop = PL_eval_root;
2848 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2849 CvOUTSIDE(PL_compcv) = Nullcv;
2851 SAVEFREEOP(PL_eval_root);
2853 scalarvoid(PL_eval_root);
2854 else if (gimme & G_ARRAY)
2857 scalar(PL_eval_root);
2859 DEBUG_x(dump_eval());
2861 /* Register with debugger: */
2862 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2863 CV *cv = get_cv("DB::postponed", FALSE);
2867 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2869 call_sv((SV*)cv, G_DISCARD);
2873 /* compiled okay, so do it */
2875 CvDEPTH(PL_compcv) = 1;
2876 SP = PL_stack_base + POPMARK; /* pop original mark */
2877 PL_op = saveop; /* The caller may need it. */
2878 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2879 #ifdef USE_5005THREADS
2880 MUTEX_LOCK(&PL_eval_mutex);
2882 COND_SIGNAL(&PL_eval_cond);
2883 MUTEX_UNLOCK(&PL_eval_mutex);
2884 #endif /* USE_5005THREADS */
2886 RETURNOP(PL_eval_start);
2890 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2892 STRLEN namelen = strlen(name);
2895 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2896 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2897 char *pmc = SvPV_nolen(pmcsv);
2900 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2901 fp = PerlIO_open(name, mode);
2904 if (PerlLIO_stat(name, &pmstat) < 0 ||
2905 pmstat.st_mtime < pmcstat.st_mtime)
2907 fp = PerlIO_open(pmc, mode);
2910 fp = PerlIO_open(name, mode);
2913 SvREFCNT_dec(pmcsv);
2916 fp = PerlIO_open(name, mode);
2924 register PERL_CONTEXT *cx;
2928 char *tryname = Nullch;
2929 SV *namesv = Nullsv;
2931 I32 gimme = GIMME_V;
2932 PerlIO *tryrsfp = 0;
2934 int filter_has_file = 0;
2935 GV *filter_child_proc = 0;
2936 SV *filter_state = 0;
2943 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2944 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2945 UV rev = 0, ver = 0, sver = 0;
2947 U8 *s = (U8*)SvPVX(sv);
2948 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2950 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2953 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2956 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2959 if (PERL_REVISION < rev
2960 || (PERL_REVISION == rev
2961 && (PERL_VERSION < ver
2962 || (PERL_VERSION == ver
2963 && PERL_SUBVERSION < sver))))
2965 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2966 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2967 PERL_VERSION, PERL_SUBVERSION);
2969 if (ckWARN(WARN_PORTABLE))
2970 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2971 "v-string in use/require non-portable");
2974 else if (!SvPOKp(sv)) { /* require 5.005_03 */
2975 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2976 + ((NV)PERL_SUBVERSION/(NV)1000000)
2977 + 0.00000099 < SvNV(sv))
2981 NV nver = (nrev - rev) * 1000;
2982 UV ver = (UV)(nver + 0.0009);
2983 NV nsver = (nver - ver) * 1000;
2984 UV sver = (UV)(nsver + 0.0009);
2986 /* help out with the "use 5.6" confusion */
2987 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2988 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2989 " (did you mean v%"UVuf".%03"UVuf"?)--"
2990 "this is only v%d.%d.%d, stopped",
2991 rev, ver, sver, rev, ver/100,
2992 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2995 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2996 "this is only v%d.%d.%d, stopped",
2997 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3004 name = SvPV(sv, len);
3005 if (!(name && len > 0 && *name))
3006 DIE(aTHX_ "Null filename used");
3007 TAINT_PROPER("require");
3008 if (PL_op->op_type == OP_REQUIRE &&
3009 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3010 *svp != &PL_sv_undef)
3013 /* prepare to compile file */
3015 if (path_is_absolute(name)) {
3017 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3019 #ifdef MACOS_TRADITIONAL
3023 MacPerl_CanonDir(name, newname, 1);
3024 if (path_is_absolute(newname)) {
3026 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3031 AV *ar = GvAVn(PL_incgv);
3035 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3038 namesv = NEWSV(806, 0);
3039 for (i = 0; i <= AvFILL(ar); i++) {
3040 SV *dirsv = *av_fetch(ar, i, TRUE);
3046 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3047 && !sv_isobject(loader))
3049 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3052 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3053 PTR2UV(SvRV(dirsv)), name);
3054 tryname = SvPVX(namesv);
3065 if (sv_isobject(loader))
3066 count = call_method("INC", G_ARRAY);
3068 count = call_sv(loader, G_ARRAY);
3078 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3082 if (SvTYPE(arg) == SVt_PVGV) {
3083 IO *io = GvIO((GV *)arg);
3088 tryrsfp = IoIFP(io);
3089 if (IoTYPE(io) == IoTYPE_PIPE) {
3090 /* reading from a child process doesn't
3091 nest -- when returning from reading
3092 the inner module, the outer one is
3093 unreadable (closed?) I've tried to
3094 save the gv to manage the lifespan of
3095 the pipe, but this didn't help. XXX */
3096 filter_child_proc = (GV *)arg;
3097 (void)SvREFCNT_inc(filter_child_proc);
3100 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3101 PerlIO_close(IoOFP(io));
3113 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3115 (void)SvREFCNT_inc(filter_sub);
3118 filter_state = SP[i];
3119 (void)SvREFCNT_inc(filter_state);
3123 tryrsfp = PerlIO_open("/dev/null",
3138 filter_has_file = 0;
3139 if (filter_child_proc) {
3140 SvREFCNT_dec(filter_child_proc);
3141 filter_child_proc = 0;
3144 SvREFCNT_dec(filter_state);
3148 SvREFCNT_dec(filter_sub);
3153 if (!path_is_absolute(name)
3154 #ifdef MACOS_TRADITIONAL
3155 /* We consider paths of the form :a:b ambiguous and interpret them first
3156 as global then as local
3158 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3161 char *dir = SvPVx(dirsv, n_a);
3162 #ifdef MACOS_TRADITIONAL
3166 MacPerl_CanonDir(name, buf2, 1);
3167 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3171 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3173 sv_setpv(namesv, unixdir);
3174 sv_catpv(namesv, unixname);
3176 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3179 TAINT_PROPER("require");
3180 tryname = SvPVX(namesv);
3181 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3183 if (tryname[0] == '.' && tryname[1] == '/')
3192 SAVECOPFILE_FREE(&PL_compiling);
3193 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3194 SvREFCNT_dec(namesv);
3196 if (PL_op->op_type == OP_REQUIRE) {
3197 char *msgstr = name;
3198 if (namesv) { /* did we lookup @INC? */
3199 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3200 SV *dirmsgsv = NEWSV(0, 0);
3201 AV *ar = GvAVn(PL_incgv);
3203 sv_catpvn(msg, " in @INC", 8);
3204 if (instr(SvPVX(msg), ".h "))
3205 sv_catpv(msg, " (change .h to .ph maybe?)");
3206 if (instr(SvPVX(msg), ".ph "))
3207 sv_catpv(msg, " (did you run h2ph?)");
3208 sv_catpv(msg, " (@INC contains:");
3209 for (i = 0; i <= AvFILL(ar); i++) {
3210 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3211 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3212 sv_catsv(msg, dirmsgsv);
3214 sv_catpvn(msg, ")", 1);
3215 SvREFCNT_dec(dirmsgsv);
3216 msgstr = SvPV_nolen(msg);
3218 DIE(aTHX_ "Can't locate %s", msgstr);
3224 SETERRNO(0, SS$_NORMAL);
3226 /* Assume success here to prevent recursive requirement. */
3228 /* Check whether a hook in @INC has already filled %INC */
3229 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3230 (void)hv_store(GvHVn(PL_incgv), name, len,
3231 (hook_sv ? SvREFCNT_inc(hook_sv)
3232 : newSVpv(CopFILE(&PL_compiling), 0)),
3238 lex_start(sv_2mortal(newSVpvn("",0)));
3239 SAVEGENERICSV(PL_rsfp_filters);
3240 PL_rsfp_filters = Nullav;
3245 SAVESPTR(PL_compiling.cop_warnings);
3246 if (PL_dowarn & G_WARN_ALL_ON)
3247 PL_compiling.cop_warnings = pWARN_ALL ;
3248 else if (PL_dowarn & G_WARN_ALL_OFF)
3249 PL_compiling.cop_warnings = pWARN_NONE ;
3250 else if (PL_taint_warn)
3251 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3253 PL_compiling.cop_warnings = pWARN_STD ;
3254 SAVESPTR(PL_compiling.cop_io);
3255 PL_compiling.cop_io = Nullsv;
3257 if (filter_sub || filter_child_proc) {
3258 SV *datasv = filter_add(run_user_filter, Nullsv);
3259 IoLINES(datasv) = filter_has_file;
3260 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3261 IoTOP_GV(datasv) = (GV *)filter_state;
3262 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3265 /* switch to eval mode */
3266 push_return(PL_op->op_next);
3267 PUSHBLOCK(cx, CXt_EVAL, SP);
3268 PUSHEVAL(cx, name, Nullgv);
3270 SAVECOPLINE(&PL_compiling);
3271 CopLINE_set(&PL_compiling, 0);
3274 #ifdef USE_5005THREADS
3275 MUTEX_LOCK(&PL_eval_mutex);
3276 if (PL_eval_owner && PL_eval_owner != thr)
3277 while (PL_eval_owner)
3278 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3279 PL_eval_owner = thr;
3280 MUTEX_UNLOCK(&PL_eval_mutex);
3281 #endif /* USE_5005THREADS */
3283 /* Store and reset encoding. */
3284 encoding = PL_encoding;
3285 PL_encoding = Nullsv;
3287 op = DOCATCH(doeval(gimme, NULL));
3289 /* Restore encoding. */
3290 PL_encoding = encoding;
3297 return pp_require();
3303 register PERL_CONTEXT *cx;
3305 I32 gimme = GIMME_V, was = PL_sub_generation;
3306 char tbuf[TYPE_DIGITS(long) + 12];
3307 char *tmpbuf = tbuf;
3314 TAINT_PROPER("eval");
3320 /* switch to eval mode */
3322 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3323 SV *sv = sv_newmortal();
3324 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3325 (unsigned long)++PL_evalseq,
3326 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3330 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3331 SAVECOPFILE_FREE(&PL_compiling);
3332 CopFILE_set(&PL_compiling, tmpbuf+2);
3333 SAVECOPLINE(&PL_compiling);
3334 CopLINE_set(&PL_compiling, 1);
3335 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3336 deleting the eval's FILEGV from the stash before gv_check() runs
3337 (i.e. before run-time proper). To work around the coredump that
3338 ensues, we always turn GvMULTI_on for any globals that were
3339 introduced within evals. See force_ident(). GSAR 96-10-12 */
3340 safestr = savepv(tmpbuf);
3341 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3343 PL_hints = PL_op->op_targ;
3344 SAVESPTR(PL_compiling.cop_warnings);
3345 if (specialWARN(PL_curcop->cop_warnings))
3346 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3348 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3349 SAVEFREESV(PL_compiling.cop_warnings);
3351 SAVESPTR(PL_compiling.cop_io);
3352 if (specialCopIO(PL_curcop->cop_io))
3353 PL_compiling.cop_io = PL_curcop->cop_io;
3355 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3356 SAVEFREESV(PL_compiling.cop_io);
3359 push_return(PL_op->op_next);
3360 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3361 PUSHEVAL(cx, 0, Nullgv);
3363 /* prepare to compile string */
3365 if (PERLDB_LINE && PL_curstash != PL_debstash)
3366 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3368 #ifdef USE_5005THREADS
3369 MUTEX_LOCK(&PL_eval_mutex);
3370 if (PL_eval_owner && PL_eval_owner != thr)
3371 while (PL_eval_owner)
3372 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3373 PL_eval_owner = thr;
3374 MUTEX_UNLOCK(&PL_eval_mutex);
3375 #endif /* USE_5005THREADS */
3376 ret = doeval(gimme, NULL);
3377 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3378 && ret != PL_op->op_next) { /* Successive compilation. */
3379 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3381 return DOCATCH(ret);
3391 register PERL_CONTEXT *cx;
3393 U8 save_flags = PL_op -> op_flags;
3398 retop = pop_return();
3401 if (gimme == G_VOID)
3403 else if (gimme == G_SCALAR) {
3406 if (SvFLAGS(TOPs) & SVs_TEMP)
3409 *MARK = sv_mortalcopy(TOPs);
3413 *MARK = &PL_sv_undef;
3418 /* in case LEAVE wipes old return values */
3419 for (mark = newsp + 1; mark <= SP; mark++) {
3420 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3421 *mark = sv_mortalcopy(*mark);
3422 TAINT_NOT; /* Each item is independent */
3426 PL_curpm = newpm; /* Don't pop $1 et al till now */
3429 assert(CvDEPTH(PL_compcv) == 1);
3431 CvDEPTH(PL_compcv) = 0;
3434 if (optype == OP_REQUIRE &&
3435 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3437 /* Unassume the success we assumed earlier. */
3438 SV *nsv = cx->blk_eval.old_namesv;
3439 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3440 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3441 /* die_where() did LEAVE, or we won't be here */
3445 if (!(save_flags & OPf_SPECIAL))
3455 register PERL_CONTEXT *cx;
3456 I32 gimme = GIMME_V;
3461 push_return(cLOGOP->op_other->op_next);
3462 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3465 PL_in_eval = EVAL_INEVAL;
3468 return DOCATCH(PL_op->op_next);
3479 register PERL_CONTEXT *cx;
3484 retop = pop_return();
3487 if (gimme == G_VOID)
3489 else if (gimme == G_SCALAR) {
3492 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3495 *MARK = sv_mortalcopy(TOPs);
3499 *MARK = &PL_sv_undef;
3504 /* in case LEAVE wipes old return values */
3505 for (mark = newsp + 1; mark <= SP; mark++) {
3506 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3507 *mark = sv_mortalcopy(*mark);
3508 TAINT_NOT; /* Each item is independent */
3512 PL_curpm = newpm; /* Don't pop $1 et al till now */
3520 S_doparseform(pTHX_ SV *sv)
3523 register char *s = SvPV_force(sv, len);
3524 register char *send = s + len;
3525 register char *base = Nullch;
3526 register I32 skipspaces = 0;
3527 bool noblank = FALSE;
3528 bool repeat = FALSE;
3529 bool postspace = FALSE;
3537 Perl_croak(aTHX_ "Null picture in formline");
3539 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3544 *fpc++ = FF_LINEMARK;
3545 noblank = repeat = FALSE;
3563 case ' ': case '\t':
3574 *fpc++ = FF_LITERAL;
3582 *fpc++ = (U16)skipspaces;
3586 *fpc++ = FF_NEWLINE;
3590 arg = fpc - linepc + 1;
3597 *fpc++ = FF_LINEMARK;
3598 noblank = repeat = FALSE;
3607 ischop = s[-1] == '^';
3613 arg = (s - base) - 1;
3615 *fpc++ = FF_LITERAL;
3624 *fpc++ = FF_LINEGLOB;
3626 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3627 arg = ischop ? 512 : 0;
3637 arg |= 256 + (s - f);
3639 *fpc++ = s - base; /* fieldsize for FETCH */
3640 *fpc++ = FF_DECIMAL;
3643 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3644 arg = ischop ? 512 : 0;
3646 s++; /* skip the '0' first */
3655 arg |= 256 + (s - f);
3657 *fpc++ = s - base; /* fieldsize for FETCH */
3658 *fpc++ = FF_0DECIMAL;
3663 bool ismore = FALSE;
3666 while (*++s == '>') ;
3667 prespace = FF_SPACE;
3669 else if (*s == '|') {
3670 while (*++s == '|') ;
3671 prespace = FF_HALFSPACE;
3676 while (*++s == '<') ;
3679 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3683 *fpc++ = s - base; /* fieldsize for FETCH */
3685 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3688 *fpc++ = (U16)prespace;
3703 { /* need to jump to the next word */
3705 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3706 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3707 s = SvPVX(sv) + SvCUR(sv) + z;
3709 Copy(fops, s, arg, U16);
3711 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3716 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3718 SV *datasv = FILTER_DATA(idx);
3719 int filter_has_file = IoLINES(datasv);
3720 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3721 SV *filter_state = (SV *)IoTOP_GV(datasv);
3722 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3725 /* I was having segfault trouble under Linux 2.2.5 after a
3726 parse error occured. (Had to hack around it with a test
3727 for PL_error_count == 0.) Solaris doesn't segfault --
3728 not sure where the trouble is yet. XXX */
3730 if (filter_has_file) {
3731 len = FILTER_READ(idx+1, buf_sv, maxlen);
3734 if (filter_sub && len >= 0) {
3745 PUSHs(sv_2mortal(newSViv(maxlen)));
3747 PUSHs(filter_state);
3750 count = call_sv(filter_sub, G_SCALAR);
3766 IoLINES(datasv) = 0;
3767 if (filter_child_proc) {
3768 SvREFCNT_dec(filter_child_proc);
3769 IoFMT_GV(datasv) = Nullgv;
3772 SvREFCNT_dec(filter_state);
3773 IoTOP_GV(datasv) = Nullgv;
3776 SvREFCNT_dec(filter_sub);
3777 IoBOTTOM_GV(datasv) = Nullgv;
3779 filter_del(run_user_filter);
3785 /* perhaps someone can come up with a better name for
3786 this? it is not really "absolute", per se ... */
3788 S_path_is_absolute(pTHX_ char *name)
3790 if (PERL_FILE_IS_ABSOLUTE(name)
3791 #ifdef MACOS_TRADITIONAL
3794 || (*name == '.' && (name[1] == '/' ||
3795 (name[1] == '.' && name[2] == '/'))))