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);
216 (void)SvOOK_off(targ);
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;
393 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
394 if (SvREADONLY(tmpForm)) {
395 SvREADONLY_off(tmpForm);
396 parseres = doparseform(tmpForm);
397 SvREADONLY_on(tmpForm);
400 parseres = doparseform(tmpForm);
404 SvPV_force(PL_formtarget, len);
405 if (DO_UTF8(PL_formtarget))
407 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
409 f = SvPV(tmpForm, len);
410 /* need to jump to the next word */
411 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
420 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
421 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
422 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
423 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
424 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
426 case FF_CHECKNL: name = "CHECKNL"; break;
427 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
428 case FF_SPACE: name = "SPACE"; break;
429 case FF_HALFSPACE: name = "HALFSPACE"; break;
430 case FF_ITEM: name = "ITEM"; break;
431 case FF_CHOP: name = "CHOP"; break;
432 case FF_LINEGLOB: name = "LINEGLOB"; break;
433 case FF_NEWLINE: name = "NEWLINE"; break;
434 case FF_MORE: name = "MORE"; break;
435 case FF_LINEMARK: name = "LINEMARK"; break;
436 case FF_END: name = "END"; break;
437 case FF_0DECIMAL: name = "0DECIMAL"; break;
438 case FF_LINESNGL: name = "LINESNGL"; break;
441 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
443 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
454 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
455 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
457 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
458 t = SvEND(PL_formtarget);
461 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
462 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
464 sv_utf8_upgrade(PL_formtarget);
465 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
466 t = SvEND(PL_formtarget);
486 if (ckWARN(WARN_SYNTAX))
487 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
492 item = s = SvPV(sv, len);
495 itemsize = sv_len_utf8(sv);
496 if (itemsize != (I32)len) {
498 if (itemsize > fieldsize) {
499 itemsize = fieldsize;
500 itembytes = itemsize;
501 sv_pos_u2b(sv, &itembytes, 0);
505 send = chophere = s + itembytes;
515 sv_pos_b2u(sv, &itemsize);
519 item_is_utf8 = FALSE;
520 if (itemsize > fieldsize)
521 itemsize = fieldsize;
522 send = chophere = s + itemsize;
534 item = s = SvPV(sv, len);
537 itemsize = sv_len_utf8(sv);
538 if (itemsize != (I32)len) {
540 if (itemsize <= fieldsize) {
541 send = chophere = s + itemsize;
553 itemsize = fieldsize;
554 itembytes = itemsize;
555 sv_pos_u2b(sv, &itembytes, 0);
556 send = chophere = s + itembytes;
557 while (s < send || (s == send && isSPACE(*s))) {
567 if (strchr(PL_chopset, *s))
572 itemsize = chophere - item;
573 sv_pos_b2u(sv, &itemsize);
579 item_is_utf8 = FALSE;
580 if (itemsize <= fieldsize) {
581 send = chophere = s + itemsize;
593 itemsize = fieldsize;
594 send = chophere = s + itemsize;
595 while (s < send || (s == send && isSPACE(*s))) {
605 if (strchr(PL_chopset, *s))
610 itemsize = chophere - item;
615 arg = fieldsize - itemsize;
624 arg = fieldsize - itemsize;
638 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
640 sv_utf8_upgrade(PL_formtarget);
641 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
642 t = SvEND(PL_formtarget);
646 if (UTF8_IS_CONTINUED(*s)) {
647 STRLEN skip = UTF8SKIP(s);
664 if ( !((*t++ = *s++) & ~31) )
670 if (targ_is_utf8 && !item_is_utf8) {
671 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
673 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
674 for (; t < SvEND(PL_formtarget); t++) {
687 int ch = *t++ = *s++;
690 if ( !((*t++ = *s++) & ~31) )
699 while (*s && isSPACE(*s))
713 item = s = SvPV(sv, len);
715 if ((item_is_utf8 = DO_UTF8(sv)))
716 itemsize = sv_len_utf8(sv);
718 bool chopped = FALSE;
721 chophere = s + itemsize;
737 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
739 SvUTF8_on(PL_formtarget);
741 SvCUR_set(sv, chophere - item);
742 sv_catsv(PL_formtarget, sv);
743 SvCUR_set(sv, itemsize);
745 sv_catsv(PL_formtarget, sv);
747 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
748 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
749 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
757 #if defined(USE_LONG_DOUBLE)
758 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
760 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
765 #if defined(USE_LONG_DOUBLE)
766 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
768 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
771 /* If the field is marked with ^ and the value is undefined,
773 if ((arg & 512) && !SvOK(sv)) {
781 /* overflow evidence */
782 if (num_overflow(value, fieldsize, arg)) {
788 /* Formats aren't yet marked for locales, so assume "yes". */
790 STORE_NUMERIC_STANDARD_SET_LOCAL();
791 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
792 RESTORE_NUMERIC_STANDARD();
799 while (t-- > linemark && *t == ' ') ;
807 if (arg) { /* repeat until fields exhausted? */
809 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
810 lines += FmLINES(PL_formtarget);
813 if (strnEQ(linemark, linemark - arg, arg))
814 DIE(aTHX_ "Runaway format");
817 SvUTF8_on(PL_formtarget);
818 FmLINES(PL_formtarget) = lines;
820 RETURNOP(cLISTOP->op_first);
833 while (*s && isSPACE(*s) && s < send)
837 arg = fieldsize - itemsize;
844 if (strnEQ(s," ",3)) {
845 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
856 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
858 SvUTF8_on(PL_formtarget);
859 FmLINES(PL_formtarget) += lines;
871 if (PL_stack_base + *PL_markstack_ptr == SP) {
873 if (GIMME_V == G_SCALAR)
874 XPUSHs(sv_2mortal(newSViv(0)));
875 RETURNOP(PL_op->op_next->op_next);
877 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
878 pp_pushmark(); /* push dst */
879 pp_pushmark(); /* push src */
880 ENTER; /* enter outer scope */
883 if (PL_op->op_private & OPpGREP_LEX)
884 SAVESPTR(PAD_SVl(PL_op->op_targ));
887 ENTER; /* enter inner scope */
890 src = PL_stack_base[*PL_markstack_ptr];
892 if (PL_op->op_private & OPpGREP_LEX)
893 PAD_SVl(PL_op->op_targ) = src;
898 if (PL_op->op_type == OP_MAPSTART)
899 pp_pushmark(); /* push top */
900 return ((LOGOP*)PL_op->op_next)->op_other;
905 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
912 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
918 /* first, move source pointer to the next item in the source list */
919 ++PL_markstack_ptr[-1];
921 /* if there are new items, push them into the destination list */
922 if (items && gimme != G_VOID) {
923 /* might need to make room back there first */
924 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
925 /* XXX this implementation is very pessimal because the stack
926 * is repeatedly extended for every set of items. Is possible
927 * to do this without any stack extension or copying at all
928 * by maintaining a separate list over which the map iterates
929 * (like foreach does). --gsar */
931 /* everything in the stack after the destination list moves
932 * towards the end the stack by the amount of room needed */
933 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
935 /* items to shift up (accounting for the moved source pointer) */
936 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
938 /* This optimization is by Ben Tilly and it does
939 * things differently from what Sarathy (gsar)
940 * is describing. The downside of this optimization is
941 * that leaves "holes" (uninitialized and hopefully unused areas)
942 * to the Perl stack, but on the other hand this
943 * shouldn't be a problem. If Sarathy's idea gets
944 * implemented, this optimization should become
945 * irrelevant. --jhi */
947 shift = count; /* Avoid shifting too often --Ben Tilly */
952 PL_markstack_ptr[-1] += shift;
953 *PL_markstack_ptr += shift;
957 /* copy the new items down to the destination list */
958 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
959 if (gimme == G_ARRAY) {
961 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
964 /* scalar context: we don't care about which values map returns
965 * (we use undef here). And so we certainly don't want to do mortal
966 * copies of meaningless values. */
967 while (items-- > 0) {
969 *dst-- = &PL_sv_undef;
973 LEAVE; /* exit inner scope */
976 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
978 (void)POPMARK; /* pop top */
979 LEAVE; /* exit outer scope */
980 (void)POPMARK; /* pop src */
981 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
982 (void)POPMARK; /* pop dst */
983 SP = PL_stack_base + POPMARK; /* pop original mark */
984 if (gimme == G_SCALAR) {
985 if (PL_op->op_private & OPpGREP_LEX) {
986 SV* sv = sv_newmortal();
995 else if (gimme == G_ARRAY)
1002 ENTER; /* enter inner scope */
1005 /* set $_ to the new source item */
1006 src = PL_stack_base[PL_markstack_ptr[-1]];
1008 if (PL_op->op_private & OPpGREP_LEX)
1009 PAD_SVl(PL_op->op_targ) = src;
1013 RETURNOP(cLOGOP->op_other);
1021 if (GIMME == G_ARRAY)
1023 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1024 return cLOGOP->op_other;
1033 if (GIMME == G_ARRAY) {
1034 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1038 SV *targ = PAD_SV(PL_op->op_targ);
1041 if (PL_op->op_private & OPpFLIP_LINENUM) {
1042 if (GvIO(PL_last_in_gv)) {
1043 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1046 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1047 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1053 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1054 if (PL_op->op_flags & OPf_SPECIAL) {
1062 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1071 /* This code tries to decide if "$left .. $right" should use the
1072 magical string increment, or if the range is numeric (we make
1073 an exception for .."0" [#18165]). AMS 20021031. */
1075 #define RANGE_IS_NUMERIC(left,right) ( \
1076 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1077 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1078 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1079 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1080 && (!SvOK(right) || looks_like_number(right))))
1086 if (GIMME == G_ARRAY) {
1092 if (SvGMAGICAL(left))
1094 if (SvGMAGICAL(right))
1097 if (RANGE_IS_NUMERIC(left,right)) {
1098 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1099 (SvOK(right) && SvNV(right) > IV_MAX))
1100 DIE(aTHX_ "Range iterator outside integer range");
1111 sv = sv_2mortal(newSViv(i++));
1116 SV *final = sv_mortalcopy(right);
1118 char *tmps = SvPV(final, len);
1120 sv = sv_mortalcopy(left);
1122 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1124 if (strEQ(SvPVX(sv),tmps))
1126 sv = sv_2mortal(newSVsv(sv));
1133 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1137 if (PL_op->op_private & OPpFLIP_LINENUM) {
1138 if (GvIO(PL_last_in_gv)) {
1139 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1142 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1143 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1151 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1152 sv_catpv(targ, "E0");
1162 static char *context_name[] = {
1173 S_dopoptolabel(pTHX_ char *label)
1176 register PERL_CONTEXT *cx;
1178 for (i = cxstack_ix; i >= 0; i--) {
1180 switch (CxTYPE(cx)) {
1186 if (ckWARN(WARN_EXITING))
1187 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1188 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1189 if (CxTYPE(cx) == CXt_NULL)
1193 if (!cx->blk_loop.label ||
1194 strNE(label, cx->blk_loop.label) ) {
1195 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1196 (long)i, cx->blk_loop.label));
1199 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1207 Perl_dowantarray(pTHX)
1209 I32 gimme = block_gimme();
1210 return (gimme == G_VOID) ? G_SCALAR : gimme;
1214 Perl_block_gimme(pTHX)
1218 cxix = dopoptosub(cxstack_ix);
1222 switch (cxstack[cxix].blk_gimme) {
1230 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1237 Perl_is_lvalue_sub(pTHX)
1241 cxix = dopoptosub(cxstack_ix);
1242 assert(cxix >= 0); /* We should only be called from inside subs */
1244 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1245 return cxstack[cxix].blk_sub.lval;
1251 S_dopoptosub(pTHX_ I32 startingblock)
1253 return dopoptosub_at(cxstack, startingblock);
1257 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1260 register PERL_CONTEXT *cx;
1261 for (i = startingblock; i >= 0; i--) {
1263 switch (CxTYPE(cx)) {
1269 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1277 S_dopoptoeval(pTHX_ I32 startingblock)
1280 register PERL_CONTEXT *cx;
1281 for (i = startingblock; i >= 0; i--) {
1283 switch (CxTYPE(cx)) {
1287 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1295 S_dopoptoloop(pTHX_ I32 startingblock)
1298 register PERL_CONTEXT *cx;
1299 for (i = startingblock; i >= 0; i--) {
1301 switch (CxTYPE(cx)) {
1307 if (ckWARN(WARN_EXITING))
1308 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1309 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1310 if ((CxTYPE(cx)) == CXt_NULL)
1314 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1322 Perl_dounwind(pTHX_ I32 cxix)
1324 register PERL_CONTEXT *cx;
1327 while (cxstack_ix > cxix) {
1329 cx = &cxstack[cxstack_ix];
1330 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1331 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1332 /* Note: we don't need to restore the base context info till the end. */
1333 switch (CxTYPE(cx)) {
1336 continue; /* not break */
1358 Perl_qerror(pTHX_ SV *err)
1361 sv_catsv(ERRSV, err);
1363 sv_catsv(PL_errors, err);
1365 Perl_warn(aTHX_ "%"SVf, err);
1370 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1376 register PERL_CONTEXT *cx;
1381 if (PL_in_eval & EVAL_KEEPERR) {
1382 static char prefix[] = "\t(in cleanup) ";
1387 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1390 if (*e != *message || strNE(e,message))
1394 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1395 sv_catpvn(err, prefix, sizeof(prefix)-1);
1396 sv_catpvn(err, message, msglen);
1397 if (ckWARN(WARN_MISC)) {
1398 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1399 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1404 sv_setpvn(ERRSV, message, msglen);
1408 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1409 && PL_curstackinfo->si_prev)
1418 if (cxix < cxstack_ix)
1421 POPBLOCK(cx,PL_curpm);
1422 if (CxTYPE(cx) != CXt_EVAL) {
1424 message = SvPVx(ERRSV, msglen);
1425 PerlIO_write(Perl_error_log, "panic: die ", 11);
1426 PerlIO_write(Perl_error_log, message, msglen);
1431 if (gimme == G_SCALAR)
1432 *++newsp = &PL_sv_undef;
1433 PL_stack_sp = newsp;
1437 /* LEAVE could clobber PL_curcop (see save_re_context())
1438 * XXX it might be better to find a way to avoid messing with
1439 * PL_curcop in save_re_context() instead, but this is a more
1440 * minimal fix --GSAR */
1441 PL_curcop = cx->blk_oldcop;
1443 if (optype == OP_REQUIRE) {
1444 char* msg = SvPVx(ERRSV, n_a);
1445 SV *nsv = cx->blk_eval.old_namesv;
1446 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1448 DIE(aTHX_ "%sCompilation failed in require",
1449 *msg ? msg : "Unknown error\n");
1451 assert(CxTYPE(cx) == CXt_EVAL);
1452 return cx->blk_eval.retop;
1456 message = SvPVx(ERRSV, msglen);
1458 write_to_stderr(message, msglen);
1467 if (SvTRUE(left) != SvTRUE(right))
1479 RETURNOP(cLOGOP->op_other);
1488 RETURNOP(cLOGOP->op_other);
1497 if (!sv || !SvANY(sv)) {
1498 RETURNOP(cLOGOP->op_other);
1501 switch (SvTYPE(sv)) {
1503 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1507 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1511 if (CvROOT(sv) || CvXSUB(sv))
1521 RETURNOP(cLOGOP->op_other);
1527 register I32 cxix = dopoptosub(cxstack_ix);
1528 register PERL_CONTEXT *cx;
1529 register PERL_CONTEXT *ccstack = cxstack;
1530 PERL_SI *top_si = PL_curstackinfo;
1541 /* we may be in a higher stacklevel, so dig down deeper */
1542 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1543 top_si = top_si->si_prev;
1544 ccstack = top_si->si_cxstack;
1545 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1548 if (GIMME != G_ARRAY) {
1554 if (PL_DBsub && cxix >= 0 &&
1555 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1559 cxix = dopoptosub_at(ccstack, cxix - 1);
1562 cx = &ccstack[cxix];
1563 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1565 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1566 field below is defined for any cx. */
1567 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1568 cx = &ccstack[dbcxix];
1571 stashname = CopSTASHPV(cx->blk_oldcop);
1572 if (GIMME != G_ARRAY) {
1575 PUSHs(&PL_sv_undef);
1578 sv_setpv(TARG, stashname);
1587 PUSHs(&PL_sv_undef);
1589 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1590 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1591 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1594 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1595 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1596 /* So is ccstack[dbcxix]. */
1599 gv_efullname3(sv, cvgv, Nullch);
1600 PUSHs(sv_2mortal(sv));
1601 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1604 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1605 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1609 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1610 PUSHs(sv_2mortal(newSViv(0)));
1612 gimme = (I32)cx->blk_gimme;
1613 if (gimme == G_VOID)
1614 PUSHs(&PL_sv_undef);
1616 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1617 if (CxTYPE(cx) == CXt_EVAL) {
1619 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1620 PUSHs(cx->blk_eval.cur_text);
1624 else if (cx->blk_eval.old_namesv) {
1625 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1628 /* eval BLOCK (try blocks have old_namesv == 0) */
1630 PUSHs(&PL_sv_undef);
1631 PUSHs(&PL_sv_undef);
1635 PUSHs(&PL_sv_undef);
1636 PUSHs(&PL_sv_undef);
1638 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1639 && CopSTASH_eq(PL_curcop, PL_debstash))
1641 AV *ary = cx->blk_sub.argarray;
1642 int off = AvARRAY(ary) - AvALLOC(ary);
1646 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1649 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1652 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1653 av_extend(PL_dbargs, AvFILLp(ary) + off);
1654 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1655 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1657 /* XXX only hints propagated via op_private are currently
1658 * visible (others are not easily accessible, since they
1659 * use the global PL_hints) */
1660 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1661 HINT_PRIVATE_MASK)));
1664 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1666 if (old_warnings == pWARN_NONE ||
1667 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1668 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1669 else if (old_warnings == pWARN_ALL ||
1670 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1671 /* Get the bit mask for $warnings::Bits{all}, because
1672 * it could have been extended by warnings::register */
1674 HV *bits = get_hv("warnings::Bits", FALSE);
1675 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1676 mask = newSVsv(*bits_all);
1679 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1683 mask = newSVsv(old_warnings);
1684 PUSHs(sv_2mortal(mask));
1699 sv_reset(tmps, CopSTASH(PL_curcop));
1709 /* like pp_nextstate, but used instead when the debugger is active */
1713 PL_curcop = (COP*)PL_op;
1714 TAINT_NOT; /* Each statement is presumed innocent */
1715 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1718 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1719 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1723 register PERL_CONTEXT *cx;
1724 I32 gimme = G_ARRAY;
1731 DIE(aTHX_ "No DB::DB routine defined");
1733 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1734 /* don't do recursive DB::DB call */
1746 PUSHBLOCK(cx, CXt_SUB, SP);
1748 cx->blk_sub.retop = PL_op->op_next;
1750 PAD_SET_CUR(CvPADLIST(cv),1);
1751 RETURNOP(CvSTART(cv));
1765 register PERL_CONTEXT *cx;
1766 I32 gimme = GIMME_V;
1768 U32 cxtype = CXt_LOOP;
1776 if (PL_op->op_targ) {
1777 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1778 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1779 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1780 SVs_PADSTALE, SVs_PADSTALE);
1782 #ifndef USE_ITHREADS
1783 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1786 SAVEPADSV(PL_op->op_targ);
1787 iterdata = INT2PTR(void*, PL_op->op_targ);
1788 cxtype |= CXp_PADVAR;
1793 svp = &GvSV(gv); /* symbol table variable */
1794 SAVEGENERICSV(*svp);
1797 iterdata = (void*)gv;
1803 PUSHBLOCK(cx, cxtype, SP);
1805 PUSHLOOP(cx, iterdata, MARK);
1807 PUSHLOOP(cx, svp, MARK);
1809 if (PL_op->op_flags & OPf_STACKED) {
1810 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1811 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1813 SV *right = (SV*)cx->blk_loop.iterary;
1814 if (RANGE_IS_NUMERIC(sv,right)) {
1815 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1816 (SvOK(right) && SvNV(right) >= IV_MAX))
1817 DIE(aTHX_ "Range iterator outside integer range");
1818 cx->blk_loop.iterix = SvIV(sv);
1819 cx->blk_loop.itermax = SvIV(right);
1823 cx->blk_loop.iterlval = newSVsv(sv);
1824 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1825 (void) SvPV(right,n_a);
1828 else if (PL_op->op_private & OPpITER_REVERSED) {
1829 cx->blk_loop.itermax = -1;
1830 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1835 cx->blk_loop.iterary = PL_curstack;
1836 AvFILLp(PL_curstack) = SP - PL_stack_base;
1837 if (PL_op->op_private & OPpITER_REVERSED) {
1838 cx->blk_loop.itermax = MARK - PL_stack_base;
1839 cx->blk_loop.iterix = cx->blk_oldsp;
1842 cx->blk_loop.iterix = MARK - PL_stack_base;
1852 register PERL_CONTEXT *cx;
1853 I32 gimme = GIMME_V;
1859 PUSHBLOCK(cx, CXt_LOOP, SP);
1860 PUSHLOOP(cx, 0, SP);
1868 register PERL_CONTEXT *cx;
1876 newsp = PL_stack_base + cx->blk_loop.resetsp;
1879 if (gimme == G_VOID)
1881 else if (gimme == G_SCALAR) {
1883 *++newsp = sv_mortalcopy(*SP);
1885 *++newsp = &PL_sv_undef;
1889 *++newsp = sv_mortalcopy(*++mark);
1890 TAINT_NOT; /* Each item is independent */
1896 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1897 PL_curpm = newpm; /* ... and pop $1 et al */
1909 register PERL_CONTEXT *cx;
1910 bool popsub2 = FALSE;
1911 bool clear_errsv = FALSE;
1919 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1920 if (cxstack_ix == PL_sortcxix
1921 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1923 if (cxstack_ix > PL_sortcxix)
1924 dounwind(PL_sortcxix);
1925 AvARRAY(PL_curstack)[1] = *SP;
1926 PL_stack_sp = PL_stack_base + 1;
1931 cxix = dopoptosub(cxstack_ix);
1933 DIE(aTHX_ "Can't return outside a subroutine");
1934 if (cxix < cxstack_ix)
1938 switch (CxTYPE(cx)) {
1941 retop = cx->blk_sub.retop;
1942 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1945 if (!(PL_in_eval & EVAL_KEEPERR))
1948 retop = cx->blk_eval.retop;
1952 if (optype == OP_REQUIRE &&
1953 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1955 /* Unassume the success we assumed earlier. */
1956 SV *nsv = cx->blk_eval.old_namesv;
1957 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1958 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1963 retop = cx->blk_sub.retop;
1966 DIE(aTHX_ "panic: return");
1970 if (gimme == G_SCALAR) {
1973 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1975 *++newsp = SvREFCNT_inc(*SP);
1980 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1982 *++newsp = sv_mortalcopy(sv);
1987 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1990 *++newsp = sv_mortalcopy(*SP);
1993 *++newsp = &PL_sv_undef;
1995 else if (gimme == G_ARRAY) {
1996 while (++MARK <= SP) {
1997 *++newsp = (popsub2 && SvTEMP(*MARK))
1998 ? *MARK : sv_mortalcopy(*MARK);
1999 TAINT_NOT; /* Each item is independent */
2002 PL_stack_sp = newsp;
2005 /* Stack values are safe: */
2008 POPSUB(cx,sv); /* release CV and @_ ... */
2012 PL_curpm = newpm; /* ... and pop $1 et al */
2024 register PERL_CONTEXT *cx;
2034 if (PL_op->op_flags & OPf_SPECIAL) {
2035 cxix = dopoptoloop(cxstack_ix);
2037 DIE(aTHX_ "Can't \"last\" outside a loop block");
2040 cxix = dopoptolabel(cPVOP->op_pv);
2042 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2044 if (cxix < cxstack_ix)
2048 cxstack_ix++; /* temporarily protect top context */
2050 switch (CxTYPE(cx)) {
2053 newsp = PL_stack_base + cx->blk_loop.resetsp;
2054 nextop = cx->blk_loop.last_op->op_next;
2058 nextop = cx->blk_sub.retop;
2062 nextop = cx->blk_eval.retop;
2066 nextop = cx->blk_sub.retop;
2069 DIE(aTHX_ "panic: last");
2073 if (gimme == G_SCALAR) {
2075 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2076 ? *SP : sv_mortalcopy(*SP);
2078 *++newsp = &PL_sv_undef;
2080 else if (gimme == G_ARRAY) {
2081 while (++MARK <= SP) {
2082 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2083 ? *MARK : sv_mortalcopy(*MARK);
2084 TAINT_NOT; /* Each item is independent */
2092 /* Stack values are safe: */
2095 POPLOOP(cx); /* release loop vars ... */
2099 POPSUB(cx,sv); /* release CV and @_ ... */
2102 PL_curpm = newpm; /* ... and pop $1 et al */
2111 register PERL_CONTEXT *cx;
2114 if (PL_op->op_flags & OPf_SPECIAL) {
2115 cxix = dopoptoloop(cxstack_ix);
2117 DIE(aTHX_ "Can't \"next\" outside a loop block");
2120 cxix = dopoptolabel(cPVOP->op_pv);
2122 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2124 if (cxix < cxstack_ix)
2127 /* clear off anything above the scope we're re-entering, but
2128 * save the rest until after a possible continue block */
2129 inner = PL_scopestack_ix;
2131 if (PL_scopestack_ix < inner)
2132 leave_scope(PL_scopestack[PL_scopestack_ix]);
2133 return cx->blk_loop.next_op;
2139 register PERL_CONTEXT *cx;
2142 if (PL_op->op_flags & OPf_SPECIAL) {
2143 cxix = dopoptoloop(cxstack_ix);
2145 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2148 cxix = dopoptolabel(cPVOP->op_pv);
2150 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2152 if (cxix < cxstack_ix)
2156 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2157 LEAVE_SCOPE(oldsave);
2159 return cx->blk_loop.redo_op;
2163 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2167 static char too_deep[] = "Target of goto is too deeply nested";
2170 Perl_croak(aTHX_ too_deep);
2171 if (o->op_type == OP_LEAVE ||
2172 o->op_type == OP_SCOPE ||
2173 o->op_type == OP_LEAVELOOP ||
2174 o->op_type == OP_LEAVESUB ||
2175 o->op_type == OP_LEAVETRY)
2177 *ops++ = cUNOPo->op_first;
2179 Perl_croak(aTHX_ too_deep);
2182 if (o->op_flags & OPf_KIDS) {
2183 /* First try all the kids at this level, since that's likeliest. */
2184 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2185 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2186 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2189 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2190 if (kid == PL_lastgotoprobe)
2192 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2195 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2196 ops[-1]->op_type == OP_DBSTATE)
2201 if ((o = dofindlabel(kid, label, ops, oplimit)))
2220 register PERL_CONTEXT *cx;
2221 #define GOTO_DEPTH 64
2222 OP *enterops[GOTO_DEPTH];
2224 int do_dump = (PL_op->op_type == OP_DUMP);
2225 static char must_have_label[] = "goto must have label";
2229 if (PL_op->op_flags & OPf_STACKED) {
2233 /* This egregious kludge implements goto &subroutine */
2234 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2236 register PERL_CONTEXT *cx;
2237 CV* cv = (CV*)SvRV(sv);
2243 if (!CvROOT(cv) && !CvXSUB(cv)) {
2248 /* autoloaded stub? */
2249 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2251 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2252 GvNAMELEN(gv), FALSE);
2253 if (autogv && (cv = GvCV(autogv)))
2255 tmpstr = sv_newmortal();
2256 gv_efullname3(tmpstr, gv, Nullch);
2257 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2259 DIE(aTHX_ "Goto undefined subroutine");
2262 /* First do some returnish stuff. */
2263 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2265 cxix = dopoptosub(cxstack_ix);
2267 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2268 if (cxix < cxstack_ix)
2272 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2273 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2274 /* put @_ back onto stack */
2275 AV* av = cx->blk_sub.argarray;
2277 items = AvFILLp(av) + 1;
2278 EXTEND(SP, items+1); /* @_ could have been extended. */
2279 Copy(AvARRAY(av), SP + 1, items, SV*);
2280 SvREFCNT_dec(GvAV(PL_defgv));
2281 GvAV(PL_defgv) = cx->blk_sub.savearray;
2282 /* abandon @_ if it got reified */
2284 oldav = av; /* delay until return */
2286 av_extend(av, items-1);
2287 AvFLAGS(av) = AVf_REIFY;
2288 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2293 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2295 av = GvAV(PL_defgv);
2296 items = AvFILLp(av) + 1;
2297 EXTEND(SP, items+1); /* @_ could have been extended. */
2298 Copy(AvARRAY(av), SP + 1, items, SV*);
2302 if (CxTYPE(cx) == CXt_SUB &&
2303 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2304 SvREFCNT_dec(cx->blk_sub.cv);
2305 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2306 LEAVE_SCOPE(oldsave);
2308 /* Now do some callish stuff. */
2310 /* For reified @_, delay freeing till return from new sub */
2312 SAVEFREESV((SV*)oldav);
2313 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2315 #ifdef PERL_XSUB_OLDSTYLE
2316 if (CvOLDSTYLE(cv)) {
2317 I32 (*fp3)(int,int,int);
2322 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2323 items = (*fp3)(CvXSUBANY(cv).any_i32,
2324 mark - PL_stack_base + 1,
2326 SP = PL_stack_base + items;
2329 #endif /* PERL_XSUB_OLDSTYLE */
2334 /* Push a mark for the start of arglist */
2337 (void)(*CvXSUB(cv))(aTHX_ cv);
2338 /* Pop the current context like a decent sub should */
2339 POPBLOCK(cx, PL_curpm);
2340 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2343 assert(CxTYPE(cx) == CXt_SUB);
2344 return cx->blk_sub.retop;
2347 AV* padlist = CvPADLIST(cv);
2348 if (CxTYPE(cx) == CXt_EVAL) {
2349 PL_in_eval = cx->blk_eval.old_in_eval;
2350 PL_eval_root = cx->blk_eval.old_eval_root;
2351 cx->cx_type = CXt_SUB;
2352 cx->blk_sub.hasargs = 0;
2354 cx->blk_sub.cv = cv;
2355 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2358 if (CvDEPTH(cv) < 2)
2359 (void)SvREFCNT_inc(cv);
2361 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2362 sub_crush_depth(cv);
2363 pad_push(padlist, CvDEPTH(cv), 1);
2365 PAD_SET_CUR(padlist, CvDEPTH(cv));
2366 if (cx->blk_sub.hasargs)
2368 AV* av = (AV*)PAD_SVl(0);
2371 cx->blk_sub.savearray = GvAV(PL_defgv);
2372 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2373 CX_CURPAD_SAVE(cx->blk_sub);
2374 cx->blk_sub.argarray = av;
2376 if (items >= AvMAX(av) + 1) {
2378 if (AvARRAY(av) != ary) {
2379 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2380 SvPVX(av) = (char*)ary;
2382 if (items >= AvMAX(av) + 1) {
2383 AvMAX(av) = items - 1;
2384 Renew(ary,items+1,SV*);
2386 SvPVX(av) = (char*)ary;
2390 Copy(mark,AvARRAY(av),items,SV*);
2391 AvFILLp(av) = items - 1;
2392 assert(!AvREAL(av));
2399 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2401 * We do not care about using sv to call CV;
2402 * it's for informational purposes only.
2404 SV *sv = GvSV(PL_DBsub);
2407 if (PERLDB_SUB_NN) {
2408 (void)SvUPGRADE(sv, SVt_PVIV);
2411 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2414 gv_efullname3(sv, CvGV(cv), Nullch);
2417 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2418 PUSHMARK( PL_stack_sp );
2419 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2423 RETURNOP(CvSTART(cv));
2427 label = SvPV(sv,n_a);
2428 if (!(do_dump || *label))
2429 DIE(aTHX_ must_have_label);
2432 else if (PL_op->op_flags & OPf_SPECIAL) {
2434 DIE(aTHX_ must_have_label);
2437 label = cPVOP->op_pv;
2439 if (label && *label) {
2441 bool leaving_eval = FALSE;
2442 bool in_block = FALSE;
2443 PERL_CONTEXT *last_eval_cx = 0;
2447 PL_lastgotoprobe = 0;
2449 for (ix = cxstack_ix; ix >= 0; ix--) {
2451 switch (CxTYPE(cx)) {
2453 leaving_eval = TRUE;
2454 if (!CxTRYBLOCK(cx)) {
2455 gotoprobe = (last_eval_cx ?
2456 last_eval_cx->blk_eval.old_eval_root :
2461 /* else fall through */
2463 gotoprobe = cx->blk_oldcop->op_sibling;
2469 gotoprobe = cx->blk_oldcop->op_sibling;
2472 gotoprobe = PL_main_root;
2475 if (CvDEPTH(cx->blk_sub.cv)) {
2476 gotoprobe = CvROOT(cx->blk_sub.cv);
2482 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2485 DIE(aTHX_ "panic: goto");
2486 gotoprobe = PL_main_root;
2490 retop = dofindlabel(gotoprobe, label,
2491 enterops, enterops + GOTO_DEPTH);
2495 PL_lastgotoprobe = gotoprobe;
2498 DIE(aTHX_ "Can't find label %s", label);
2500 /* if we're leaving an eval, check before we pop any frames
2501 that we're not going to punt, otherwise the error
2504 if (leaving_eval && *enterops && enterops[1]) {
2506 for (i = 1; enterops[i]; i++)
2507 if (enterops[i]->op_type == OP_ENTERITER)
2508 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2511 /* pop unwanted frames */
2513 if (ix < cxstack_ix) {
2520 oldsave = PL_scopestack[PL_scopestack_ix];
2521 LEAVE_SCOPE(oldsave);
2524 /* push wanted frames */
2526 if (*enterops && enterops[1]) {
2528 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2529 for (; enterops[ix]; ix++) {
2530 PL_op = enterops[ix];
2531 /* Eventually we may want to stack the needed arguments
2532 * for each op. For now, we punt on the hard ones. */
2533 if (PL_op->op_type == OP_ENTERITER)
2534 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2535 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2543 if (!retop) retop = PL_main_start;
2545 PL_restartop = retop;
2546 PL_do_undump = TRUE;
2550 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2551 PL_do_undump = FALSE;
2567 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2569 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2572 PL_exit_flags |= PERL_EXIT_EXPECTED;
2574 PUSHs(&PL_sv_undef);
2582 NV value = SvNVx(GvSV(cCOP->cop_gv));
2583 register I32 match = I_32(value);
2586 if (((NV)match) > value)
2587 --match; /* was fractional--truncate other way */
2589 match -= cCOP->uop.scop.scop_offset;
2592 else if (match > cCOP->uop.scop.scop_max)
2593 match = cCOP->uop.scop.scop_max;
2594 PL_op = cCOP->uop.scop.scop_next[match];
2604 PL_op = PL_op->op_next; /* can't assume anything */
2607 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2608 match -= cCOP->uop.scop.scop_offset;
2611 else if (match > cCOP->uop.scop.scop_max)
2612 match = cCOP->uop.scop.scop_max;
2613 PL_op = cCOP->uop.scop.scop_next[match];
2622 S_save_lines(pTHX_ AV *array, SV *sv)
2624 register char *s = SvPVX(sv);
2625 register char *send = SvPVX(sv) + SvCUR(sv);
2627 register I32 line = 1;
2629 while (s && s < send) {
2630 SV *tmpstr = NEWSV(85,0);
2632 sv_upgrade(tmpstr, SVt_PVMG);
2633 t = strchr(s, '\n');
2639 sv_setpvn(tmpstr, s, t - s);
2640 av_store(array, line++, tmpstr);
2645 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2647 S_docatch_body(pTHX_ va_list args)
2649 return docatch_body();
2654 S_docatch_body(pTHX)
2661 S_docatch(pTHX_ OP *o)
2666 volatile PERL_SI *cursi = PL_curstackinfo;
2670 assert(CATCH_GET == TRUE);
2674 /* Normally, the leavetry at the end of this block of ops will
2675 * pop an op off the return stack and continue there. By setting
2676 * the op to Nullop, we force an exit from the inner runops()
2679 assert(cxstack_ix >= 0);
2680 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2681 retop = cxstack[cxstack_ix].blk_eval.retop;
2682 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2684 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2686 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2692 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2698 /* die caught by an inner eval - continue inner loop */
2699 if (PL_restartop && cursi == PL_curstackinfo) {
2700 PL_op = PL_restartop;
2704 /* a die in this eval - continue in outer loop */
2720 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2721 /* sv Text to convert to OP tree. */
2722 /* startop op_free() this to undo. */
2723 /* code Short string id of the caller. */
2725 dSP; /* Make POPBLOCK work. */
2728 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2732 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2733 char *tmpbuf = tbuf;
2736 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2741 /* switch to eval mode */
2743 if (IN_PERL_COMPILETIME) {
2744 SAVECOPSTASH_FREE(&PL_compiling);
2745 CopSTASH_set(&PL_compiling, PL_curstash);
2747 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2748 SV *sv = sv_newmortal();
2749 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2750 code, (unsigned long)++PL_evalseq,
2751 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2755 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2756 SAVECOPFILE_FREE(&PL_compiling);
2757 CopFILE_set(&PL_compiling, tmpbuf+2);
2758 SAVECOPLINE(&PL_compiling);
2759 CopLINE_set(&PL_compiling, 1);
2760 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2761 deleting the eval's FILEGV from the stash before gv_check() runs
2762 (i.e. before run-time proper). To work around the coredump that
2763 ensues, we always turn GvMULTI_on for any globals that were
2764 introduced within evals. See force_ident(). GSAR 96-10-12 */
2765 safestr = savepv(tmpbuf);
2766 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2768 #ifdef OP_IN_REGISTER
2774 /* we get here either during compilation, or via pp_regcomp at runtime */
2775 runtime = IN_PERL_RUNTIME;
2777 runcv = find_runcv(NULL);
2780 PL_op->op_type = OP_ENTEREVAL;
2781 PL_op->op_flags = 0; /* Avoid uninit warning. */
2782 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2783 PUSHEVAL(cx, 0, Nullgv);
2786 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2788 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2789 POPBLOCK(cx,PL_curpm);
2792 (*startop)->op_type = OP_NULL;
2793 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2795 /* XXX DAPM do this properly one year */
2796 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2798 if (IN_PERL_COMPILETIME)
2799 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2800 #ifdef OP_IN_REGISTER
2808 =for apidoc find_runcv
2810 Locate the CV corresponding to the currently executing sub or eval.
2811 If db_seqp is non_null, skip CVs that are in the DB package and populate
2812 *db_seqp with the cop sequence number at the point that the DB:: code was
2813 entered. (allows debuggers to eval in the scope of the breakpoint rather
2814 than in in the scope of the debugger itself).
2820 Perl_find_runcv(pTHX_ U32 *db_seqp)
2827 *db_seqp = PL_curcop->cop_seq;
2828 for (si = PL_curstackinfo; si; si = si->si_prev) {
2829 for (ix = si->si_cxix; ix >= 0; ix--) {
2830 cx = &(si->si_cxstack[ix]);
2831 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2832 CV *cv = cx->blk_sub.cv;
2833 /* skip DB:: code */
2834 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2835 *db_seqp = cx->blk_oldcop->cop_seq;
2840 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2848 /* Compile a require/do, an eval '', or a /(?{...})/.
2849 * In the last case, startop is non-null, and contains the address of
2850 * a pointer that should be set to the just-compiled code.
2851 * outside is the lexically enclosing CV (if any) that invoked us.
2854 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2856 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2861 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2862 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2867 SAVESPTR(PL_compcv);
2868 PL_compcv = (CV*)NEWSV(1104,0);
2869 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2870 CvEVAL_on(PL_compcv);
2871 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2872 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2874 CvOUTSIDE_SEQ(PL_compcv) = seq;
2875 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2877 /* set up a scratch pad */
2879 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2882 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2884 /* make sure we compile in the right package */
2886 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2887 SAVESPTR(PL_curstash);
2888 PL_curstash = CopSTASH(PL_curcop);
2890 SAVESPTR(PL_beginav);
2891 PL_beginav = newAV();
2892 SAVEFREESV(PL_beginav);
2893 SAVEI32(PL_error_count);
2895 /* try to compile it */
2897 PL_eval_root = Nullop;
2899 PL_curcop = &PL_compiling;
2900 PL_curcop->cop_arybase = 0;
2901 if (saveop && saveop->op_flags & OPf_SPECIAL)
2902 PL_in_eval |= EVAL_KEEPERR;
2905 if (yyparse() || PL_error_count || !PL_eval_root) {
2906 SV **newsp; /* Used by POPBLOCK. */
2907 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2908 I32 optype = 0; /* Might be reset by POPEVAL. */
2913 op_free(PL_eval_root);
2914 PL_eval_root = Nullop;
2916 SP = PL_stack_base + POPMARK; /* pop original mark */
2918 POPBLOCK(cx,PL_curpm);
2923 if (optype == OP_REQUIRE) {
2924 char* msg = SvPVx(ERRSV, n_a);
2925 SV *nsv = cx->blk_eval.old_namesv;
2926 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2928 DIE(aTHX_ "%sCompilation failed in require",
2929 *msg ? msg : "Unknown error\n");
2932 char* msg = SvPVx(ERRSV, n_a);
2934 POPBLOCK(cx,PL_curpm);
2936 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2937 (*msg ? msg : "Unknown error\n"));
2940 char* msg = SvPVx(ERRSV, n_a);
2942 sv_setpv(ERRSV, "Compilation error");
2947 CopLINE_set(&PL_compiling, 0);
2949 *startop = PL_eval_root;
2951 SAVEFREEOP(PL_eval_root);
2953 /* Set the context for this new optree.
2954 * If the last op is an OP_REQUIRE, force scalar context.
2955 * Otherwise, propagate the context from the eval(). */
2956 if (PL_eval_root->op_type == OP_LEAVEEVAL
2957 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2958 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2960 scalar(PL_eval_root);
2961 else if (gimme & G_VOID)
2962 scalarvoid(PL_eval_root);
2963 else if (gimme & G_ARRAY)
2966 scalar(PL_eval_root);
2968 DEBUG_x(dump_eval());
2970 /* Register with debugger: */
2971 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2972 CV *cv = get_cv("DB::postponed", FALSE);
2976 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2978 call_sv((SV*)cv, G_DISCARD);
2982 /* compiled okay, so do it */
2984 CvDEPTH(PL_compcv) = 1;
2985 SP = PL_stack_base + POPMARK; /* pop original mark */
2986 PL_op = saveop; /* The caller may need it. */
2987 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2989 RETURNOP(PL_eval_start);
2993 S_doopen_pm(pTHX_ const char *name, const char *mode)
2995 #ifndef PERL_DISABLE_PMC
2996 STRLEN namelen = strlen(name);
2999 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3000 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3001 char *pmc = SvPV_nolen(pmcsv);
3004 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3005 fp = PerlIO_open(name, mode);
3008 if (PerlLIO_stat(name, &pmstat) < 0 ||
3009 pmstat.st_mtime < pmcstat.st_mtime)
3011 fp = PerlIO_open(pmc, mode);
3014 fp = PerlIO_open(name, mode);
3017 SvREFCNT_dec(pmcsv);
3020 fp = PerlIO_open(name, mode);
3024 return PerlIO_open(name, mode);
3025 #endif /* !PERL_DISABLE_PMC */
3031 register PERL_CONTEXT *cx;
3035 char *tryname = Nullch;
3036 SV *namesv = Nullsv;
3038 I32 gimme = GIMME_V;
3039 PerlIO *tryrsfp = 0;
3041 int filter_has_file = 0;
3042 GV *filter_child_proc = 0;
3043 SV *filter_state = 0;
3050 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3051 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3052 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3053 "v-string in use/require non-portable");
3055 sv = new_version(sv);
3056 if (!sv_derived_from(PL_patchlevel, "version"))
3057 (void *)upg_version(PL_patchlevel);
3058 if ( vcmp(sv,PL_patchlevel) > 0 )
3059 DIE(aTHX_ "Perl v%_ required--this is only v%_, stopped",
3060 vstringify(sv), vstringify(PL_patchlevel));
3064 name = SvPV(sv, len);
3065 if (!(name && len > 0 && *name))
3066 DIE(aTHX_ "Null filename used");
3067 TAINT_PROPER("require");
3068 if (PL_op->op_type == OP_REQUIRE &&
3069 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3070 if (*svp != &PL_sv_undef)
3073 DIE(aTHX_ "Compilation failed in require");
3076 /* prepare to compile file */
3078 if (path_is_absolute(name)) {
3080 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3082 #ifdef MACOS_TRADITIONAL
3086 MacPerl_CanonDir(name, newname, 1);
3087 if (path_is_absolute(newname)) {
3089 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3094 AV *ar = GvAVn(PL_incgv);
3098 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3101 namesv = NEWSV(806, 0);
3102 for (i = 0; i <= AvFILL(ar); i++) {
3103 SV *dirsv = *av_fetch(ar, i, TRUE);
3109 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3110 && !sv_isobject(loader))
3112 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3115 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3116 PTR2UV(SvRV(dirsv)), name);
3117 tryname = SvPVX(namesv);
3128 if (sv_isobject(loader))
3129 count = call_method("INC", G_ARRAY);
3131 count = call_sv(loader, G_ARRAY);
3141 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3145 if (SvTYPE(arg) == SVt_PVGV) {
3146 IO *io = GvIO((GV *)arg);
3151 tryrsfp = IoIFP(io);
3152 if (IoTYPE(io) == IoTYPE_PIPE) {
3153 /* reading from a child process doesn't
3154 nest -- when returning from reading
3155 the inner module, the outer one is
3156 unreadable (closed?) I've tried to
3157 save the gv to manage the lifespan of
3158 the pipe, but this didn't help. XXX */
3159 filter_child_proc = (GV *)arg;
3160 (void)SvREFCNT_inc(filter_child_proc);
3163 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3164 PerlIO_close(IoOFP(io));
3176 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3178 (void)SvREFCNT_inc(filter_sub);
3181 filter_state = SP[i];
3182 (void)SvREFCNT_inc(filter_state);
3186 tryrsfp = PerlIO_open("/dev/null",
3202 filter_has_file = 0;
3203 if (filter_child_proc) {
3204 SvREFCNT_dec(filter_child_proc);
3205 filter_child_proc = 0;
3208 SvREFCNT_dec(filter_state);
3212 SvREFCNT_dec(filter_sub);
3217 if (!path_is_absolute(name)
3218 #ifdef MACOS_TRADITIONAL
3219 /* We consider paths of the form :a:b ambiguous and interpret them first
3220 as global then as local
3222 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3225 char *dir = SvPVx(dirsv, n_a);
3226 #ifdef MACOS_TRADITIONAL
3230 MacPerl_CanonDir(name, buf2, 1);
3231 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3235 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3237 sv_setpv(namesv, unixdir);
3238 sv_catpv(namesv, unixname);
3240 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3243 TAINT_PROPER("require");
3244 tryname = SvPVX(namesv);
3245 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3247 if (tryname[0] == '.' && tryname[1] == '/')
3256 SAVECOPFILE_FREE(&PL_compiling);
3257 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3258 SvREFCNT_dec(namesv);
3260 if (PL_op->op_type == OP_REQUIRE) {
3261 char *msgstr = name;
3262 if (namesv) { /* did we lookup @INC? */
3263 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3264 SV *dirmsgsv = NEWSV(0, 0);
3265 AV *ar = GvAVn(PL_incgv);
3267 sv_catpvn(msg, " in @INC", 8);
3268 if (instr(SvPVX(msg), ".h "))
3269 sv_catpv(msg, " (change .h to .ph maybe?)");
3270 if (instr(SvPVX(msg), ".ph "))
3271 sv_catpv(msg, " (did you run h2ph?)");
3272 sv_catpv(msg, " (@INC contains:");
3273 for (i = 0; i <= AvFILL(ar); i++) {
3274 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3275 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3276 sv_catsv(msg, dirmsgsv);
3278 sv_catpvn(msg, ")", 1);
3279 SvREFCNT_dec(dirmsgsv);
3280 msgstr = SvPV_nolen(msg);
3282 DIE(aTHX_ "Can't locate %s", msgstr);
3288 SETERRNO(0, SS_NORMAL);
3290 /* Assume success here to prevent recursive requirement. */
3292 /* Check whether a hook in @INC has already filled %INC */
3293 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3294 (void)hv_store(GvHVn(PL_incgv), name, len,
3295 (hook_sv ? SvREFCNT_inc(hook_sv)
3296 : newSVpv(CopFILE(&PL_compiling), 0)),
3302 lex_start(sv_2mortal(newSVpvn("",0)));
3303 SAVEGENERICSV(PL_rsfp_filters);
3304 PL_rsfp_filters = Nullav;
3309 SAVESPTR(PL_compiling.cop_warnings);
3310 if (PL_dowarn & G_WARN_ALL_ON)
3311 PL_compiling.cop_warnings = pWARN_ALL ;
3312 else if (PL_dowarn & G_WARN_ALL_OFF)
3313 PL_compiling.cop_warnings = pWARN_NONE ;
3314 else if (PL_taint_warn)
3315 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3317 PL_compiling.cop_warnings = pWARN_STD ;
3318 SAVESPTR(PL_compiling.cop_io);
3319 PL_compiling.cop_io = Nullsv;
3321 if (filter_sub || filter_child_proc) {
3322 SV *datasv = filter_add(run_user_filter, Nullsv);
3323 IoLINES(datasv) = filter_has_file;
3324 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3325 IoTOP_GV(datasv) = (GV *)filter_state;
3326 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3329 /* switch to eval mode */
3330 PUSHBLOCK(cx, CXt_EVAL, SP);
3331 PUSHEVAL(cx, name, Nullgv);
3332 cx->blk_eval.retop = PL_op->op_next;
3334 SAVECOPLINE(&PL_compiling);
3335 CopLINE_set(&PL_compiling, 0);
3339 /* Store and reset encoding. */
3340 encoding = PL_encoding;
3341 PL_encoding = Nullsv;
3343 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3345 /* Restore encoding. */
3346 PL_encoding = encoding;
3353 return pp_require();
3359 register PERL_CONTEXT *cx;
3361 I32 gimme = GIMME_V, was = PL_sub_generation;
3362 char tbuf[TYPE_DIGITS(long) + 12];
3363 char *tmpbuf = tbuf;
3372 TAINT_PROPER("eval");
3378 /* switch to eval mode */
3380 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3381 SV *sv = sv_newmortal();
3382 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3383 (unsigned long)++PL_evalseq,
3384 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3388 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3389 SAVECOPFILE_FREE(&PL_compiling);
3390 CopFILE_set(&PL_compiling, tmpbuf+2);
3391 SAVECOPLINE(&PL_compiling);
3392 CopLINE_set(&PL_compiling, 1);
3393 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3394 deleting the eval's FILEGV from the stash before gv_check() runs
3395 (i.e. before run-time proper). To work around the coredump that
3396 ensues, we always turn GvMULTI_on for any globals that were
3397 introduced within evals. See force_ident(). GSAR 96-10-12 */
3398 safestr = savepv(tmpbuf);
3399 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3401 PL_hints = PL_op->op_targ;
3402 SAVESPTR(PL_compiling.cop_warnings);
3403 if (specialWARN(PL_curcop->cop_warnings))
3404 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3406 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3407 SAVEFREESV(PL_compiling.cop_warnings);
3409 SAVESPTR(PL_compiling.cop_io);
3410 if (specialCopIO(PL_curcop->cop_io))
3411 PL_compiling.cop_io = PL_curcop->cop_io;
3413 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3414 SAVEFREESV(PL_compiling.cop_io);
3416 /* special case: an eval '' executed within the DB package gets lexically
3417 * placed in the first non-DB CV rather than the current CV - this
3418 * allows the debugger to execute code, find lexicals etc, in the
3419 * scope of the code being debugged. Passing &seq gets find_runcv
3420 * to do the dirty work for us */
3421 runcv = find_runcv(&seq);
3423 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3424 PUSHEVAL(cx, 0, Nullgv);
3425 cx->blk_eval.retop = PL_op->op_next;
3427 /* prepare to compile string */
3429 if (PERLDB_LINE && PL_curstash != PL_debstash)
3430 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3432 ret = doeval(gimme, NULL, runcv, seq);
3433 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3434 && ret != PL_op->op_next) { /* Successive compilation. */
3435 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3437 return DOCATCH(ret);
3447 register PERL_CONTEXT *cx;
3449 U8 save_flags = PL_op -> op_flags;
3454 retop = cx->blk_eval.retop;
3457 if (gimme == G_VOID)
3459 else if (gimme == G_SCALAR) {
3462 if (SvFLAGS(TOPs) & SVs_TEMP)
3465 *MARK = sv_mortalcopy(TOPs);
3469 *MARK = &PL_sv_undef;
3474 /* in case LEAVE wipes old return values */
3475 for (mark = newsp + 1; mark <= SP; mark++) {
3476 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3477 *mark = sv_mortalcopy(*mark);
3478 TAINT_NOT; /* Each item is independent */
3482 PL_curpm = newpm; /* Don't pop $1 et al till now */
3485 assert(CvDEPTH(PL_compcv) == 1);
3487 CvDEPTH(PL_compcv) = 0;
3490 if (optype == OP_REQUIRE &&
3491 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3493 /* Unassume the success we assumed earlier. */
3494 SV *nsv = cx->blk_eval.old_namesv;
3495 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3496 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3497 /* die_where() did LEAVE, or we won't be here */
3501 if (!(save_flags & OPf_SPECIAL))
3511 register PERL_CONTEXT *cx;
3512 I32 gimme = GIMME_V;
3517 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3519 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3521 PL_in_eval = EVAL_INEVAL;
3524 return DOCATCH(PL_op->op_next);
3535 register PERL_CONTEXT *cx;
3540 retop = cx->blk_eval.retop;
3543 if (gimme == G_VOID)
3545 else if (gimme == G_SCALAR) {
3548 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3551 *MARK = sv_mortalcopy(TOPs);
3555 *MARK = &PL_sv_undef;
3560 /* in case LEAVE wipes old return values */
3561 for (mark = newsp + 1; mark <= SP; mark++) {
3562 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3563 *mark = sv_mortalcopy(*mark);
3564 TAINT_NOT; /* Each item is independent */
3568 PL_curpm = newpm; /* Don't pop $1 et al till now */
3576 S_doparseform(pTHX_ SV *sv)
3579 register char *s = SvPV_force(sv, len);
3580 register char *send = s + len;
3581 register char *base = Nullch;
3582 register I32 skipspaces = 0;
3583 bool noblank = FALSE;
3584 bool repeat = FALSE;
3585 bool postspace = FALSE;
3591 bool unchopnum = FALSE;
3592 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3595 Perl_croak(aTHX_ "Null picture in formline");
3597 /* estimate the buffer size needed */
3598 for (base = s; s <= send; s++) {
3599 if (*s == '\n' || *s == '@' || *s == '^')
3605 New(804, fops, maxops, U32);
3610 *fpc++ = FF_LINEMARK;
3611 noblank = repeat = FALSE;
3629 case ' ': case '\t':
3636 } /* else FALL THROUGH */
3644 *fpc++ = FF_LITERAL;
3652 *fpc++ = (U16)skipspaces;
3656 *fpc++ = FF_NEWLINE;
3660 arg = fpc - linepc + 1;
3667 *fpc++ = FF_LINEMARK;
3668 noblank = repeat = FALSE;
3677 ischop = s[-1] == '^';
3683 arg = (s - base) - 1;
3685 *fpc++ = FF_LITERAL;
3693 *fpc++ = 2; /* skip the @* or ^* */
3695 *fpc++ = FF_LINESNGL;
3698 *fpc++ = FF_LINEGLOB;
3700 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3701 arg = ischop ? 512 : 0;
3711 arg |= 256 + (s - f);
3713 *fpc++ = s - base; /* fieldsize for FETCH */
3714 *fpc++ = FF_DECIMAL;
3716 unchopnum |= ! ischop;
3718 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3719 arg = ischop ? 512 : 0;
3721 s++; /* skip the '0' first */
3730 arg |= 256 + (s - f);
3732 *fpc++ = s - base; /* fieldsize for FETCH */
3733 *fpc++ = FF_0DECIMAL;
3735 unchopnum |= ! ischop;
3739 bool ismore = FALSE;
3742 while (*++s == '>') ;
3743 prespace = FF_SPACE;
3745 else if (*s == '|') {
3746 while (*++s == '|') ;
3747 prespace = FF_HALFSPACE;
3752 while (*++s == '<') ;
3755 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3759 *fpc++ = s - base; /* fieldsize for FETCH */
3761 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3764 *fpc++ = (U16)prespace;
3778 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3780 { /* need to jump to the next word */
3782 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3783 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3784 s = SvPVX(sv) + SvCUR(sv) + z;
3786 Copy(fops, s, arg, U32);
3788 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3791 if (unchopnum && repeat)
3792 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3798 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3800 /* Can value be printed in fldsize chars, using %*.*f ? */
3804 int intsize = fldsize - (value < 0 ? 1 : 0);
3811 while (intsize--) pwr *= 10.0;
3812 while (frcsize--) eps /= 10.0;
3815 if (value + eps >= pwr)
3818 if (value - eps <= -pwr)
3825 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3827 SV *datasv = FILTER_DATA(idx);
3828 int filter_has_file = IoLINES(datasv);
3829 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3830 SV *filter_state = (SV *)IoTOP_GV(datasv);
3831 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3834 /* I was having segfault trouble under Linux 2.2.5 after a
3835 parse error occured. (Had to hack around it with a test
3836 for PL_error_count == 0.) Solaris doesn't segfault --
3837 not sure where the trouble is yet. XXX */
3839 if (filter_has_file) {
3840 len = FILTER_READ(idx+1, buf_sv, maxlen);
3843 if (filter_sub && len >= 0) {
3854 PUSHs(sv_2mortal(newSViv(maxlen)));
3856 PUSHs(filter_state);
3859 count = call_sv(filter_sub, G_SCALAR);
3875 IoLINES(datasv) = 0;
3876 if (filter_child_proc) {
3877 SvREFCNT_dec(filter_child_proc);
3878 IoFMT_GV(datasv) = Nullgv;
3881 SvREFCNT_dec(filter_state);
3882 IoTOP_GV(datasv) = Nullgv;
3885 SvREFCNT_dec(filter_sub);
3886 IoBOTTOM_GV(datasv) = Nullgv;
3888 filter_del(run_user_filter);
3894 /* perhaps someone can come up with a better name for
3895 this? it is not really "absolute", per se ... */
3897 S_path_is_absolute(pTHX_ char *name)
3899 if (PERL_FILE_IS_ABSOLUTE(name)
3900 #ifdef MACOS_TRADITIONAL
3903 || (*name == '.' && (name[1] == '/' ||
3904 (name[1] == '.' && name[2] == '/'))))