3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
49 cxix = dopoptosub(cxstack_ix);
53 switch (cxstack[cxix].blk_gimme) {
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 MAGIC *mg = Null(MAGIC*);
88 /* prevent recompiling under /o and ithreads. */
89 #if defined(USE_ITHREADS)
90 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
95 SV *sv = SvRV(tmpstr);
97 mg = mg_find(sv, PERL_MAGIC_qr);
100 regexp *re = (regexp *)mg->mg_obj;
101 ReREFCNT_dec(PM_GETRE(pm));
102 PM_SETRE(pm, ReREFCNT_inc(re));
105 t = SvPV(tmpstr, len);
107 /* Check against the last compiled regexp. */
108 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
109 PM_GETRE(pm)->prelen != (I32)len ||
110 memNE(PM_GETRE(pm)->precomp, t, len))
113 ReREFCNT_dec(PM_GETRE(pm));
114 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
116 if (PL_op->op_flags & OPf_SPECIAL)
117 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
119 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
121 pm->op_pmdynflags |= PMdf_DYN_UTF8;
123 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
124 if (pm->op_pmdynflags & PMdf_UTF8)
125 t = (char*)bytes_to_utf8((U8*)t, &len);
127 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
128 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
130 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
131 inside tie/overload accessors. */
135 #ifndef INCOMPLETE_TAINTS
138 pm->op_pmdynflags |= PMdf_TAINTED;
140 pm->op_pmdynflags &= ~PMdf_TAINTED;
144 if (!PM_GETRE(pm)->prelen && PL_curpm)
146 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
147 pm->op_pmflags |= PMf_WHITE;
149 pm->op_pmflags &= ~PMf_WHITE;
151 /* XXX runtime compiled output needs to move to the pad */
152 if (pm->op_pmflags & PMf_KEEP) {
153 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
154 #if !defined(USE_ITHREADS)
155 /* XXX can't change the optree at runtime either */
156 cLOGOP->op_first->op_next = PL_op->op_next;
165 register PMOP *pm = (PMOP*) cLOGOP->op_other;
166 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
167 register SV *dstr = cx->sb_dstr;
168 register char *s = cx->sb_s;
169 register char *m = cx->sb_m;
170 char *orig = cx->sb_orig;
171 register REGEXP *rx = cx->sb_rx;
173 REGEXP *old = PM_GETRE(pm);
180 rxres_restore(&cx->sb_rxres, rx);
181 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
183 if (cx->sb_iters++) {
184 I32 saviters = cx->sb_iters;
185 if (cx->sb_iters > cx->sb_maxiters)
186 DIE(aTHX_ "Substitution loop");
188 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
189 cx->sb_rxtainted |= 2;
190 sv_catsv(dstr, POPs);
193 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
194 s == m, cx->sb_targ, NULL,
195 ((cx->sb_rflags & REXEC_COPY_STR)
196 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
197 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
199 SV *targ = cx->sb_targ;
201 assert(cx->sb_strend >= s);
202 if(cx->sb_strend > s) {
203 if (DO_UTF8(dstr) && !SvUTF8(targ))
204 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
206 sv_catpvn(dstr, s, cx->sb_strend - s);
208 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
210 #ifdef PERL_COPY_ON_WRITE
212 sv_force_normal_flags(targ, SV_COW_DROP_PV);
218 Safefree(SvPVX(targ));
220 SvPVX(targ) = SvPVX(dstr);
221 SvCUR_set(targ, SvCUR(dstr));
222 SvLEN_set(targ, SvLEN(dstr));
228 TAINT_IF(cx->sb_rxtainted & 1);
229 PUSHs(sv_2mortal(newSViv(saviters - 1)));
231 (void)SvPOK_only_UTF8(targ);
232 TAINT_IF(cx->sb_rxtainted);
236 LEAVE_SCOPE(cx->sb_oldsave);
239 RETURNOP(pm->op_next);
241 cx->sb_iters = saviters;
243 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
246 cx->sb_orig = orig = rx->subbeg;
248 cx->sb_strend = s + (cx->sb_strend - m);
250 cx->sb_m = m = rx->startp[0] + orig;
252 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
253 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
255 sv_catpvn(dstr, s, m-s);
257 cx->sb_s = rx->endp[0] + orig;
258 { /* Update the pos() information. */
259 SV *sv = cx->sb_targ;
262 if (SvTYPE(sv) < SVt_PVMG)
263 (void)SvUPGRADE(sv, SVt_PVMG);
264 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
265 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
266 mg = mg_find(sv, PERL_MAGIC_regex_global);
275 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
276 rxres_save(&cx->sb_rxres, rx);
277 RETURNOP(pm->op_pmreplstart);
281 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
286 if (!p || p[1] < rx->nparens) {
287 #ifdef PERL_COPY_ON_WRITE
288 i = 7 + rx->nparens * 2;
290 i = 6 + rx->nparens * 2;
299 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
300 RX_MATCH_COPIED_off(rx);
302 #ifdef PERL_COPY_ON_WRITE
303 *p++ = PTR2UV(rx->saved_copy);
304 rx->saved_copy = Nullsv;
309 *p++ = PTR2UV(rx->subbeg);
310 *p++ = (UV)rx->sublen;
311 for (i = 0; i <= rx->nparens; ++i) {
312 *p++ = (UV)rx->startp[i];
313 *p++ = (UV)rx->endp[i];
318 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
323 RX_MATCH_COPY_FREE(rx);
324 RX_MATCH_COPIED_set(rx, *p);
327 #ifdef PERL_COPY_ON_WRITE
329 SvREFCNT_dec (rx->saved_copy);
330 rx->saved_copy = INT2PTR(SV*,*p);
336 rx->subbeg = INT2PTR(char*,*p++);
337 rx->sublen = (I32)(*p++);
338 for (i = 0; i <= rx->nparens; ++i) {
339 rx->startp[i] = (I32)(*p++);
340 rx->endp[i] = (I32)(*p++);
345 Perl_rxres_free(pTHX_ void **rsp)
350 Safefree(INT2PTR(char*,*p));
351 #ifdef PERL_COPY_ON_WRITE
353 SvREFCNT_dec (INT2PTR(SV*,p[1]));
363 dSP; dMARK; dORIGMARK;
364 register SV *tmpForm = *++MARK;
371 register SV *sv = Nullsv;
376 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
377 char *chophere = Nullch;
378 char *linemark = Nullch;
380 bool gotsome = FALSE;
382 STRLEN fudge = SvPOK(tmpForm)
383 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
384 bool item_is_utf8 = FALSE;
385 bool targ_is_utf8 = FALSE;
391 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
392 if (SvREADONLY(tmpForm)) {
393 SvREADONLY_off(tmpForm);
394 parseres = doparseform(tmpForm);
395 SvREADONLY_on(tmpForm);
398 parseres = doparseform(tmpForm);
402 SvPV_force(PL_formtarget, len);
403 if (DO_UTF8(PL_formtarget))
405 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
407 f = SvPV(tmpForm, len);
408 /* need to jump to the next word */
409 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
418 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
419 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
420 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
421 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
422 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
424 case FF_CHECKNL: name = "CHECKNL"; break;
425 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
426 case FF_SPACE: name = "SPACE"; break;
427 case FF_HALFSPACE: name = "HALFSPACE"; break;
428 case FF_ITEM: name = "ITEM"; break;
429 case FF_CHOP: name = "CHOP"; break;
430 case FF_LINEGLOB: name = "LINEGLOB"; break;
431 case FF_NEWLINE: name = "NEWLINE"; break;
432 case FF_MORE: name = "MORE"; break;
433 case FF_LINEMARK: name = "LINEMARK"; break;
434 case FF_END: name = "END"; break;
435 case FF_0DECIMAL: name = "0DECIMAL"; break;
436 case FF_LINESNGL: name = "LINESNGL"; break;
439 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
441 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
452 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
453 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
455 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
456 t = SvEND(PL_formtarget);
459 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
460 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
462 sv_utf8_upgrade(PL_formtarget);
463 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
464 t = SvEND(PL_formtarget);
484 if (ckWARN(WARN_SYNTAX))
485 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
490 item = s = SvPV(sv, len);
493 itemsize = sv_len_utf8(sv);
494 if (itemsize != (I32)len) {
496 if (itemsize > fieldsize) {
497 itemsize = fieldsize;
498 itembytes = itemsize;
499 sv_pos_u2b(sv, &itembytes, 0);
503 send = chophere = s + itembytes;
513 sv_pos_b2u(sv, &itemsize);
517 item_is_utf8 = FALSE;
518 if (itemsize > fieldsize)
519 itemsize = fieldsize;
520 send = chophere = s + itemsize;
532 item = s = SvPV(sv, len);
535 itemsize = sv_len_utf8(sv);
536 if (itemsize != (I32)len) {
538 if (itemsize <= fieldsize) {
539 send = chophere = s + itemsize;
551 itemsize = fieldsize;
552 itembytes = itemsize;
553 sv_pos_u2b(sv, &itembytes, 0);
554 send = chophere = s + itembytes;
555 while (s < send || (s == send && isSPACE(*s))) {
565 if (strchr(PL_chopset, *s))
570 itemsize = chophere - item;
571 sv_pos_b2u(sv, &itemsize);
577 item_is_utf8 = FALSE;
578 if (itemsize <= fieldsize) {
579 send = chophere = s + itemsize;
591 itemsize = fieldsize;
592 send = chophere = s + itemsize;
593 while (s < send || (s == send && isSPACE(*s))) {
603 if (strchr(PL_chopset, *s))
608 itemsize = chophere - item;
613 arg = fieldsize - itemsize;
622 arg = fieldsize - itemsize;
636 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
638 sv_utf8_upgrade(PL_formtarget);
639 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
640 t = SvEND(PL_formtarget);
644 if (UTF8_IS_CONTINUED(*s)) {
645 STRLEN skip = UTF8SKIP(s);
662 if ( !((*t++ = *s++) & ~31) )
668 if (targ_is_utf8 && !item_is_utf8) {
669 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
671 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
672 for (; t < SvEND(PL_formtarget); t++) {
685 int ch = *t++ = *s++;
688 if ( !((*t++ = *s++) & ~31) )
697 while (*s && isSPACE(*s))
711 item = s = SvPV(sv, len);
713 if ((item_is_utf8 = DO_UTF8(sv)))
714 itemsize = sv_len_utf8(sv);
716 bool chopped = FALSE;
719 chophere = s + itemsize;
735 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
737 SvUTF8_on(PL_formtarget);
739 SvCUR_set(sv, chophere - item);
740 sv_catsv(PL_formtarget, sv);
741 SvCUR_set(sv, itemsize);
743 sv_catsv(PL_formtarget, sv);
745 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
746 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
747 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
755 #if defined(USE_LONG_DOUBLE)
756 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
758 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
763 #if defined(USE_LONG_DOUBLE)
764 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
766 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
769 /* If the field is marked with ^ and the value is undefined,
771 if ((arg & 512) && !SvOK(sv)) {
779 /* overflow evidence */
780 if (num_overflow(value, fieldsize, arg)) {
786 /* Formats aren't yet marked for locales, so assume "yes". */
788 STORE_NUMERIC_STANDARD_SET_LOCAL();
789 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
790 RESTORE_NUMERIC_STANDARD();
797 while (t-- > linemark && *t == ' ') ;
805 if (arg) { /* repeat until fields exhausted? */
807 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
808 lines += FmLINES(PL_formtarget);
811 if (strnEQ(linemark, linemark - arg, arg))
812 DIE(aTHX_ "Runaway format");
815 SvUTF8_on(PL_formtarget);
816 FmLINES(PL_formtarget) = lines;
818 RETURNOP(cLISTOP->op_first);
831 while (*s && isSPACE(*s) && s < send)
835 arg = fieldsize - itemsize;
842 if (strnEQ(s," ",3)) {
843 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
854 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
856 SvUTF8_on(PL_formtarget);
857 FmLINES(PL_formtarget) += lines;
869 if (PL_stack_base + *PL_markstack_ptr == SP) {
871 if (GIMME_V == G_SCALAR)
872 XPUSHs(sv_2mortal(newSViv(0)));
873 RETURNOP(PL_op->op_next->op_next);
875 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
876 pp_pushmark(); /* push dst */
877 pp_pushmark(); /* push src */
878 ENTER; /* enter outer scope */
881 if (PL_op->op_private & OPpGREP_LEX)
882 SAVESPTR(PAD_SVl(PL_op->op_targ));
885 ENTER; /* enter inner scope */
888 src = PL_stack_base[*PL_markstack_ptr];
890 if (PL_op->op_private & OPpGREP_LEX)
891 PAD_SVl(PL_op->op_targ) = src;
896 if (PL_op->op_type == OP_MAPSTART)
897 pp_pushmark(); /* push top */
898 return ((LOGOP*)PL_op->op_next)->op_other;
903 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
910 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
916 /* first, move source pointer to the next item in the source list */
917 ++PL_markstack_ptr[-1];
919 /* if there are new items, push them into the destination list */
920 if (items && gimme != G_VOID) {
921 /* might need to make room back there first */
922 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
923 /* XXX this implementation is very pessimal because the stack
924 * is repeatedly extended for every set of items. Is possible
925 * to do this without any stack extension or copying at all
926 * by maintaining a separate list over which the map iterates
927 * (like foreach does). --gsar */
929 /* everything in the stack after the destination list moves
930 * towards the end the stack by the amount of room needed */
931 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
933 /* items to shift up (accounting for the moved source pointer) */
934 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
936 /* This optimization is by Ben Tilly and it does
937 * things differently from what Sarathy (gsar)
938 * is describing. The downside of this optimization is
939 * that leaves "holes" (uninitialized and hopefully unused areas)
940 * to the Perl stack, but on the other hand this
941 * shouldn't be a problem. If Sarathy's idea gets
942 * implemented, this optimization should become
943 * irrelevant. --jhi */
945 shift = count; /* Avoid shifting too often --Ben Tilly */
950 PL_markstack_ptr[-1] += shift;
951 *PL_markstack_ptr += shift;
955 /* copy the new items down to the destination list */
956 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
957 if (gimme == G_ARRAY) {
959 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
962 /* scalar context: we don't care about which values map returns
963 * (we use undef here). And so we certainly don't want to do mortal
964 * copies of meaningless values. */
965 while (items-- > 0) {
967 *dst-- = &PL_sv_undef;
971 LEAVE; /* exit inner scope */
974 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
976 (void)POPMARK; /* pop top */
977 LEAVE; /* exit outer scope */
978 (void)POPMARK; /* pop src */
979 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
980 (void)POPMARK; /* pop dst */
981 SP = PL_stack_base + POPMARK; /* pop original mark */
982 if (gimme == G_SCALAR) {
983 if (PL_op->op_private & OPpGREP_LEX) {
984 SV* sv = sv_newmortal();
993 else if (gimme == G_ARRAY)
1000 ENTER; /* enter inner scope */
1003 /* set $_ to the new source item */
1004 src = PL_stack_base[PL_markstack_ptr[-1]];
1006 if (PL_op->op_private & OPpGREP_LEX)
1007 PAD_SVl(PL_op->op_targ) = src;
1011 RETURNOP(cLOGOP->op_other);
1019 if (GIMME == G_ARRAY)
1021 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1022 return cLOGOP->op_other;
1031 if (GIMME == G_ARRAY) {
1032 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1036 SV *targ = PAD_SV(PL_op->op_targ);
1039 if (PL_op->op_private & OPpFLIP_LINENUM) {
1040 if (GvIO(PL_last_in_gv)) {
1041 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1044 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1045 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1051 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1052 if (PL_op->op_flags & OPf_SPECIAL) {
1060 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1069 /* This code tries to decide if "$left .. $right" should use the
1070 magical string increment, or if the range is numeric (we make
1071 an exception for .."0" [#18165]). AMS 20021031. */
1073 #define RANGE_IS_NUMERIC(left,right) ( \
1074 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1075 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1076 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1077 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1078 && (!SvOK(right) || looks_like_number(right))))
1084 if (GIMME == G_ARRAY) {
1090 if (SvGMAGICAL(left))
1092 if (SvGMAGICAL(right))
1095 if (RANGE_IS_NUMERIC(left,right)) {
1096 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1097 (SvOK(right) && SvNV(right) > IV_MAX))
1098 DIE(aTHX_ "Range iterator outside integer range");
1109 sv = sv_2mortal(newSViv(i++));
1114 SV *final = sv_mortalcopy(right);
1116 char *tmps = SvPV(final, len);
1118 sv = sv_mortalcopy(left);
1120 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1122 if (strEQ(SvPVX(sv),tmps))
1124 sv = sv_2mortal(newSVsv(sv));
1131 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1135 if (PL_op->op_private & OPpFLIP_LINENUM) {
1136 if (GvIO(PL_last_in_gv)) {
1137 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1140 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1141 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1149 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1150 sv_catpv(targ, "E0");
1160 static char *context_name[] = {
1171 S_dopoptolabel(pTHX_ char *label)
1174 register PERL_CONTEXT *cx;
1176 for (i = cxstack_ix; i >= 0; i--) {
1178 switch (CxTYPE(cx)) {
1184 if (ckWARN(WARN_EXITING))
1185 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1186 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1187 if (CxTYPE(cx) == CXt_NULL)
1191 if (!cx->blk_loop.label ||
1192 strNE(label, cx->blk_loop.label) ) {
1193 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1194 (long)i, cx->blk_loop.label));
1197 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1205 Perl_dowantarray(pTHX)
1207 I32 gimme = block_gimme();
1208 return (gimme == G_VOID) ? G_SCALAR : gimme;
1212 Perl_block_gimme(pTHX)
1216 cxix = dopoptosub(cxstack_ix);
1220 switch (cxstack[cxix].blk_gimme) {
1228 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1235 Perl_is_lvalue_sub(pTHX)
1239 cxix = dopoptosub(cxstack_ix);
1240 assert(cxix >= 0); /* We should only be called from inside subs */
1242 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1243 return cxstack[cxix].blk_sub.lval;
1249 S_dopoptosub(pTHX_ I32 startingblock)
1251 return dopoptosub_at(cxstack, startingblock);
1255 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1258 register PERL_CONTEXT *cx;
1259 for (i = startingblock; i >= 0; i--) {
1261 switch (CxTYPE(cx)) {
1267 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1275 S_dopoptoeval(pTHX_ I32 startingblock)
1278 register PERL_CONTEXT *cx;
1279 for (i = startingblock; i >= 0; i--) {
1281 switch (CxTYPE(cx)) {
1285 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1293 S_dopoptoloop(pTHX_ I32 startingblock)
1296 register PERL_CONTEXT *cx;
1297 for (i = startingblock; i >= 0; i--) {
1299 switch (CxTYPE(cx)) {
1305 if (ckWARN(WARN_EXITING))
1306 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1307 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1308 if ((CxTYPE(cx)) == CXt_NULL)
1312 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1320 Perl_dounwind(pTHX_ I32 cxix)
1322 register PERL_CONTEXT *cx;
1325 while (cxstack_ix > cxix) {
1327 cx = &cxstack[cxstack_ix];
1328 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1329 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1330 /* Note: we don't need to restore the base context info till the end. */
1331 switch (CxTYPE(cx)) {
1334 continue; /* not break */
1356 Perl_qerror(pTHX_ SV *err)
1359 sv_catsv(ERRSV, err);
1361 sv_catsv(PL_errors, err);
1363 Perl_warn(aTHX_ "%"SVf, err);
1368 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1374 register PERL_CONTEXT *cx;
1379 if (PL_in_eval & EVAL_KEEPERR) {
1380 static char prefix[] = "\t(in cleanup) ";
1385 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1388 if (*e != *message || strNE(e,message))
1392 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1393 sv_catpvn(err, prefix, sizeof(prefix)-1);
1394 sv_catpvn(err, message, msglen);
1395 if (ckWARN(WARN_MISC)) {
1396 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1397 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1402 sv_setpvn(ERRSV, message, msglen);
1406 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1407 && PL_curstackinfo->si_prev)
1416 if (cxix < cxstack_ix)
1419 POPBLOCK(cx,PL_curpm);
1420 if (CxTYPE(cx) != CXt_EVAL) {
1422 message = SvPVx(ERRSV, msglen);
1423 PerlIO_write(Perl_error_log, "panic: die ", 11);
1424 PerlIO_write(Perl_error_log, message, msglen);
1429 if (gimme == G_SCALAR)
1430 *++newsp = &PL_sv_undef;
1431 PL_stack_sp = newsp;
1435 /* LEAVE could clobber PL_curcop (see save_re_context())
1436 * XXX it might be better to find a way to avoid messing with
1437 * PL_curcop in save_re_context() instead, but this is a more
1438 * minimal fix --GSAR */
1439 PL_curcop = cx->blk_oldcop;
1441 if (optype == OP_REQUIRE) {
1442 char* msg = SvPVx(ERRSV, n_a);
1443 SV *nsv = cx->blk_eval.old_namesv;
1444 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1446 DIE(aTHX_ "%sCompilation failed in require",
1447 *msg ? msg : "Unknown error\n");
1449 assert(CxTYPE(cx) == CXt_EVAL);
1450 return cx->blk_eval.retop;
1454 message = SvPVx(ERRSV, msglen);
1456 write_to_stderr(message, msglen);
1465 if (SvTRUE(left) != SvTRUE(right))
1477 RETURNOP(cLOGOP->op_other);
1486 RETURNOP(cLOGOP->op_other);
1495 if (!sv || !SvANY(sv)) {
1496 RETURNOP(cLOGOP->op_other);
1499 switch (SvTYPE(sv)) {
1501 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1505 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1509 if (CvROOT(sv) || CvXSUB(sv))
1519 RETURNOP(cLOGOP->op_other);
1525 register I32 cxix = dopoptosub(cxstack_ix);
1526 register PERL_CONTEXT *cx;
1527 register PERL_CONTEXT *ccstack = cxstack;
1528 PERL_SI *top_si = PL_curstackinfo;
1539 /* we may be in a higher stacklevel, so dig down deeper */
1540 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1541 top_si = top_si->si_prev;
1542 ccstack = top_si->si_cxstack;
1543 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1546 if (GIMME != G_ARRAY) {
1552 if (PL_DBsub && cxix >= 0 &&
1553 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1557 cxix = dopoptosub_at(ccstack, cxix - 1);
1560 cx = &ccstack[cxix];
1561 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1562 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1563 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1564 field below is defined for any cx. */
1565 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1566 cx = &ccstack[dbcxix];
1569 stashname = CopSTASHPV(cx->blk_oldcop);
1570 if (GIMME != G_ARRAY) {
1573 PUSHs(&PL_sv_undef);
1576 sv_setpv(TARG, stashname);
1585 PUSHs(&PL_sv_undef);
1587 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1588 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1589 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1592 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1593 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1594 /* So is ccstack[dbcxix]. */
1597 gv_efullname3(sv, cvgv, Nullch);
1598 PUSHs(sv_2mortal(sv));
1599 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1602 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1603 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1607 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1608 PUSHs(sv_2mortal(newSViv(0)));
1610 gimme = (I32)cx->blk_gimme;
1611 if (gimme == G_VOID)
1612 PUSHs(&PL_sv_undef);
1614 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1615 if (CxTYPE(cx) == CXt_EVAL) {
1617 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1618 PUSHs(cx->blk_eval.cur_text);
1622 else if (cx->blk_eval.old_namesv) {
1623 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1626 /* eval BLOCK (try blocks have old_namesv == 0) */
1628 PUSHs(&PL_sv_undef);
1629 PUSHs(&PL_sv_undef);
1633 PUSHs(&PL_sv_undef);
1634 PUSHs(&PL_sv_undef);
1636 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1637 && CopSTASH_eq(PL_curcop, PL_debstash))
1639 AV *ary = cx->blk_sub.argarray;
1640 int off = AvARRAY(ary) - AvALLOC(ary);
1644 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1647 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1650 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1651 av_extend(PL_dbargs, AvFILLp(ary) + off);
1652 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1653 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1655 /* XXX only hints propagated via op_private are currently
1656 * visible (others are not easily accessible, since they
1657 * use the global PL_hints) */
1658 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1659 HINT_PRIVATE_MASK)));
1662 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1664 if (old_warnings == pWARN_NONE ||
1665 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1666 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1667 else if (old_warnings == pWARN_ALL ||
1668 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1669 /* Get the bit mask for $warnings::Bits{all}, because
1670 * it could have been extended by warnings::register */
1672 HV *bits = get_hv("warnings::Bits", FALSE);
1673 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1674 mask = newSVsv(*bits_all);
1677 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1681 mask = newSVsv(old_warnings);
1682 PUSHs(sv_2mortal(mask));
1697 sv_reset(tmps, CopSTASH(PL_curcop));
1707 /* like pp_nextstate, but used instead when the debugger is active */
1711 PL_curcop = (COP*)PL_op;
1712 TAINT_NOT; /* Each statement is presumed innocent */
1713 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1716 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1717 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1721 register PERL_CONTEXT *cx;
1722 I32 gimme = G_ARRAY;
1729 DIE(aTHX_ "No DB::DB routine defined");
1731 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1732 /* don't do recursive DB::DB call */
1744 PUSHBLOCK(cx, CXt_SUB, SP);
1746 cx->blk_sub.retop = PL_op->op_next;
1748 PAD_SET_CUR(CvPADLIST(cv),1);
1749 RETURNOP(CvSTART(cv));
1763 register PERL_CONTEXT *cx;
1764 I32 gimme = GIMME_V;
1766 U32 cxtype = CXt_LOOP;
1774 if (PL_op->op_targ) {
1775 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1776 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1777 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1778 SVs_PADSTALE, SVs_PADSTALE);
1780 #ifndef USE_ITHREADS
1781 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1784 SAVEPADSV(PL_op->op_targ);
1785 iterdata = INT2PTR(void*, PL_op->op_targ);
1786 cxtype |= CXp_PADVAR;
1791 svp = &GvSV(gv); /* symbol table variable */
1792 SAVEGENERICSV(*svp);
1795 iterdata = (void*)gv;
1801 PUSHBLOCK(cx, cxtype, SP);
1803 PUSHLOOP(cx, iterdata, MARK);
1805 PUSHLOOP(cx, svp, MARK);
1807 if (PL_op->op_flags & OPf_STACKED) {
1808 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1809 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1811 SV *right = (SV*)cx->blk_loop.iterary;
1812 if (RANGE_IS_NUMERIC(sv,right)) {
1813 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1814 (SvOK(right) && SvNV(right) >= IV_MAX))
1815 DIE(aTHX_ "Range iterator outside integer range");
1816 cx->blk_loop.iterix = SvIV(sv);
1817 cx->blk_loop.itermax = SvIV(right);
1821 cx->blk_loop.iterlval = newSVsv(sv);
1822 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1823 (void) SvPV(right,n_a);
1826 else if (PL_op->op_private & OPpITER_REVERSED) {
1827 cx->blk_loop.itermax = -1;
1828 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1833 cx->blk_loop.iterary = PL_curstack;
1834 AvFILLp(PL_curstack) = SP - PL_stack_base;
1835 if (PL_op->op_private & OPpITER_REVERSED) {
1836 cx->blk_loop.itermax = MARK - PL_stack_base;
1837 cx->blk_loop.iterix = cx->blk_oldsp;
1840 cx->blk_loop.iterix = MARK - PL_stack_base;
1850 register PERL_CONTEXT *cx;
1851 I32 gimme = GIMME_V;
1857 PUSHBLOCK(cx, CXt_LOOP, SP);
1858 PUSHLOOP(cx, 0, SP);
1866 register PERL_CONTEXT *cx;
1874 newsp = PL_stack_base + cx->blk_loop.resetsp;
1877 if (gimme == G_VOID)
1879 else if (gimme == G_SCALAR) {
1881 *++newsp = sv_mortalcopy(*SP);
1883 *++newsp = &PL_sv_undef;
1887 *++newsp = sv_mortalcopy(*++mark);
1888 TAINT_NOT; /* Each item is independent */
1894 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1895 PL_curpm = newpm; /* ... and pop $1 et al */
1907 register PERL_CONTEXT *cx;
1908 bool popsub2 = FALSE;
1909 bool clear_errsv = FALSE;
1917 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1918 if (cxstack_ix == PL_sortcxix
1919 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1921 if (cxstack_ix > PL_sortcxix)
1922 dounwind(PL_sortcxix);
1923 AvARRAY(PL_curstack)[1] = *SP;
1924 PL_stack_sp = PL_stack_base + 1;
1929 cxix = dopoptosub(cxstack_ix);
1931 DIE(aTHX_ "Can't return outside a subroutine");
1932 if (cxix < cxstack_ix)
1936 switch (CxTYPE(cx)) {
1939 retop = cx->blk_sub.retop;
1940 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1943 if (!(PL_in_eval & EVAL_KEEPERR))
1946 retop = cx->blk_eval.retop;
1950 if (optype == OP_REQUIRE &&
1951 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1953 /* Unassume the success we assumed earlier. */
1954 SV *nsv = cx->blk_eval.old_namesv;
1955 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1956 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1961 retop = cx->blk_sub.retop;
1964 DIE(aTHX_ "panic: return");
1968 if (gimme == G_SCALAR) {
1971 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1973 *++newsp = SvREFCNT_inc(*SP);
1978 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1980 *++newsp = sv_mortalcopy(sv);
1985 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1988 *++newsp = sv_mortalcopy(*SP);
1991 *++newsp = &PL_sv_undef;
1993 else if (gimme == G_ARRAY) {
1994 while (++MARK <= SP) {
1995 *++newsp = (popsub2 && SvTEMP(*MARK))
1996 ? *MARK : sv_mortalcopy(*MARK);
1997 TAINT_NOT; /* Each item is independent */
2000 PL_stack_sp = newsp;
2003 /* Stack values are safe: */
2006 POPSUB(cx,sv); /* release CV and @_ ... */
2010 PL_curpm = newpm; /* ... and pop $1 et al */
2022 register PERL_CONTEXT *cx;
2032 if (PL_op->op_flags & OPf_SPECIAL) {
2033 cxix = dopoptoloop(cxstack_ix);
2035 DIE(aTHX_ "Can't \"last\" outside a loop block");
2038 cxix = dopoptolabel(cPVOP->op_pv);
2040 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2042 if (cxix < cxstack_ix)
2046 cxstack_ix++; /* temporarily protect top context */
2048 switch (CxTYPE(cx)) {
2051 newsp = PL_stack_base + cx->blk_loop.resetsp;
2052 nextop = cx->blk_loop.last_op->op_next;
2056 nextop = cx->blk_sub.retop;
2060 nextop = cx->blk_eval.retop;
2064 nextop = cx->blk_sub.retop;
2067 DIE(aTHX_ "panic: last");
2071 if (gimme == G_SCALAR) {
2073 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2074 ? *SP : sv_mortalcopy(*SP);
2076 *++newsp = &PL_sv_undef;
2078 else if (gimme == G_ARRAY) {
2079 while (++MARK <= SP) {
2080 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2081 ? *MARK : sv_mortalcopy(*MARK);
2082 TAINT_NOT; /* Each item is independent */
2090 /* Stack values are safe: */
2093 POPLOOP(cx); /* release loop vars ... */
2097 POPSUB(cx,sv); /* release CV and @_ ... */
2100 PL_curpm = newpm; /* ... and pop $1 et al */
2109 register PERL_CONTEXT *cx;
2112 if (PL_op->op_flags & OPf_SPECIAL) {
2113 cxix = dopoptoloop(cxstack_ix);
2115 DIE(aTHX_ "Can't \"next\" outside a loop block");
2118 cxix = dopoptolabel(cPVOP->op_pv);
2120 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2122 if (cxix < cxstack_ix)
2125 /* clear off anything above the scope we're re-entering, but
2126 * save the rest until after a possible continue block */
2127 inner = PL_scopestack_ix;
2129 if (PL_scopestack_ix < inner)
2130 leave_scope(PL_scopestack[PL_scopestack_ix]);
2131 return cx->blk_loop.next_op;
2137 register PERL_CONTEXT *cx;
2140 if (PL_op->op_flags & OPf_SPECIAL) {
2141 cxix = dopoptoloop(cxstack_ix);
2143 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2146 cxix = dopoptolabel(cPVOP->op_pv);
2148 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2150 if (cxix < cxstack_ix)
2154 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2155 LEAVE_SCOPE(oldsave);
2157 return cx->blk_loop.redo_op;
2161 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2165 static char too_deep[] = "Target of goto is too deeply nested";
2168 Perl_croak(aTHX_ too_deep);
2169 if (o->op_type == OP_LEAVE ||
2170 o->op_type == OP_SCOPE ||
2171 o->op_type == OP_LEAVELOOP ||
2172 o->op_type == OP_LEAVESUB ||
2173 o->op_type == OP_LEAVETRY)
2175 *ops++ = cUNOPo->op_first;
2177 Perl_croak(aTHX_ too_deep);
2180 if (o->op_flags & OPf_KIDS) {
2181 /* First try all the kids at this level, since that's likeliest. */
2182 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2183 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2184 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2187 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2188 if (kid == PL_lastgotoprobe)
2190 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2193 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2194 ops[-1]->op_type == OP_DBSTATE)
2199 if ((o = dofindlabel(kid, label, ops, oplimit)))
2218 register PERL_CONTEXT *cx;
2219 #define GOTO_DEPTH 64
2220 OP *enterops[GOTO_DEPTH];
2222 int do_dump = (PL_op->op_type == OP_DUMP);
2223 static char must_have_label[] = "goto must have label";
2227 if (PL_op->op_flags & OPf_STACKED) {
2231 /* This egregious kludge implements goto &subroutine */
2232 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2234 register PERL_CONTEXT *cx;
2235 CV* cv = (CV*)SvRV(sv);
2241 if (!CvROOT(cv) && !CvXSUB(cv)) {
2246 /* autoloaded stub? */
2247 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2249 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2250 GvNAMELEN(gv), FALSE);
2251 if (autogv && (cv = GvCV(autogv)))
2253 tmpstr = sv_newmortal();
2254 gv_efullname3(tmpstr, gv, Nullch);
2255 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2257 DIE(aTHX_ "Goto undefined subroutine");
2260 /* First do some returnish stuff. */
2261 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2263 cxix = dopoptosub(cxstack_ix);
2265 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2266 if (cxix < cxstack_ix)
2270 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2271 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2272 /* put @_ back onto stack */
2273 AV* av = cx->blk_sub.argarray;
2275 items = AvFILLp(av) + 1;
2276 EXTEND(SP, items+1); /* @_ could have been extended. */
2277 Copy(AvARRAY(av), SP + 1, items, SV*);
2278 SvREFCNT_dec(GvAV(PL_defgv));
2279 GvAV(PL_defgv) = cx->blk_sub.savearray;
2280 /* abandon @_ if it got reified */
2282 oldav = av; /* delay until return */
2284 av_extend(av, items-1);
2285 AvFLAGS(av) = AVf_REIFY;
2286 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2291 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2293 av = GvAV(PL_defgv);
2294 items = AvFILLp(av) + 1;
2295 EXTEND(SP, items+1); /* @_ could have been extended. */
2296 Copy(AvARRAY(av), SP + 1, items, SV*);
2300 if (CxTYPE(cx) == CXt_SUB &&
2301 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2302 SvREFCNT_dec(cx->blk_sub.cv);
2303 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2304 LEAVE_SCOPE(oldsave);
2306 /* Now do some callish stuff. */
2308 /* For reified @_, delay freeing till return from new sub */
2310 SAVEFREESV((SV*)oldav);
2311 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2313 #ifdef PERL_XSUB_OLDSTYLE
2314 if (CvOLDSTYLE(cv)) {
2315 I32 (*fp3)(int,int,int);
2320 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2321 items = (*fp3)(CvXSUBANY(cv).any_i32,
2322 mark - PL_stack_base + 1,
2324 SP = PL_stack_base + items;
2327 #endif /* PERL_XSUB_OLDSTYLE */
2332 /* Push a mark for the start of arglist */
2335 (void)(*CvXSUB(cv))(aTHX_ cv);
2336 /* Pop the current context like a decent sub should */
2337 POPBLOCK(cx, PL_curpm);
2338 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2341 assert(CxTYPE(cx) == CXt_SUB);
2342 return cx->blk_sub.retop;
2345 AV* padlist = CvPADLIST(cv);
2346 if (CxTYPE(cx) == CXt_EVAL) {
2347 PL_in_eval = cx->blk_eval.old_in_eval;
2348 PL_eval_root = cx->blk_eval.old_eval_root;
2349 cx->cx_type = CXt_SUB;
2350 cx->blk_sub.hasargs = 0;
2352 cx->blk_sub.cv = cv;
2353 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2356 if (CvDEPTH(cv) < 2)
2357 (void)SvREFCNT_inc(cv);
2359 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2360 sub_crush_depth(cv);
2361 pad_push(padlist, CvDEPTH(cv), 1);
2363 PAD_SET_CUR(padlist, CvDEPTH(cv));
2364 if (cx->blk_sub.hasargs)
2366 AV* av = (AV*)PAD_SVl(0);
2369 cx->blk_sub.savearray = GvAV(PL_defgv);
2370 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2371 CX_CURPAD_SAVE(cx->blk_sub);
2372 cx->blk_sub.argarray = av;
2374 if (items >= AvMAX(av) + 1) {
2376 if (AvARRAY(av) != ary) {
2377 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2378 SvPVX(av) = (char*)ary;
2380 if (items >= AvMAX(av) + 1) {
2381 AvMAX(av) = items - 1;
2382 Renew(ary,items+1,SV*);
2384 SvPVX(av) = (char*)ary;
2388 Copy(mark,AvARRAY(av),items,SV*);
2389 AvFILLp(av) = items - 1;
2390 assert(!AvREAL(av));
2397 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2399 * We do not care about using sv to call CV;
2400 * it's for informational purposes only.
2402 SV *sv = GvSV(PL_DBsub);
2405 if (PERLDB_SUB_NN) {
2406 (void)SvUPGRADE(sv, SVt_PVIV);
2409 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2412 gv_efullname3(sv, CvGV(cv), Nullch);
2415 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2416 PUSHMARK( PL_stack_sp );
2417 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2421 RETURNOP(CvSTART(cv));
2425 label = SvPV(sv,n_a);
2426 if (!(do_dump || *label))
2427 DIE(aTHX_ must_have_label);
2430 else if (PL_op->op_flags & OPf_SPECIAL) {
2432 DIE(aTHX_ must_have_label);
2435 label = cPVOP->op_pv;
2437 if (label && *label) {
2439 bool leaving_eval = FALSE;
2440 bool in_block = FALSE;
2441 PERL_CONTEXT *last_eval_cx = 0;
2445 PL_lastgotoprobe = 0;
2447 for (ix = cxstack_ix; ix >= 0; ix--) {
2449 switch (CxTYPE(cx)) {
2451 leaving_eval = TRUE;
2452 if (!CxTRYBLOCK(cx)) {
2453 gotoprobe = (last_eval_cx ?
2454 last_eval_cx->blk_eval.old_eval_root :
2459 /* else fall through */
2461 gotoprobe = cx->blk_oldcop->op_sibling;
2467 gotoprobe = cx->blk_oldcop->op_sibling;
2470 gotoprobe = PL_main_root;
2473 if (CvDEPTH(cx->blk_sub.cv)) {
2474 gotoprobe = CvROOT(cx->blk_sub.cv);
2480 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2483 DIE(aTHX_ "panic: goto");
2484 gotoprobe = PL_main_root;
2488 retop = dofindlabel(gotoprobe, label,
2489 enterops, enterops + GOTO_DEPTH);
2493 PL_lastgotoprobe = gotoprobe;
2496 DIE(aTHX_ "Can't find label %s", label);
2498 /* if we're leaving an eval, check before we pop any frames
2499 that we're not going to punt, otherwise the error
2502 if (leaving_eval && *enterops && enterops[1]) {
2504 for (i = 1; enterops[i]; i++)
2505 if (enterops[i]->op_type == OP_ENTERITER)
2506 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2509 /* pop unwanted frames */
2511 if (ix < cxstack_ix) {
2518 oldsave = PL_scopestack[PL_scopestack_ix];
2519 LEAVE_SCOPE(oldsave);
2522 /* push wanted frames */
2524 if (*enterops && enterops[1]) {
2526 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2527 for (; enterops[ix]; ix++) {
2528 PL_op = enterops[ix];
2529 /* Eventually we may want to stack the needed arguments
2530 * for each op. For now, we punt on the hard ones. */
2531 if (PL_op->op_type == OP_ENTERITER)
2532 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2533 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2541 if (!retop) retop = PL_main_start;
2543 PL_restartop = retop;
2544 PL_do_undump = TRUE;
2548 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2549 PL_do_undump = FALSE;
2565 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2567 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2570 PL_exit_flags |= PERL_EXIT_EXPECTED;
2572 PUSHs(&PL_sv_undef);
2580 NV value = SvNVx(GvSV(cCOP->cop_gv));
2581 register I32 match = I_32(value);
2584 if (((NV)match) > value)
2585 --match; /* was fractional--truncate other way */
2587 match -= cCOP->uop.scop.scop_offset;
2590 else if (match > cCOP->uop.scop.scop_max)
2591 match = cCOP->uop.scop.scop_max;
2592 PL_op = cCOP->uop.scop.scop_next[match];
2602 PL_op = PL_op->op_next; /* can't assume anything */
2605 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2606 match -= cCOP->uop.scop.scop_offset;
2609 else if (match > cCOP->uop.scop.scop_max)
2610 match = cCOP->uop.scop.scop_max;
2611 PL_op = cCOP->uop.scop.scop_next[match];
2620 S_save_lines(pTHX_ AV *array, SV *sv)
2622 register char *s = SvPVX(sv);
2623 register char *send = SvPVX(sv) + SvCUR(sv);
2625 register I32 line = 1;
2627 while (s && s < send) {
2628 SV *tmpstr = NEWSV(85,0);
2630 sv_upgrade(tmpstr, SVt_PVMG);
2631 t = strchr(s, '\n');
2637 sv_setpvn(tmpstr, s, t - s);
2638 av_store(array, line++, tmpstr);
2643 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2645 S_docatch_body(pTHX_ va_list args)
2647 return docatch_body();
2652 S_docatch_body(pTHX)
2659 S_docatch(pTHX_ OP *o)
2664 volatile PERL_SI *cursi = PL_curstackinfo;
2668 assert(CATCH_GET == TRUE);
2672 /* Normally, the leavetry at the end of this block of ops will
2673 * pop an op off the return stack and continue there. By setting
2674 * the op to Nullop, we force an exit from the inner runops()
2677 assert(cxstack_ix >= 0);
2678 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2679 retop = cxstack[cxstack_ix].blk_eval.retop;
2680 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2682 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2684 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2690 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2696 /* die caught by an inner eval - continue inner loop */
2697 if (PL_restartop && cursi == PL_curstackinfo) {
2698 PL_op = PL_restartop;
2702 /* a die in this eval - continue in outer loop */
2718 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2719 /* sv Text to convert to OP tree. */
2720 /* startop op_free() this to undo. */
2721 /* code Short string id of the caller. */
2723 dSP; /* Make POPBLOCK work. */
2726 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2730 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2731 char *tmpbuf = tbuf;
2734 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2739 /* switch to eval mode */
2741 if (IN_PERL_COMPILETIME) {
2742 SAVECOPSTASH_FREE(&PL_compiling);
2743 CopSTASH_set(&PL_compiling, PL_curstash);
2745 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2746 SV *sv = sv_newmortal();
2747 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2748 code, (unsigned long)++PL_evalseq,
2749 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2753 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2754 SAVECOPFILE_FREE(&PL_compiling);
2755 CopFILE_set(&PL_compiling, tmpbuf+2);
2756 SAVECOPLINE(&PL_compiling);
2757 CopLINE_set(&PL_compiling, 1);
2758 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2759 deleting the eval's FILEGV from the stash before gv_check() runs
2760 (i.e. before run-time proper). To work around the coredump that
2761 ensues, we always turn GvMULTI_on for any globals that were
2762 introduced within evals. See force_ident(). GSAR 96-10-12 */
2763 safestr = savepv(tmpbuf);
2764 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2766 #ifdef OP_IN_REGISTER
2772 /* we get here either during compilation, or via pp_regcomp at runtime */
2773 runtime = IN_PERL_RUNTIME;
2775 runcv = find_runcv(NULL);
2778 PL_op->op_type = OP_ENTEREVAL;
2779 PL_op->op_flags = 0; /* Avoid uninit warning. */
2780 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2781 PUSHEVAL(cx, 0, Nullgv);
2784 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2786 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2787 POPBLOCK(cx,PL_curpm);
2790 (*startop)->op_type = OP_NULL;
2791 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2793 /* XXX DAPM do this properly one year */
2794 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2796 if (IN_PERL_COMPILETIME)
2797 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2798 #ifdef OP_IN_REGISTER
2806 =for apidoc find_runcv
2808 Locate the CV corresponding to the currently executing sub or eval.
2809 If db_seqp is non_null, skip CVs that are in the DB package and populate
2810 *db_seqp with the cop sequence number at the point that the DB:: code was
2811 entered. (allows debuggers to eval in the scope of the breakpoint rather
2812 than in in the scope of the debugger itself).
2818 Perl_find_runcv(pTHX_ U32 *db_seqp)
2825 *db_seqp = PL_curcop->cop_seq;
2826 for (si = PL_curstackinfo; si; si = si->si_prev) {
2827 for (ix = si->si_cxix; ix >= 0; ix--) {
2828 cx = &(si->si_cxstack[ix]);
2829 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2830 CV *cv = cx->blk_sub.cv;
2831 /* skip DB:: code */
2832 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2833 *db_seqp = cx->blk_oldcop->cop_seq;
2838 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2846 /* Compile a require/do, an eval '', or a /(?{...})/.
2847 * In the last case, startop is non-null, and contains the address of
2848 * a pointer that should be set to the just-compiled code.
2849 * outside is the lexically enclosing CV (if any) that invoked us.
2852 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2854 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2859 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2860 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2865 SAVESPTR(PL_compcv);
2866 PL_compcv = (CV*)NEWSV(1104,0);
2867 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2868 CvEVAL_on(PL_compcv);
2869 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2870 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2872 CvOUTSIDE_SEQ(PL_compcv) = seq;
2873 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2875 /* set up a scratch pad */
2877 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2880 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2882 /* make sure we compile in the right package */
2884 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2885 SAVESPTR(PL_curstash);
2886 PL_curstash = CopSTASH(PL_curcop);
2888 SAVESPTR(PL_beginav);
2889 PL_beginav = newAV();
2890 SAVEFREESV(PL_beginav);
2891 SAVEI32(PL_error_count);
2893 /* try to compile it */
2895 PL_eval_root = Nullop;
2897 PL_curcop = &PL_compiling;
2898 PL_curcop->cop_arybase = 0;
2899 if (saveop && saveop->op_flags & OPf_SPECIAL)
2900 PL_in_eval |= EVAL_KEEPERR;
2903 if (yyparse() || PL_error_count || !PL_eval_root) {
2904 SV **newsp; /* Used by POPBLOCK. */
2905 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2906 I32 optype = 0; /* Might be reset by POPEVAL. */
2911 op_free(PL_eval_root);
2912 PL_eval_root = Nullop;
2914 SP = PL_stack_base + POPMARK; /* pop original mark */
2916 POPBLOCK(cx,PL_curpm);
2921 if (optype == OP_REQUIRE) {
2922 char* msg = SvPVx(ERRSV, n_a);
2923 SV *nsv = cx->blk_eval.old_namesv;
2924 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2926 DIE(aTHX_ "%sCompilation failed in require",
2927 *msg ? msg : "Unknown error\n");
2930 char* msg = SvPVx(ERRSV, n_a);
2932 POPBLOCK(cx,PL_curpm);
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
2938 char* msg = SvPVx(ERRSV, n_a);
2940 sv_setpv(ERRSV, "Compilation error");
2945 CopLINE_set(&PL_compiling, 0);
2947 *startop = PL_eval_root;
2949 SAVEFREEOP(PL_eval_root);
2951 /* Set the context for this new optree.
2952 * If the last op is an OP_REQUIRE, force scalar context.
2953 * Otherwise, propagate the context from the eval(). */
2954 if (PL_eval_root->op_type == OP_LEAVEEVAL
2955 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2956 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2958 scalar(PL_eval_root);
2959 else if (gimme & G_VOID)
2960 scalarvoid(PL_eval_root);
2961 else if (gimme & G_ARRAY)
2964 scalar(PL_eval_root);
2966 DEBUG_x(dump_eval());
2968 /* Register with debugger: */
2969 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2970 CV *cv = get_cv("DB::postponed", FALSE);
2974 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2976 call_sv((SV*)cv, G_DISCARD);
2980 /* compiled okay, so do it */
2982 CvDEPTH(PL_compcv) = 1;
2983 SP = PL_stack_base + POPMARK; /* pop original mark */
2984 PL_op = saveop; /* The caller may need it. */
2985 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2987 RETURNOP(PL_eval_start);
2991 S_doopen_pm(pTHX_ const char *name, const char *mode)
2993 #ifndef PERL_DISABLE_PMC
2994 STRLEN namelen = strlen(name);
2997 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2998 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2999 char *pmc = SvPV_nolen(pmcsv);
3002 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3003 fp = PerlIO_open(name, mode);
3006 if (PerlLIO_stat(name, &pmstat) < 0 ||
3007 pmstat.st_mtime < pmcstat.st_mtime)
3009 fp = PerlIO_open(pmc, mode);
3012 fp = PerlIO_open(name, mode);
3015 SvREFCNT_dec(pmcsv);
3018 fp = PerlIO_open(name, mode);
3022 return PerlIO_open(name, mode);
3023 #endif /* !PERL_DISABLE_PMC */
3029 register PERL_CONTEXT *cx;
3033 char *tryname = Nullch;
3034 SV *namesv = Nullsv;
3036 I32 gimme = GIMME_V;
3037 PerlIO *tryrsfp = 0;
3039 int filter_has_file = 0;
3040 GV *filter_child_proc = 0;
3041 SV *filter_state = 0;
3048 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3049 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3050 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3051 "v-string in use/require non-portable");
3053 sv = new_version(sv);
3054 if (!sv_derived_from(PL_patchlevel, "version"))
3055 (void *)upg_version(PL_patchlevel);
3056 if ( vcmp(sv,PL_patchlevel) > 0 )
3057 DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
3058 vstringify(sv), vstringify(PL_patchlevel));
3062 name = SvPV(sv, len);
3063 if (!(name && len > 0 && *name))
3064 DIE(aTHX_ "Null filename used");
3065 TAINT_PROPER("require");
3066 if (PL_op->op_type == OP_REQUIRE &&
3067 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3068 if (*svp != &PL_sv_undef)
3071 DIE(aTHX_ "Compilation failed in require");
3074 /* prepare to compile file */
3076 if (path_is_absolute(name)) {
3078 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3080 #ifdef MACOS_TRADITIONAL
3084 MacPerl_CanonDir(name, newname, 1);
3085 if (path_is_absolute(newname)) {
3087 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3092 AV *ar = GvAVn(PL_incgv);
3096 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3099 namesv = NEWSV(806, 0);
3100 for (i = 0; i <= AvFILL(ar); i++) {
3101 SV *dirsv = *av_fetch(ar, i, TRUE);
3107 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3108 && !sv_isobject(loader))
3110 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3113 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3114 PTR2UV(SvRV(dirsv)), name);
3115 tryname = SvPVX(namesv);
3126 if (sv_isobject(loader))
3127 count = call_method("INC", G_ARRAY);
3129 count = call_sv(loader, G_ARRAY);
3139 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3143 if (SvTYPE(arg) == SVt_PVGV) {
3144 IO *io = GvIO((GV *)arg);
3149 tryrsfp = IoIFP(io);
3150 if (IoTYPE(io) == IoTYPE_PIPE) {
3151 /* reading from a child process doesn't
3152 nest -- when returning from reading
3153 the inner module, the outer one is
3154 unreadable (closed?) I've tried to
3155 save the gv to manage the lifespan of
3156 the pipe, but this didn't help. XXX */
3157 filter_child_proc = (GV *)arg;
3158 (void)SvREFCNT_inc(filter_child_proc);
3161 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3162 PerlIO_close(IoOFP(io));
3174 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3176 (void)SvREFCNT_inc(filter_sub);
3179 filter_state = SP[i];
3180 (void)SvREFCNT_inc(filter_state);
3184 tryrsfp = PerlIO_open("/dev/null",
3200 filter_has_file = 0;
3201 if (filter_child_proc) {
3202 SvREFCNT_dec(filter_child_proc);
3203 filter_child_proc = 0;
3206 SvREFCNT_dec(filter_state);
3210 SvREFCNT_dec(filter_sub);
3215 if (!path_is_absolute(name)
3216 #ifdef MACOS_TRADITIONAL
3217 /* We consider paths of the form :a:b ambiguous and interpret them first
3218 as global then as local
3220 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3223 char *dir = SvPVx(dirsv, n_a);
3224 #ifdef MACOS_TRADITIONAL
3228 MacPerl_CanonDir(name, buf2, 1);
3229 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3233 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3235 sv_setpv(namesv, unixdir);
3236 sv_catpv(namesv, unixname);
3238 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3241 TAINT_PROPER("require");
3242 tryname = SvPVX(namesv);
3243 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3245 if (tryname[0] == '.' && tryname[1] == '/')
3254 SAVECOPFILE_FREE(&PL_compiling);
3255 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3256 SvREFCNT_dec(namesv);
3258 if (PL_op->op_type == OP_REQUIRE) {
3259 char *msgstr = name;
3260 if (namesv) { /* did we lookup @INC? */
3261 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3262 SV *dirmsgsv = NEWSV(0, 0);
3263 AV *ar = GvAVn(PL_incgv);
3265 sv_catpvn(msg, " in @INC", 8);
3266 if (instr(SvPVX(msg), ".h "))
3267 sv_catpv(msg, " (change .h to .ph maybe?)");
3268 if (instr(SvPVX(msg), ".ph "))
3269 sv_catpv(msg, " (did you run h2ph?)");
3270 sv_catpv(msg, " (@INC contains:");
3271 for (i = 0; i <= AvFILL(ar); i++) {
3272 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3273 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3274 sv_catsv(msg, dirmsgsv);
3276 sv_catpvn(msg, ")", 1);
3277 SvREFCNT_dec(dirmsgsv);
3278 msgstr = SvPV_nolen(msg);
3280 DIE(aTHX_ "Can't locate %s", msgstr);
3286 SETERRNO(0, SS_NORMAL);
3288 /* Assume success here to prevent recursive requirement. */
3290 /* Check whether a hook in @INC has already filled %INC */
3291 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3292 (void)hv_store(GvHVn(PL_incgv), name, len,
3293 (hook_sv ? SvREFCNT_inc(hook_sv)
3294 : newSVpv(CopFILE(&PL_compiling), 0)),
3300 lex_start(sv_2mortal(newSVpvn("",0)));
3301 SAVEGENERICSV(PL_rsfp_filters);
3302 PL_rsfp_filters = Nullav;
3307 SAVESPTR(PL_compiling.cop_warnings);
3308 if (PL_dowarn & G_WARN_ALL_ON)
3309 PL_compiling.cop_warnings = pWARN_ALL ;
3310 else if (PL_dowarn & G_WARN_ALL_OFF)
3311 PL_compiling.cop_warnings = pWARN_NONE ;
3312 else if (PL_taint_warn)
3313 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3315 PL_compiling.cop_warnings = pWARN_STD ;
3316 SAVESPTR(PL_compiling.cop_io);
3317 PL_compiling.cop_io = Nullsv;
3319 if (filter_sub || filter_child_proc) {
3320 SV *datasv = filter_add(run_user_filter, Nullsv);
3321 IoLINES(datasv) = filter_has_file;
3322 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3323 IoTOP_GV(datasv) = (GV *)filter_state;
3324 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3327 /* switch to eval mode */
3328 PUSHBLOCK(cx, CXt_EVAL, SP);
3329 PUSHEVAL(cx, name, Nullgv);
3330 cx->blk_eval.retop = PL_op->op_next;
3332 SAVECOPLINE(&PL_compiling);
3333 CopLINE_set(&PL_compiling, 0);
3337 /* Store and reset encoding. */
3338 encoding = PL_encoding;
3339 PL_encoding = Nullsv;
3341 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3343 /* Restore encoding. */
3344 PL_encoding = encoding;
3351 return pp_require();
3357 register PERL_CONTEXT *cx;
3359 I32 gimme = GIMME_V, was = PL_sub_generation;
3360 char tbuf[TYPE_DIGITS(long) + 12];
3361 char *tmpbuf = tbuf;
3370 TAINT_PROPER("eval");
3376 /* switch to eval mode */
3378 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3379 SV *sv = sv_newmortal();
3380 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3381 (unsigned long)++PL_evalseq,
3382 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3386 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3387 SAVECOPFILE_FREE(&PL_compiling);
3388 CopFILE_set(&PL_compiling, tmpbuf+2);
3389 SAVECOPLINE(&PL_compiling);
3390 CopLINE_set(&PL_compiling, 1);
3391 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3392 deleting the eval's FILEGV from the stash before gv_check() runs
3393 (i.e. before run-time proper). To work around the coredump that
3394 ensues, we always turn GvMULTI_on for any globals that were
3395 introduced within evals. See force_ident(). GSAR 96-10-12 */
3396 safestr = savepv(tmpbuf);
3397 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3399 PL_hints = PL_op->op_targ;
3400 SAVESPTR(PL_compiling.cop_warnings);
3401 if (specialWARN(PL_curcop->cop_warnings))
3402 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3404 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3405 SAVEFREESV(PL_compiling.cop_warnings);
3407 SAVESPTR(PL_compiling.cop_io);
3408 if (specialCopIO(PL_curcop->cop_io))
3409 PL_compiling.cop_io = PL_curcop->cop_io;
3411 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3412 SAVEFREESV(PL_compiling.cop_io);
3414 /* special case: an eval '' executed within the DB package gets lexically
3415 * placed in the first non-DB CV rather than the current CV - this
3416 * allows the debugger to execute code, find lexicals etc, in the
3417 * scope of the code being debugged. Passing &seq gets find_runcv
3418 * to do the dirty work for us */
3419 runcv = find_runcv(&seq);
3421 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3422 PUSHEVAL(cx, 0, Nullgv);
3423 cx->blk_eval.retop = PL_op->op_next;
3425 /* prepare to compile string */
3427 if (PERLDB_LINE && PL_curstash != PL_debstash)
3428 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3430 ret = doeval(gimme, NULL, runcv, seq);
3431 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3432 && ret != PL_op->op_next) { /* Successive compilation. */
3433 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3435 return DOCATCH(ret);
3445 register PERL_CONTEXT *cx;
3447 U8 save_flags = PL_op -> op_flags;
3452 retop = cx->blk_eval.retop;
3455 if (gimme == G_VOID)
3457 else if (gimme == G_SCALAR) {
3460 if (SvFLAGS(TOPs) & SVs_TEMP)
3463 *MARK = sv_mortalcopy(TOPs);
3467 *MARK = &PL_sv_undef;
3472 /* in case LEAVE wipes old return values */
3473 for (mark = newsp + 1; mark <= SP; mark++) {
3474 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3475 *mark = sv_mortalcopy(*mark);
3476 TAINT_NOT; /* Each item is independent */
3480 PL_curpm = newpm; /* Don't pop $1 et al till now */
3483 assert(CvDEPTH(PL_compcv) == 1);
3485 CvDEPTH(PL_compcv) = 0;
3488 if (optype == OP_REQUIRE &&
3489 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3491 /* Unassume the success we assumed earlier. */
3492 SV *nsv = cx->blk_eval.old_namesv;
3493 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3494 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3495 /* die_where() did LEAVE, or we won't be here */
3499 if (!(save_flags & OPf_SPECIAL))
3509 register PERL_CONTEXT *cx;
3510 I32 gimme = GIMME_V;
3515 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3517 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3519 PL_in_eval = EVAL_INEVAL;
3522 return DOCATCH(PL_op->op_next);
3533 register PERL_CONTEXT *cx;
3538 retop = cx->blk_eval.retop;
3541 if (gimme == G_VOID)
3543 else if (gimme == G_SCALAR) {
3546 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3549 *MARK = sv_mortalcopy(TOPs);
3553 *MARK = &PL_sv_undef;
3558 /* in case LEAVE wipes old return values */
3559 for (mark = newsp + 1; mark <= SP; mark++) {
3560 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3561 *mark = sv_mortalcopy(*mark);
3562 TAINT_NOT; /* Each item is independent */
3566 PL_curpm = newpm; /* Don't pop $1 et al till now */
3574 S_doparseform(pTHX_ SV *sv)
3577 register char *s = SvPV_force(sv, len);
3578 register char *send = s + len;
3579 register char *base = Nullch;
3580 register I32 skipspaces = 0;
3581 bool noblank = FALSE;
3582 bool repeat = FALSE;
3583 bool postspace = FALSE;
3589 bool unchopnum = FALSE;
3590 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3593 Perl_croak(aTHX_ "Null picture in formline");
3595 /* estimate the buffer size needed */
3596 for (base = s; s <= send; s++) {
3597 if (*s == '\n' || *s == '@' || *s == '^')
3603 New(804, fops, maxops, U32);
3608 *fpc++ = FF_LINEMARK;
3609 noblank = repeat = FALSE;
3627 case ' ': case '\t':
3634 } /* else FALL THROUGH */
3642 *fpc++ = FF_LITERAL;
3650 *fpc++ = (U16)skipspaces;
3654 *fpc++ = FF_NEWLINE;
3658 arg = fpc - linepc + 1;
3665 *fpc++ = FF_LINEMARK;
3666 noblank = repeat = FALSE;
3675 ischop = s[-1] == '^';
3681 arg = (s - base) - 1;
3683 *fpc++ = FF_LITERAL;
3691 *fpc++ = 2; /* skip the @* or ^* */
3693 *fpc++ = FF_LINESNGL;
3696 *fpc++ = FF_LINEGLOB;
3698 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3699 arg = ischop ? 512 : 0;
3709 arg |= 256 + (s - f);
3711 *fpc++ = s - base; /* fieldsize for FETCH */
3712 *fpc++ = FF_DECIMAL;
3714 unchopnum |= ! ischop;
3716 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3717 arg = ischop ? 512 : 0;
3719 s++; /* skip the '0' first */
3728 arg |= 256 + (s - f);
3730 *fpc++ = s - base; /* fieldsize for FETCH */
3731 *fpc++ = FF_0DECIMAL;
3733 unchopnum |= ! ischop;
3737 bool ismore = FALSE;
3740 while (*++s == '>') ;
3741 prespace = FF_SPACE;
3743 else if (*s == '|') {
3744 while (*++s == '|') ;
3745 prespace = FF_HALFSPACE;
3750 while (*++s == '<') ;
3753 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3757 *fpc++ = s - base; /* fieldsize for FETCH */
3759 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3762 *fpc++ = (U16)prespace;
3776 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3778 { /* need to jump to the next word */
3780 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3781 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3782 s = SvPVX(sv) + SvCUR(sv) + z;
3784 Copy(fops, s, arg, U32);
3786 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3789 if (unchopnum && repeat)
3790 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3796 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3798 /* Can value be printed in fldsize chars, using %*.*f ? */
3802 int intsize = fldsize - (value < 0 ? 1 : 0);
3809 while (intsize--) pwr *= 10.0;
3810 while (frcsize--) eps /= 10.0;
3813 if (value + eps >= pwr)
3816 if (value - eps <= -pwr)
3823 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3825 SV *datasv = FILTER_DATA(idx);
3826 int filter_has_file = IoLINES(datasv);
3827 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3828 SV *filter_state = (SV *)IoTOP_GV(datasv);
3829 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3832 /* I was having segfault trouble under Linux 2.2.5 after a
3833 parse error occured. (Had to hack around it with a test
3834 for PL_error_count == 0.) Solaris doesn't segfault --
3835 not sure where the trouble is yet. XXX */
3837 if (filter_has_file) {
3838 len = FILTER_READ(idx+1, buf_sv, maxlen);
3841 if (filter_sub && len >= 0) {
3852 PUSHs(sv_2mortal(newSViv(maxlen)));
3854 PUSHs(filter_state);
3857 count = call_sv(filter_sub, G_SCALAR);
3873 IoLINES(datasv) = 0;
3874 if (filter_child_proc) {
3875 SvREFCNT_dec(filter_child_proc);
3876 IoFMT_GV(datasv) = Nullgv;
3879 SvREFCNT_dec(filter_state);
3880 IoTOP_GV(datasv) = Nullgv;
3883 SvREFCNT_dec(filter_sub);
3884 IoBOTTOM_GV(datasv) = Nullgv;
3886 filter_del(run_user_filter);
3892 /* perhaps someone can come up with a better name for
3893 this? it is not really "absolute", per se ... */
3895 S_path_is_absolute(pTHX_ char *name)
3897 if (PERL_FILE_IS_ABSOLUTE(name)
3898 #ifdef MACOS_TRADITIONAL
3901 || (*name == '.' && (name[1] == '/' ||
3902 (name[1] == '.' && name[2] == '/'))))