3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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*);
86 /* prevent recompiling under /o and ithreads. */
87 #if defined(USE_ITHREADS)
88 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
89 if (PL_op->op_flags & OPf_STACKED) {
98 if (PL_op->op_flags & OPf_STACKED) {
99 /* multiple args; concatentate them */
101 tmpstr = PAD_SV(ARGTARG);
102 sv_setpvn(tmpstr, "", 0);
103 while (++MARK <= SP) {
104 if (PL_amagic_generation) {
106 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
107 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
109 sv_setsv(tmpstr, sv);
113 sv_catsv(tmpstr, *MARK);
122 SV *sv = SvRV(tmpstr);
124 mg = mg_find(sv, PERL_MAGIC_qr);
127 regexp *re = (regexp *)mg->mg_obj;
128 ReREFCNT_dec(PM_GETRE(pm));
129 PM_SETRE(pm, ReREFCNT_inc(re));
132 t = SvPV(tmpstr, len);
134 /* Check against the last compiled regexp. */
135 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
136 PM_GETRE(pm)->prelen != (I32)len ||
137 memNE(PM_GETRE(pm)->precomp, t, len))
140 ReREFCNT_dec(PM_GETRE(pm));
141 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
143 if (PL_op->op_flags & OPf_SPECIAL)
144 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
146 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
148 pm->op_pmdynflags |= PMdf_DYN_UTF8;
150 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
151 if (pm->op_pmdynflags & PMdf_UTF8)
152 t = (char*)bytes_to_utf8((U8*)t, &len);
154 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
155 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
157 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
158 inside tie/overload accessors. */
162 #ifndef INCOMPLETE_TAINTS
165 pm->op_pmdynflags |= PMdf_TAINTED;
167 pm->op_pmdynflags &= ~PMdf_TAINTED;
171 if (!PM_GETRE(pm)->prelen && PL_curpm)
173 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
174 pm->op_pmflags |= PMf_WHITE;
176 pm->op_pmflags &= ~PMf_WHITE;
178 /* XXX runtime compiled output needs to move to the pad */
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
181 #if !defined(USE_ITHREADS)
182 /* XXX can't change the optree at runtime either */
183 cLOGOP->op_first->op_next = PL_op->op_next;
192 register PMOP *pm = (PMOP*) cLOGOP->op_other;
193 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
194 register SV *dstr = cx->sb_dstr;
195 register char *s = cx->sb_s;
196 register char *m = cx->sb_m;
197 char *orig = cx->sb_orig;
198 register REGEXP *rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 rxres_restore(&cx->sb_rxres, rx);
208 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
210 if (cx->sb_iters++) {
211 I32 saviters = cx->sb_iters;
212 if (cx->sb_iters > cx->sb_maxiters)
213 DIE(aTHX_ "Substitution loop");
215 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
216 cx->sb_rxtainted |= 2;
217 sv_catsv(dstr, POPs);
220 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
221 s == m, cx->sb_targ, NULL,
222 ((cx->sb_rflags & REXEC_COPY_STR)
223 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
224 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
226 SV *targ = cx->sb_targ;
228 assert(cx->sb_strend >= s);
229 if(cx->sb_strend > s) {
230 if (DO_UTF8(dstr) && !SvUTF8(targ))
231 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
233 sv_catpvn(dstr, s, cx->sb_strend - s);
235 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
237 #ifdef PERL_COPY_ON_WRITE
239 sv_force_normal_flags(targ, SV_COW_DROP_PV);
245 Safefree(SvPVX(targ));
247 SvPVX(targ) = SvPVX(dstr);
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
255 TAINT_IF(cx->sb_rxtainted & 1);
256 PUSHs(sv_2mortal(newSViv(saviters - 1)));
258 (void)SvPOK_only_UTF8(targ);
259 TAINT_IF(cx->sb_rxtainted);
263 LEAVE_SCOPE(cx->sb_oldsave);
266 RETURNOP(pm->op_next);
268 cx->sb_iters = saviters;
270 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
273 cx->sb_orig = orig = rx->subbeg;
275 cx->sb_strend = s + (cx->sb_strend - m);
277 cx->sb_m = m = rx->startp[0] + orig;
279 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
280 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
282 sv_catpvn(dstr, s, m-s);
284 cx->sb_s = rx->endp[0] + orig;
285 { /* Update the pos() information. */
286 SV *sv = cx->sb_targ;
289 if (SvTYPE(sv) < SVt_PVMG)
290 (void)SvUPGRADE(sv, SVt_PVMG);
291 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
292 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
293 mg = mg_find(sv, PERL_MAGIC_regex_global);
302 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
303 rxres_save(&cx->sb_rxres, rx);
304 RETURNOP(pm->op_pmreplstart);
308 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
313 if (!p || p[1] < rx->nparens) {
314 #ifdef PERL_COPY_ON_WRITE
315 i = 7 + rx->nparens * 2;
317 i = 6 + rx->nparens * 2;
326 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
327 RX_MATCH_COPIED_off(rx);
329 #ifdef PERL_COPY_ON_WRITE
330 *p++ = PTR2UV(rx->saved_copy);
331 rx->saved_copy = Nullsv;
336 *p++ = PTR2UV(rx->subbeg);
337 *p++ = (UV)rx->sublen;
338 for (i = 0; i <= rx->nparens; ++i) {
339 *p++ = (UV)rx->startp[i];
340 *p++ = (UV)rx->endp[i];
345 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
350 RX_MATCH_COPY_FREE(rx);
351 RX_MATCH_COPIED_set(rx, *p);
354 #ifdef PERL_COPY_ON_WRITE
356 SvREFCNT_dec (rx->saved_copy);
357 rx->saved_copy = INT2PTR(SV*,*p);
363 rx->subbeg = INT2PTR(char*,*p++);
364 rx->sublen = (I32)(*p++);
365 for (i = 0; i <= rx->nparens; ++i) {
366 rx->startp[i] = (I32)(*p++);
367 rx->endp[i] = (I32)(*p++);
372 Perl_rxres_free(pTHX_ void **rsp)
377 Safefree(INT2PTR(char*,*p));
378 #ifdef PERL_COPY_ON_WRITE
380 SvREFCNT_dec (INT2PTR(SV*,p[1]));
390 dSP; dMARK; dORIGMARK;
391 register SV *tmpForm = *++MARK;
398 register SV *sv = Nullsv;
403 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
404 char *chophere = Nullch;
405 char *linemark = Nullch;
407 bool gotsome = FALSE;
409 STRLEN fudge = SvPOK(tmpForm)
410 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
411 bool item_is_utf8 = FALSE;
412 bool targ_is_utf8 = FALSE;
418 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
419 if (SvREADONLY(tmpForm)) {
420 SvREADONLY_off(tmpForm);
421 parseres = doparseform(tmpForm);
422 SvREADONLY_on(tmpForm);
425 parseres = doparseform(tmpForm);
429 SvPV_force(PL_formtarget, len);
430 if (DO_UTF8(PL_formtarget))
432 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
434 f = SvPV(tmpForm, len);
435 /* need to jump to the next word */
436 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
445 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
446 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
447 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
448 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
449 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
451 case FF_CHECKNL: name = "CHECKNL"; break;
452 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
453 case FF_SPACE: name = "SPACE"; break;
454 case FF_HALFSPACE: name = "HALFSPACE"; break;
455 case FF_ITEM: name = "ITEM"; break;
456 case FF_CHOP: name = "CHOP"; break;
457 case FF_LINEGLOB: name = "LINEGLOB"; break;
458 case FF_NEWLINE: name = "NEWLINE"; break;
459 case FF_MORE: name = "MORE"; break;
460 case FF_LINEMARK: name = "LINEMARK"; break;
461 case FF_END: name = "END"; break;
462 case FF_0DECIMAL: name = "0DECIMAL"; break;
463 case FF_LINESNGL: name = "LINESNGL"; break;
466 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
468 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
479 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
480 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
482 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
483 t = SvEND(PL_formtarget);
486 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
487 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
489 sv_utf8_upgrade(PL_formtarget);
490 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
491 t = SvEND(PL_formtarget);
511 if (ckWARN(WARN_SYNTAX))
512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
517 item = s = SvPV(sv, len);
520 itemsize = sv_len_utf8(sv);
521 if (itemsize != (I32)len) {
523 if (itemsize > fieldsize) {
524 itemsize = fieldsize;
525 itembytes = itemsize;
526 sv_pos_u2b(sv, &itembytes, 0);
530 send = chophere = s + itembytes;
540 sv_pos_b2u(sv, &itemsize);
544 item_is_utf8 = FALSE;
545 if (itemsize > fieldsize)
546 itemsize = fieldsize;
547 send = chophere = s + itemsize;
559 item = s = SvPV(sv, len);
562 itemsize = sv_len_utf8(sv);
563 if (itemsize != (I32)len) {
565 if (itemsize <= fieldsize) {
566 send = chophere = s + itemsize;
578 itemsize = fieldsize;
579 itembytes = itemsize;
580 sv_pos_u2b(sv, &itembytes, 0);
581 send = chophere = s + itembytes;
582 while (s < send || (s == send && isSPACE(*s))) {
592 if (strchr(PL_chopset, *s))
597 itemsize = chophere - item;
598 sv_pos_b2u(sv, &itemsize);
604 item_is_utf8 = FALSE;
605 if (itemsize <= fieldsize) {
606 send = chophere = s + itemsize;
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
630 if (strchr(PL_chopset, *s))
635 itemsize = chophere - item;
640 arg = fieldsize - itemsize;
649 arg = fieldsize - itemsize;
663 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
665 sv_utf8_upgrade(PL_formtarget);
666 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
667 t = SvEND(PL_formtarget);
671 if (UTF8_IS_CONTINUED(*s)) {
672 STRLEN skip = UTF8SKIP(s);
689 if ( !((*t++ = *s++) & ~31) )
695 if (targ_is_utf8 && !item_is_utf8) {
696 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
698 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
699 for (; t < SvEND(PL_formtarget); t++) {
712 int ch = *t++ = *s++;
715 if ( !((*t++ = *s++) & ~31) )
724 while (*s && isSPACE(*s))
738 item = s = SvPV(sv, len);
740 if ((item_is_utf8 = DO_UTF8(sv)))
741 itemsize = sv_len_utf8(sv);
743 bool chopped = FALSE;
746 chophere = s + itemsize;
762 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
764 SvUTF8_on(PL_formtarget);
766 SvCUR_set(sv, chophere - item);
767 sv_catsv(PL_formtarget, sv);
768 SvCUR_set(sv, itemsize);
770 sv_catsv(PL_formtarget, sv);
772 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
773 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
774 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
782 #if defined(USE_LONG_DOUBLE)
783 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
785 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
790 #if defined(USE_LONG_DOUBLE)
791 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
793 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
796 /* If the field is marked with ^ and the value is undefined,
798 if ((arg & 512) && !SvOK(sv)) {
806 /* overflow evidence */
807 if (num_overflow(value, fieldsize, arg)) {
813 /* Formats aren't yet marked for locales, so assume "yes". */
815 STORE_NUMERIC_STANDARD_SET_LOCAL();
816 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
817 RESTORE_NUMERIC_STANDARD();
824 while (t-- > linemark && *t == ' ') ;
832 if (arg) { /* repeat until fields exhausted? */
834 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
835 lines += FmLINES(PL_formtarget);
838 if (strnEQ(linemark, linemark - arg, arg))
839 DIE(aTHX_ "Runaway format");
842 SvUTF8_on(PL_formtarget);
843 FmLINES(PL_formtarget) = lines;
845 RETURNOP(cLISTOP->op_first);
858 while (*s && isSPACE(*s) && s < send)
862 arg = fieldsize - itemsize;
869 if (strnEQ(s," ",3)) {
870 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
881 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
883 SvUTF8_on(PL_formtarget);
884 FmLINES(PL_formtarget) += lines;
896 if (PL_stack_base + *PL_markstack_ptr == SP) {
898 if (GIMME_V == G_SCALAR)
899 XPUSHs(sv_2mortal(newSViv(0)));
900 RETURNOP(PL_op->op_next->op_next);
902 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
903 pp_pushmark(); /* push dst */
904 pp_pushmark(); /* push src */
905 ENTER; /* enter outer scope */
908 if (PL_op->op_private & OPpGREP_LEX)
909 SAVESPTR(PAD_SVl(PL_op->op_targ));
912 ENTER; /* enter inner scope */
915 src = PL_stack_base[*PL_markstack_ptr];
917 if (PL_op->op_private & OPpGREP_LEX)
918 PAD_SVl(PL_op->op_targ) = src;
923 if (PL_op->op_type == OP_MAPSTART)
924 pp_pushmark(); /* push top */
925 return ((LOGOP*)PL_op->op_next)->op_other;
930 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
937 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
943 /* first, move source pointer to the next item in the source list */
944 ++PL_markstack_ptr[-1];
946 /* if there are new items, push them into the destination list */
947 if (items && gimme != G_VOID) {
948 /* might need to make room back there first */
949 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
950 /* XXX this implementation is very pessimal because the stack
951 * is repeatedly extended for every set of items. Is possible
952 * to do this without any stack extension or copying at all
953 * by maintaining a separate list over which the map iterates
954 * (like foreach does). --gsar */
956 /* everything in the stack after the destination list moves
957 * towards the end the stack by the amount of room needed */
958 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
960 /* items to shift up (accounting for the moved source pointer) */
961 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
963 /* This optimization is by Ben Tilly and it does
964 * things differently from what Sarathy (gsar)
965 * is describing. The downside of this optimization is
966 * that leaves "holes" (uninitialized and hopefully unused areas)
967 * to the Perl stack, but on the other hand this
968 * shouldn't be a problem. If Sarathy's idea gets
969 * implemented, this optimization should become
970 * irrelevant. --jhi */
972 shift = count; /* Avoid shifting too often --Ben Tilly */
977 PL_markstack_ptr[-1] += shift;
978 *PL_markstack_ptr += shift;
982 /* copy the new items down to the destination list */
983 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
984 if (gimme == G_ARRAY) {
986 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
989 /* scalar context: we don't care about which values map returns
990 * (we use undef here). And so we certainly don't want to do mortal
991 * copies of meaningless values. */
992 while (items-- > 0) {
994 *dst-- = &PL_sv_undef;
998 LEAVE; /* exit inner scope */
1001 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1003 (void)POPMARK; /* pop top */
1004 LEAVE; /* exit outer scope */
1005 (void)POPMARK; /* pop src */
1006 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1007 (void)POPMARK; /* pop dst */
1008 SP = PL_stack_base + POPMARK; /* pop original mark */
1009 if (gimme == G_SCALAR) {
1010 if (PL_op->op_private & OPpGREP_LEX) {
1011 SV* sv = sv_newmortal();
1012 sv_setiv(sv, items);
1020 else if (gimme == G_ARRAY)
1027 ENTER; /* enter inner scope */
1030 /* set $_ to the new source item */
1031 src = PL_stack_base[PL_markstack_ptr[-1]];
1033 if (PL_op->op_private & OPpGREP_LEX)
1034 PAD_SVl(PL_op->op_targ) = src;
1038 RETURNOP(cLOGOP->op_other);
1046 if (GIMME == G_ARRAY)
1048 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1049 return cLOGOP->op_other;
1058 if (GIMME == G_ARRAY) {
1059 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1063 SV *targ = PAD_SV(PL_op->op_targ);
1066 if (PL_op->op_private & OPpFLIP_LINENUM) {
1067 if (GvIO(PL_last_in_gv)) {
1068 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1071 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1072 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1078 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1079 if (PL_op->op_flags & OPf_SPECIAL) {
1087 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1096 /* This code tries to decide if "$left .. $right" should use the
1097 magical string increment, or if the range is numeric (we make
1098 an exception for .."0" [#18165]). AMS 20021031. */
1100 #define RANGE_IS_NUMERIC(left,right) ( \
1101 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1102 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1103 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1104 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1105 && (!SvOK(right) || looks_like_number(right))))
1111 if (GIMME == G_ARRAY) {
1117 if (SvGMAGICAL(left))
1119 if (SvGMAGICAL(right))
1122 if (RANGE_IS_NUMERIC(left,right)) {
1123 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1124 (SvOK(right) && SvNV(right) > IV_MAX))
1125 DIE(aTHX_ "Range iterator outside integer range");
1136 sv = sv_2mortal(newSViv(i++));
1141 SV *final = sv_mortalcopy(right);
1143 char *tmps = SvPV(final, len);
1145 sv = sv_mortalcopy(left);
1147 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1149 if (strEQ(SvPVX(sv),tmps))
1151 sv = sv_2mortal(newSVsv(sv));
1158 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1162 if (PL_op->op_private & OPpFLIP_LINENUM) {
1163 if (GvIO(PL_last_in_gv)) {
1164 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1167 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1168 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1176 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1177 sv_catpv(targ, "E0");
1187 static char *context_name[] = {
1198 S_dopoptolabel(pTHX_ char *label)
1201 register PERL_CONTEXT *cx;
1203 for (i = cxstack_ix; i >= 0; i--) {
1205 switch (CxTYPE(cx)) {
1211 if (ckWARN(WARN_EXITING))
1212 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1213 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1214 if (CxTYPE(cx) == CXt_NULL)
1218 if (!cx->blk_loop.label ||
1219 strNE(label, cx->blk_loop.label) ) {
1220 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1221 (long)i, cx->blk_loop.label));
1224 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1232 Perl_dowantarray(pTHX)
1234 I32 gimme = block_gimme();
1235 return (gimme == G_VOID) ? G_SCALAR : gimme;
1239 Perl_block_gimme(pTHX)
1243 cxix = dopoptosub(cxstack_ix);
1247 switch (cxstack[cxix].blk_gimme) {
1255 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1262 Perl_is_lvalue_sub(pTHX)
1266 cxix = dopoptosub(cxstack_ix);
1267 assert(cxix >= 0); /* We should only be called from inside subs */
1269 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1270 return cxstack[cxix].blk_sub.lval;
1276 S_dopoptosub(pTHX_ I32 startingblock)
1278 return dopoptosub_at(cxstack, startingblock);
1282 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1285 register PERL_CONTEXT *cx;
1286 for (i = startingblock; i >= 0; i--) {
1288 switch (CxTYPE(cx)) {
1294 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1302 S_dopoptoeval(pTHX_ I32 startingblock)
1305 register PERL_CONTEXT *cx;
1306 for (i = startingblock; i >= 0; i--) {
1308 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1323 register PERL_CONTEXT *cx;
1324 for (i = startingblock; i >= 0; i--) {
1326 switch (CxTYPE(cx)) {
1332 if (ckWARN(WARN_EXITING))
1333 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335 if ((CxTYPE(cx)) == CXt_NULL)
1339 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1347 Perl_dounwind(pTHX_ I32 cxix)
1349 register PERL_CONTEXT *cx;
1352 while (cxstack_ix > cxix) {
1354 cx = &cxstack[cxstack_ix];
1355 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1356 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1357 /* Note: we don't need to restore the base context info till the end. */
1358 switch (CxTYPE(cx)) {
1361 continue; /* not break */
1383 Perl_qerror(pTHX_ SV *err)
1386 sv_catsv(ERRSV, err);
1388 sv_catsv(PL_errors, err);
1390 Perl_warn(aTHX_ "%"SVf, err);
1395 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1401 register PERL_CONTEXT *cx;
1406 if (PL_in_eval & EVAL_KEEPERR) {
1407 static char prefix[] = "\t(in cleanup) ";
1412 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1415 if (*e != *message || strNE(e,message))
1419 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1420 sv_catpvn(err, prefix, sizeof(prefix)-1);
1421 sv_catpvn(err, message, msglen);
1422 if (ckWARN(WARN_MISC)) {
1423 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1424 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1429 sv_setpvn(ERRSV, message, msglen);
1433 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1434 && PL_curstackinfo->si_prev)
1443 if (cxix < cxstack_ix)
1446 POPBLOCK(cx,PL_curpm);
1447 if (CxTYPE(cx) != CXt_EVAL) {
1449 message = SvPVx(ERRSV, msglen);
1450 PerlIO_write(Perl_error_log, "panic: die ", 11);
1451 PerlIO_write(Perl_error_log, message, msglen);
1456 if (gimme == G_SCALAR)
1457 *++newsp = &PL_sv_undef;
1458 PL_stack_sp = newsp;
1462 /* LEAVE could clobber PL_curcop (see save_re_context())
1463 * XXX it might be better to find a way to avoid messing with
1464 * PL_curcop in save_re_context() instead, but this is a more
1465 * minimal fix --GSAR */
1466 PL_curcop = cx->blk_oldcop;
1468 if (optype == OP_REQUIRE) {
1469 char* msg = SvPVx(ERRSV, n_a);
1470 SV *nsv = cx->blk_eval.old_namesv;
1471 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1473 DIE(aTHX_ "%sCompilation failed in require",
1474 *msg ? msg : "Unknown error\n");
1476 assert(CxTYPE(cx) == CXt_EVAL);
1477 return cx->blk_eval.retop;
1481 message = SvPVx(ERRSV, msglen);
1483 write_to_stderr(message, msglen);
1492 if (SvTRUE(left) != SvTRUE(right))
1504 RETURNOP(cLOGOP->op_other);
1513 RETURNOP(cLOGOP->op_other);
1522 if (!sv || !SvANY(sv)) {
1523 RETURNOP(cLOGOP->op_other);
1526 switch (SvTYPE(sv)) {
1528 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1532 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1536 if (CvROOT(sv) || CvXSUB(sv))
1546 RETURNOP(cLOGOP->op_other);
1552 register I32 cxix = dopoptosub(cxstack_ix);
1553 register PERL_CONTEXT *cx;
1554 register PERL_CONTEXT *ccstack = cxstack;
1555 PERL_SI *top_si = PL_curstackinfo;
1566 /* we may be in a higher stacklevel, so dig down deeper */
1567 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1568 top_si = top_si->si_prev;
1569 ccstack = top_si->si_cxstack;
1570 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1573 if (GIMME != G_ARRAY) {
1579 if (PL_DBsub && cxix >= 0 &&
1580 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1584 cxix = dopoptosub_at(ccstack, cxix - 1);
1587 cx = &ccstack[cxix];
1588 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1589 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1590 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1591 field below is defined for any cx. */
1592 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1593 cx = &ccstack[dbcxix];
1596 stashname = CopSTASHPV(cx->blk_oldcop);
1597 if (GIMME != G_ARRAY) {
1600 PUSHs(&PL_sv_undef);
1603 sv_setpv(TARG, stashname);
1612 PUSHs(&PL_sv_undef);
1614 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1615 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1616 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1619 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1620 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1621 /* So is ccstack[dbcxix]. */
1624 gv_efullname3(sv, cvgv, Nullch);
1625 PUSHs(sv_2mortal(sv));
1626 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1629 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1630 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1634 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1635 PUSHs(sv_2mortal(newSViv(0)));
1637 gimme = (I32)cx->blk_gimme;
1638 if (gimme == G_VOID)
1639 PUSHs(&PL_sv_undef);
1641 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1642 if (CxTYPE(cx) == CXt_EVAL) {
1644 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1645 PUSHs(cx->blk_eval.cur_text);
1649 else if (cx->blk_eval.old_namesv) {
1650 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1653 /* eval BLOCK (try blocks have old_namesv == 0) */
1655 PUSHs(&PL_sv_undef);
1656 PUSHs(&PL_sv_undef);
1660 PUSHs(&PL_sv_undef);
1661 PUSHs(&PL_sv_undef);
1663 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1664 && CopSTASH_eq(PL_curcop, PL_debstash))
1666 AV *ary = cx->blk_sub.argarray;
1667 int off = AvARRAY(ary) - AvALLOC(ary);
1671 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1674 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1677 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1678 av_extend(PL_dbargs, AvFILLp(ary) + off);
1679 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1680 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1682 /* XXX only hints propagated via op_private are currently
1683 * visible (others are not easily accessible, since they
1684 * use the global PL_hints) */
1685 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1686 HINT_PRIVATE_MASK)));
1689 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1691 if (old_warnings == pWARN_NONE ||
1692 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1693 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1694 else if (old_warnings == pWARN_ALL ||
1695 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1696 /* Get the bit mask for $warnings::Bits{all}, because
1697 * it could have been extended by warnings::register */
1699 HV *bits = get_hv("warnings::Bits", FALSE);
1700 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1701 mask = newSVsv(*bits_all);
1704 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1708 mask = newSVsv(old_warnings);
1709 PUSHs(sv_2mortal(mask));
1724 sv_reset(tmps, CopSTASH(PL_curcop));
1734 /* like pp_nextstate, but used instead when the debugger is active */
1738 PL_curcop = (COP*)PL_op;
1739 TAINT_NOT; /* Each statement is presumed innocent */
1740 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1743 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1744 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1748 register PERL_CONTEXT *cx;
1749 I32 gimme = G_ARRAY;
1756 DIE(aTHX_ "No DB::DB routine defined");
1758 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1759 /* don't do recursive DB::DB call */
1771 PUSHBLOCK(cx, CXt_SUB, SP);
1773 cx->blk_sub.retop = PL_op->op_next;
1775 PAD_SET_CUR(CvPADLIST(cv),1);
1776 RETURNOP(CvSTART(cv));
1790 register PERL_CONTEXT *cx;
1791 I32 gimme = GIMME_V;
1793 U32 cxtype = CXt_LOOP;
1801 if (PL_op->op_targ) {
1802 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1803 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1804 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1805 SVs_PADSTALE, SVs_PADSTALE);
1807 #ifndef USE_ITHREADS
1808 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1811 SAVEPADSV(PL_op->op_targ);
1812 iterdata = INT2PTR(void*, PL_op->op_targ);
1813 cxtype |= CXp_PADVAR;
1818 svp = &GvSV(gv); /* symbol table variable */
1819 SAVEGENERICSV(*svp);
1822 iterdata = (void*)gv;
1828 PUSHBLOCK(cx, cxtype, SP);
1830 PUSHLOOP(cx, iterdata, MARK);
1832 PUSHLOOP(cx, svp, MARK);
1834 if (PL_op->op_flags & OPf_STACKED) {
1835 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1836 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1838 SV *right = (SV*)cx->blk_loop.iterary;
1839 if (RANGE_IS_NUMERIC(sv,right)) {
1840 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1841 (SvOK(right) && SvNV(right) >= IV_MAX))
1842 DIE(aTHX_ "Range iterator outside integer range");
1843 cx->blk_loop.iterix = SvIV(sv);
1844 cx->blk_loop.itermax = SvIV(right);
1848 cx->blk_loop.iterlval = newSVsv(sv);
1849 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1850 (void) SvPV(right,n_a);
1853 else if (PL_op->op_private & OPpITER_REVERSED) {
1854 cx->blk_loop.itermax = -1;
1855 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1860 cx->blk_loop.iterary = PL_curstack;
1861 AvFILLp(PL_curstack) = SP - PL_stack_base;
1862 if (PL_op->op_private & OPpITER_REVERSED) {
1863 cx->blk_loop.itermax = MARK - PL_stack_base;
1864 cx->blk_loop.iterix = cx->blk_oldsp;
1867 cx->blk_loop.iterix = MARK - PL_stack_base;
1877 register PERL_CONTEXT *cx;
1878 I32 gimme = GIMME_V;
1884 PUSHBLOCK(cx, CXt_LOOP, SP);
1885 PUSHLOOP(cx, 0, SP);
1893 register PERL_CONTEXT *cx;
1901 newsp = PL_stack_base + cx->blk_loop.resetsp;
1904 if (gimme == G_VOID)
1906 else if (gimme == G_SCALAR) {
1908 *++newsp = sv_mortalcopy(*SP);
1910 *++newsp = &PL_sv_undef;
1914 *++newsp = sv_mortalcopy(*++mark);
1915 TAINT_NOT; /* Each item is independent */
1921 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1922 PL_curpm = newpm; /* ... and pop $1 et al */
1934 register PERL_CONTEXT *cx;
1935 bool popsub2 = FALSE;
1936 bool clear_errsv = FALSE;
1944 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1945 if (cxstack_ix == PL_sortcxix
1946 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1948 if (cxstack_ix > PL_sortcxix)
1949 dounwind(PL_sortcxix);
1950 AvARRAY(PL_curstack)[1] = *SP;
1951 PL_stack_sp = PL_stack_base + 1;
1956 cxix = dopoptosub(cxstack_ix);
1958 DIE(aTHX_ "Can't return outside a subroutine");
1959 if (cxix < cxstack_ix)
1963 switch (CxTYPE(cx)) {
1966 retop = cx->blk_sub.retop;
1967 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1970 if (!(PL_in_eval & EVAL_KEEPERR))
1973 retop = cx->blk_eval.retop;
1977 if (optype == OP_REQUIRE &&
1978 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1980 /* Unassume the success we assumed earlier. */
1981 SV *nsv = cx->blk_eval.old_namesv;
1982 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1983 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1988 retop = cx->blk_sub.retop;
1991 DIE(aTHX_ "panic: return");
1995 if (gimme == G_SCALAR) {
1998 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2000 *++newsp = SvREFCNT_inc(*SP);
2005 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2007 *++newsp = sv_mortalcopy(sv);
2012 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2015 *++newsp = sv_mortalcopy(*SP);
2018 *++newsp = &PL_sv_undef;
2020 else if (gimme == G_ARRAY) {
2021 while (++MARK <= SP) {
2022 *++newsp = (popsub2 && SvTEMP(*MARK))
2023 ? *MARK : sv_mortalcopy(*MARK);
2024 TAINT_NOT; /* Each item is independent */
2027 PL_stack_sp = newsp;
2030 /* Stack values are safe: */
2033 POPSUB(cx,sv); /* release CV and @_ ... */
2037 PL_curpm = newpm; /* ... and pop $1 et al */
2049 register PERL_CONTEXT *cx;
2059 if (PL_op->op_flags & OPf_SPECIAL) {
2060 cxix = dopoptoloop(cxstack_ix);
2062 DIE(aTHX_ "Can't \"last\" outside a loop block");
2065 cxix = dopoptolabel(cPVOP->op_pv);
2067 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2069 if (cxix < cxstack_ix)
2073 cxstack_ix++; /* temporarily protect top context */
2075 switch (CxTYPE(cx)) {
2078 newsp = PL_stack_base + cx->blk_loop.resetsp;
2079 nextop = cx->blk_loop.last_op->op_next;
2083 nextop = cx->blk_sub.retop;
2087 nextop = cx->blk_eval.retop;
2091 nextop = cx->blk_sub.retop;
2094 DIE(aTHX_ "panic: last");
2098 if (gimme == G_SCALAR) {
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2101 ? *SP : sv_mortalcopy(*SP);
2103 *++newsp = &PL_sv_undef;
2105 else if (gimme == G_ARRAY) {
2106 while (++MARK <= SP) {
2107 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2108 ? *MARK : sv_mortalcopy(*MARK);
2109 TAINT_NOT; /* Each item is independent */
2117 /* Stack values are safe: */
2120 POPLOOP(cx); /* release loop vars ... */
2124 POPSUB(cx,sv); /* release CV and @_ ... */
2127 PL_curpm = newpm; /* ... and pop $1 et al */
2136 register PERL_CONTEXT *cx;
2139 if (PL_op->op_flags & OPf_SPECIAL) {
2140 cxix = dopoptoloop(cxstack_ix);
2142 DIE(aTHX_ "Can't \"next\" outside a loop block");
2145 cxix = dopoptolabel(cPVOP->op_pv);
2147 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2149 if (cxix < cxstack_ix)
2152 /* clear off anything above the scope we're re-entering, but
2153 * save the rest until after a possible continue block */
2154 inner = PL_scopestack_ix;
2156 if (PL_scopestack_ix < inner)
2157 leave_scope(PL_scopestack[PL_scopestack_ix]);
2158 return cx->blk_loop.next_op;
2164 register PERL_CONTEXT *cx;
2167 if (PL_op->op_flags & OPf_SPECIAL) {
2168 cxix = dopoptoloop(cxstack_ix);
2170 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2173 cxix = dopoptolabel(cPVOP->op_pv);
2175 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2177 if (cxix < cxstack_ix)
2181 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2182 LEAVE_SCOPE(oldsave);
2184 return cx->blk_loop.redo_op;
2188 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2192 static char too_deep[] = "Target of goto is too deeply nested";
2195 Perl_croak(aTHX_ too_deep);
2196 if (o->op_type == OP_LEAVE ||
2197 o->op_type == OP_SCOPE ||
2198 o->op_type == OP_LEAVELOOP ||
2199 o->op_type == OP_LEAVESUB ||
2200 o->op_type == OP_LEAVETRY)
2202 *ops++ = cUNOPo->op_first;
2204 Perl_croak(aTHX_ too_deep);
2207 if (o->op_flags & OPf_KIDS) {
2208 /* First try all the kids at this level, since that's likeliest. */
2209 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2210 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2211 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2214 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2215 if (kid == PL_lastgotoprobe)
2217 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2220 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2221 ops[-1]->op_type == OP_DBSTATE)
2226 if ((o = dofindlabel(kid, label, ops, oplimit)))
2245 register PERL_CONTEXT *cx;
2246 #define GOTO_DEPTH 64
2247 OP *enterops[GOTO_DEPTH];
2249 int do_dump = (PL_op->op_type == OP_DUMP);
2250 static char must_have_label[] = "goto must have label";
2253 if (PL_op->op_flags & OPf_STACKED) {
2257 /* This egregious kludge implements goto &subroutine */
2258 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2260 register PERL_CONTEXT *cx;
2261 CV* cv = (CV*)SvRV(sv);
2268 if (!CvROOT(cv) && !CvXSUB(cv)) {
2273 /* autoloaded stub? */
2274 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2276 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2277 GvNAMELEN(gv), FALSE);
2278 if (autogv && (cv = GvCV(autogv)))
2280 tmpstr = sv_newmortal();
2281 gv_efullname3(tmpstr, gv, Nullch);
2282 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2284 DIE(aTHX_ "Goto undefined subroutine");
2287 /* First do some returnish stuff. */
2288 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2290 cxix = dopoptosub(cxstack_ix);
2292 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2293 if (cxix < cxstack_ix)
2297 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2298 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2299 /* put @_ back onto stack */
2300 AV* av = cx->blk_sub.argarray;
2302 items = AvFILLp(av) + 1;
2303 EXTEND(SP, items+1); /* @_ could have been extended. */
2304 Copy(AvARRAY(av), SP + 1, items, SV*);
2305 SvREFCNT_dec(GvAV(PL_defgv));
2306 GvAV(PL_defgv) = cx->blk_sub.savearray;
2308 /* abandon @_ if it got reified */
2313 av_extend(av, items-1);
2314 AvFLAGS(av) = AVf_REIFY;
2315 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2318 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2320 av = GvAV(PL_defgv);
2321 items = AvFILLp(av) + 1;
2322 EXTEND(SP, items+1); /* @_ could have been extended. */
2323 Copy(AvARRAY(av), SP + 1, items, SV*);
2327 if (CxTYPE(cx) == CXt_SUB &&
2328 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2329 SvREFCNT_dec(cx->blk_sub.cv);
2330 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2331 LEAVE_SCOPE(oldsave);
2333 /* Now do some callish stuff. */
2335 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2339 for (index=0; index<items; index++)
2340 sv_2mortal(SP[-index]);
2342 #ifdef PERL_XSUB_OLDSTYLE
2343 if (CvOLDSTYLE(cv)) {
2344 I32 (*fp3)(int,int,int);
2349 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2350 items = (*fp3)(CvXSUBANY(cv).any_i32,
2351 mark - PL_stack_base + 1,
2353 SP = PL_stack_base + items;
2356 #endif /* PERL_XSUB_OLDSTYLE */
2361 /* Push a mark for the start of arglist */
2364 (void)(*CvXSUB(cv))(aTHX_ cv);
2365 /* Pop the current context like a decent sub should */
2366 POPBLOCK(cx, PL_curpm);
2367 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2370 assert(CxTYPE(cx) == CXt_SUB);
2371 return cx->blk_sub.retop;
2374 AV* padlist = CvPADLIST(cv);
2375 if (CxTYPE(cx) == CXt_EVAL) {
2376 PL_in_eval = cx->blk_eval.old_in_eval;
2377 PL_eval_root = cx->blk_eval.old_eval_root;
2378 cx->cx_type = CXt_SUB;
2379 cx->blk_sub.hasargs = 0;
2381 cx->blk_sub.cv = cv;
2382 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2385 if (CvDEPTH(cv) < 2)
2386 (void)SvREFCNT_inc(cv);
2388 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2389 sub_crush_depth(cv);
2390 pad_push(padlist, CvDEPTH(cv), 1);
2392 PAD_SET_CUR(padlist, CvDEPTH(cv));
2393 if (cx->blk_sub.hasargs)
2395 AV* av = (AV*)PAD_SVl(0);
2398 cx->blk_sub.savearray = GvAV(PL_defgv);
2399 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2400 CX_CURPAD_SAVE(cx->blk_sub);
2401 cx->blk_sub.argarray = av;
2403 if (items >= AvMAX(av) + 1) {
2405 if (AvARRAY(av) != ary) {
2406 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2407 SvPVX(av) = (char*)ary;
2409 if (items >= AvMAX(av) + 1) {
2410 AvMAX(av) = items - 1;
2411 Renew(ary,items+1,SV*);
2413 SvPVX(av) = (char*)ary;
2417 Copy(mark,AvARRAY(av),items,SV*);
2418 AvFILLp(av) = items - 1;
2419 assert(!AvREAL(av));
2421 /* transfer 'ownership' of refcnts to new @_ */
2431 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2433 * We do not care about using sv to call CV;
2434 * it's for informational purposes only.
2436 SV *sv = GvSV(PL_DBsub);
2439 if (PERLDB_SUB_NN) {
2440 (void)SvUPGRADE(sv, SVt_PVIV);
2443 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2446 gv_efullname3(sv, CvGV(cv), Nullch);
2449 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2450 PUSHMARK( PL_stack_sp );
2451 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2455 RETURNOP(CvSTART(cv));
2459 label = SvPV(sv,n_a);
2460 if (!(do_dump || *label))
2461 DIE(aTHX_ must_have_label);
2464 else if (PL_op->op_flags & OPf_SPECIAL) {
2466 DIE(aTHX_ must_have_label);
2469 label = cPVOP->op_pv;
2471 if (label && *label) {
2473 bool leaving_eval = FALSE;
2474 bool in_block = FALSE;
2475 PERL_CONTEXT *last_eval_cx = 0;
2479 PL_lastgotoprobe = 0;
2481 for (ix = cxstack_ix; ix >= 0; ix--) {
2483 switch (CxTYPE(cx)) {
2485 leaving_eval = TRUE;
2486 if (!CxTRYBLOCK(cx)) {
2487 gotoprobe = (last_eval_cx ?
2488 last_eval_cx->blk_eval.old_eval_root :
2493 /* else fall through */
2495 gotoprobe = cx->blk_oldcop->op_sibling;
2501 gotoprobe = cx->blk_oldcop->op_sibling;
2504 gotoprobe = PL_main_root;
2507 if (CvDEPTH(cx->blk_sub.cv)) {
2508 gotoprobe = CvROOT(cx->blk_sub.cv);
2514 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2517 DIE(aTHX_ "panic: goto");
2518 gotoprobe = PL_main_root;
2522 retop = dofindlabel(gotoprobe, label,
2523 enterops, enterops + GOTO_DEPTH);
2527 PL_lastgotoprobe = gotoprobe;
2530 DIE(aTHX_ "Can't find label %s", label);
2532 /* if we're leaving an eval, check before we pop any frames
2533 that we're not going to punt, otherwise the error
2536 if (leaving_eval && *enterops && enterops[1]) {
2538 for (i = 1; enterops[i]; i++)
2539 if (enterops[i]->op_type == OP_ENTERITER)
2540 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2543 /* pop unwanted frames */
2545 if (ix < cxstack_ix) {
2552 oldsave = PL_scopestack[PL_scopestack_ix];
2553 LEAVE_SCOPE(oldsave);
2556 /* push wanted frames */
2558 if (*enterops && enterops[1]) {
2560 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2561 for (; enterops[ix]; ix++) {
2562 PL_op = enterops[ix];
2563 /* Eventually we may want to stack the needed arguments
2564 * for each op. For now, we punt on the hard ones. */
2565 if (PL_op->op_type == OP_ENTERITER)
2566 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2567 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2575 if (!retop) retop = PL_main_start;
2577 PL_restartop = retop;
2578 PL_do_undump = TRUE;
2582 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2583 PL_do_undump = FALSE;
2599 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2601 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2604 PL_exit_flags |= PERL_EXIT_EXPECTED;
2606 PUSHs(&PL_sv_undef);
2614 NV value = SvNVx(GvSV(cCOP->cop_gv));
2615 register I32 match = I_32(value);
2618 if (((NV)match) > value)
2619 --match; /* was fractional--truncate other way */
2621 match -= cCOP->uop.scop.scop_offset;
2624 else if (match > cCOP->uop.scop.scop_max)
2625 match = cCOP->uop.scop.scop_max;
2626 PL_op = cCOP->uop.scop.scop_next[match];
2636 PL_op = PL_op->op_next; /* can't assume anything */
2639 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2640 match -= cCOP->uop.scop.scop_offset;
2643 else if (match > cCOP->uop.scop.scop_max)
2644 match = cCOP->uop.scop.scop_max;
2645 PL_op = cCOP->uop.scop.scop_next[match];
2654 S_save_lines(pTHX_ AV *array, SV *sv)
2656 register char *s = SvPVX(sv);
2657 register char *send = SvPVX(sv) + SvCUR(sv);
2659 register I32 line = 1;
2661 while (s && s < send) {
2662 SV *tmpstr = NEWSV(85,0);
2664 sv_upgrade(tmpstr, SVt_PVMG);
2665 t = strchr(s, '\n');
2671 sv_setpvn(tmpstr, s, t - s);
2672 av_store(array, line++, tmpstr);
2678 S_docatch_body(pTHX)
2685 S_docatch(pTHX_ OP *o)
2690 volatile PERL_SI *cursi = PL_curstackinfo;
2694 assert(CATCH_GET == TRUE);
2698 /* Normally, the leavetry at the end of this block of ops will
2699 * pop an op off the return stack and continue there. By setting
2700 * the op to Nullop, we force an exit from the inner runops()
2703 assert(cxstack_ix >= 0);
2704 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2705 retop = cxstack[cxstack_ix].blk_eval.retop;
2706 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2715 /* die caught by an inner eval - continue inner loop */
2716 if (PL_restartop && cursi == PL_curstackinfo) {
2717 PL_op = PL_restartop;
2721 /* a die in this eval - continue in outer loop */
2737 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2738 /* sv Text to convert to OP tree. */
2739 /* startop op_free() this to undo. */
2740 /* code Short string id of the caller. */
2742 dSP; /* Make POPBLOCK work. */
2745 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2749 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2750 char *tmpbuf = tbuf;
2753 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2758 /* switch to eval mode */
2760 if (IN_PERL_COMPILETIME) {
2761 SAVECOPSTASH_FREE(&PL_compiling);
2762 CopSTASH_set(&PL_compiling, PL_curstash);
2764 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2765 SV *sv = sv_newmortal();
2766 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2767 code, (unsigned long)++PL_evalseq,
2768 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2772 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2773 SAVECOPFILE_FREE(&PL_compiling);
2774 CopFILE_set(&PL_compiling, tmpbuf+2);
2775 SAVECOPLINE(&PL_compiling);
2776 CopLINE_set(&PL_compiling, 1);
2777 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2778 deleting the eval's FILEGV from the stash before gv_check() runs
2779 (i.e. before run-time proper). To work around the coredump that
2780 ensues, we always turn GvMULTI_on for any globals that were
2781 introduced within evals. See force_ident(). GSAR 96-10-12 */
2782 safestr = savepv(tmpbuf);
2783 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2785 #ifdef OP_IN_REGISTER
2791 /* we get here either during compilation, or via pp_regcomp at runtime */
2792 runtime = IN_PERL_RUNTIME;
2794 runcv = find_runcv(NULL);
2797 PL_op->op_type = OP_ENTEREVAL;
2798 PL_op->op_flags = 0; /* Avoid uninit warning. */
2799 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2800 PUSHEVAL(cx, 0, Nullgv);
2803 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2805 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2806 POPBLOCK(cx,PL_curpm);
2809 (*startop)->op_type = OP_NULL;
2810 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2812 /* XXX DAPM do this properly one year */
2813 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2815 if (IN_PERL_COMPILETIME)
2816 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2817 #ifdef OP_IN_REGISTER
2825 =for apidoc find_runcv
2827 Locate the CV corresponding to the currently executing sub or eval.
2828 If db_seqp is non_null, skip CVs that are in the DB package and populate
2829 *db_seqp with the cop sequence number at the point that the DB:: code was
2830 entered. (allows debuggers to eval in the scope of the breakpoint rather
2831 than in in the scope of the debugger itself).
2837 Perl_find_runcv(pTHX_ U32 *db_seqp)
2844 *db_seqp = PL_curcop->cop_seq;
2845 for (si = PL_curstackinfo; si; si = si->si_prev) {
2846 for (ix = si->si_cxix; ix >= 0; ix--) {
2847 cx = &(si->si_cxstack[ix]);
2848 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2849 CV *cv = cx->blk_sub.cv;
2850 /* skip DB:: code */
2851 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2852 *db_seqp = cx->blk_oldcop->cop_seq;
2857 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2865 /* Compile a require/do, an eval '', or a /(?{...})/.
2866 * In the last case, startop is non-null, and contains the address of
2867 * a pointer that should be set to the just-compiled code.
2868 * outside is the lexically enclosing CV (if any) that invoked us.
2871 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2873 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2878 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2879 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2884 SAVESPTR(PL_compcv);
2885 PL_compcv = (CV*)NEWSV(1104,0);
2886 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2887 CvEVAL_on(PL_compcv);
2888 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2889 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2891 CvOUTSIDE_SEQ(PL_compcv) = seq;
2892 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2894 /* set up a scratch pad */
2896 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2899 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2901 /* make sure we compile in the right package */
2903 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2904 SAVESPTR(PL_curstash);
2905 PL_curstash = CopSTASH(PL_curcop);
2907 SAVESPTR(PL_beginav);
2908 PL_beginav = newAV();
2909 SAVEFREESV(PL_beginav);
2910 SAVEI32(PL_error_count);
2912 /* try to compile it */
2914 PL_eval_root = Nullop;
2916 PL_curcop = &PL_compiling;
2917 PL_curcop->cop_arybase = 0;
2918 if (saveop && saveop->op_flags & OPf_SPECIAL)
2919 PL_in_eval |= EVAL_KEEPERR;
2922 if (yyparse() || PL_error_count || !PL_eval_root) {
2923 SV **newsp; /* Used by POPBLOCK. */
2924 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2925 I32 optype = 0; /* Might be reset by POPEVAL. */
2930 op_free(PL_eval_root);
2931 PL_eval_root = Nullop;
2933 SP = PL_stack_base + POPMARK; /* pop original mark */
2935 POPBLOCK(cx,PL_curpm);
2940 if (optype == OP_REQUIRE) {
2941 char* msg = SvPVx(ERRSV, n_a);
2942 SV *nsv = cx->blk_eval.old_namesv;
2943 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2945 DIE(aTHX_ "%sCompilation failed in require",
2946 *msg ? msg : "Unknown error\n");
2949 char* msg = SvPVx(ERRSV, n_a);
2951 POPBLOCK(cx,PL_curpm);
2953 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2954 (*msg ? msg : "Unknown error\n"));
2957 char* msg = SvPVx(ERRSV, n_a);
2959 sv_setpv(ERRSV, "Compilation error");
2964 CopLINE_set(&PL_compiling, 0);
2966 *startop = PL_eval_root;
2968 SAVEFREEOP(PL_eval_root);
2970 /* Set the context for this new optree.
2971 * If the last op is an OP_REQUIRE, force scalar context.
2972 * Otherwise, propagate the context from the eval(). */
2973 if (PL_eval_root->op_type == OP_LEAVEEVAL
2974 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2975 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2977 scalar(PL_eval_root);
2978 else if (gimme & G_VOID)
2979 scalarvoid(PL_eval_root);
2980 else if (gimme & G_ARRAY)
2983 scalar(PL_eval_root);
2985 DEBUG_x(dump_eval());
2987 /* Register with debugger: */
2988 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2989 CV *cv = get_cv("DB::postponed", FALSE);
2993 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2995 call_sv((SV*)cv, G_DISCARD);
2999 /* compiled okay, so do it */
3001 CvDEPTH(PL_compcv) = 1;
3002 SP = PL_stack_base + POPMARK; /* pop original mark */
3003 PL_op = saveop; /* The caller may need it. */
3004 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3006 RETURNOP(PL_eval_start);
3010 S_doopen_pm(pTHX_ const char *name, const char *mode)
3012 #ifndef PERL_DISABLE_PMC
3013 STRLEN namelen = strlen(name);
3016 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3017 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3018 char *pmc = SvPV_nolen(pmcsv);
3021 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3022 fp = PerlIO_open(name, mode);
3025 if (PerlLIO_stat(name, &pmstat) < 0 ||
3026 pmstat.st_mtime < pmcstat.st_mtime)
3028 fp = PerlIO_open(pmc, mode);
3031 fp = PerlIO_open(name, mode);
3034 SvREFCNT_dec(pmcsv);
3037 fp = PerlIO_open(name, mode);
3041 return PerlIO_open(name, mode);
3042 #endif /* !PERL_DISABLE_PMC */
3048 register PERL_CONTEXT *cx;
3052 char *tryname = Nullch;
3053 SV *namesv = Nullsv;
3055 I32 gimme = GIMME_V;
3056 PerlIO *tryrsfp = 0;
3058 int filter_has_file = 0;
3059 GV *filter_child_proc = 0;
3060 SV *filter_state = 0;
3067 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3068 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3069 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3070 "v-string in use/require non-portable");
3072 sv = new_version(sv);
3073 if (!sv_derived_from(PL_patchlevel, "version"))
3074 (void *)upg_version(PL_patchlevel);
3075 if ( vcmp(sv,PL_patchlevel) > 0 )
3076 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3077 vstringify(sv), vstringify(PL_patchlevel));
3081 name = SvPV(sv, len);
3082 if (!(name && len > 0 && *name))
3083 DIE(aTHX_ "Null filename used");
3084 TAINT_PROPER("require");
3085 if (PL_op->op_type == OP_REQUIRE &&
3086 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3087 if (*svp != &PL_sv_undef)
3090 DIE(aTHX_ "Compilation failed in require");
3093 /* prepare to compile file */
3095 if (path_is_absolute(name)) {
3097 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3099 #ifdef MACOS_TRADITIONAL
3103 MacPerl_CanonDir(name, newname, 1);
3104 if (path_is_absolute(newname)) {
3106 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3111 AV *ar = GvAVn(PL_incgv);
3115 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3118 namesv = NEWSV(806, 0);
3119 for (i = 0; i <= AvFILL(ar); i++) {
3120 SV *dirsv = *av_fetch(ar, i, TRUE);
3126 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3127 && !sv_isobject(loader))
3129 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3132 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3133 PTR2UV(SvRV(dirsv)), name);
3134 tryname = SvPVX(namesv);
3145 if (sv_isobject(loader))
3146 count = call_method("INC", G_ARRAY);
3148 count = call_sv(loader, G_ARRAY);
3158 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3162 if (SvTYPE(arg) == SVt_PVGV) {
3163 IO *io = GvIO((GV *)arg);
3168 tryrsfp = IoIFP(io);
3169 if (IoTYPE(io) == IoTYPE_PIPE) {
3170 /* reading from a child process doesn't
3171 nest -- when returning from reading
3172 the inner module, the outer one is
3173 unreadable (closed?) I've tried to
3174 save the gv to manage the lifespan of
3175 the pipe, but this didn't help. XXX */
3176 filter_child_proc = (GV *)arg;
3177 (void)SvREFCNT_inc(filter_child_proc);
3180 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3181 PerlIO_close(IoOFP(io));
3193 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3195 (void)SvREFCNT_inc(filter_sub);
3198 filter_state = SP[i];
3199 (void)SvREFCNT_inc(filter_state);
3203 tryrsfp = PerlIO_open("/dev/null",
3219 filter_has_file = 0;
3220 if (filter_child_proc) {
3221 SvREFCNT_dec(filter_child_proc);
3222 filter_child_proc = 0;
3225 SvREFCNT_dec(filter_state);
3229 SvREFCNT_dec(filter_sub);
3234 if (!path_is_absolute(name)
3235 #ifdef MACOS_TRADITIONAL
3236 /* We consider paths of the form :a:b ambiguous and interpret them first
3237 as global then as local
3239 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3242 char *dir = SvPVx(dirsv, n_a);
3243 #ifdef MACOS_TRADITIONAL
3247 MacPerl_CanonDir(name, buf2, 1);
3248 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3252 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3254 sv_setpv(namesv, unixdir);
3255 sv_catpv(namesv, unixname);
3257 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3260 TAINT_PROPER("require");
3261 tryname = SvPVX(namesv);
3262 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3264 if (tryname[0] == '.' && tryname[1] == '/')
3273 SAVECOPFILE_FREE(&PL_compiling);
3274 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3275 SvREFCNT_dec(namesv);
3277 if (PL_op->op_type == OP_REQUIRE) {
3278 char *msgstr = name;
3279 if (namesv) { /* did we lookup @INC? */
3280 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3281 SV *dirmsgsv = NEWSV(0, 0);
3282 AV *ar = GvAVn(PL_incgv);
3284 sv_catpvn(msg, " in @INC", 8);
3285 if (instr(SvPVX(msg), ".h "))
3286 sv_catpv(msg, " (change .h to .ph maybe?)");
3287 if (instr(SvPVX(msg), ".ph "))
3288 sv_catpv(msg, " (did you run h2ph?)");
3289 sv_catpv(msg, " (@INC contains:");
3290 for (i = 0; i <= AvFILL(ar); i++) {
3291 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3292 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3293 sv_catsv(msg, dirmsgsv);
3295 sv_catpvn(msg, ")", 1);
3296 SvREFCNT_dec(dirmsgsv);
3297 msgstr = SvPV_nolen(msg);
3299 DIE(aTHX_ "Can't locate %s", msgstr);
3305 SETERRNO(0, SS_NORMAL);
3307 /* Assume success here to prevent recursive requirement. */
3309 /* Check whether a hook in @INC has already filled %INC */
3310 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3311 (void)hv_store(GvHVn(PL_incgv), name, len,
3312 (hook_sv ? SvREFCNT_inc(hook_sv)
3313 : newSVpv(CopFILE(&PL_compiling), 0)),
3319 lex_start(sv_2mortal(newSVpvn("",0)));
3320 SAVEGENERICSV(PL_rsfp_filters);
3321 PL_rsfp_filters = Nullav;
3326 SAVESPTR(PL_compiling.cop_warnings);
3327 if (PL_dowarn & G_WARN_ALL_ON)
3328 PL_compiling.cop_warnings = pWARN_ALL ;
3329 else if (PL_dowarn & G_WARN_ALL_OFF)
3330 PL_compiling.cop_warnings = pWARN_NONE ;
3331 else if (PL_taint_warn)
3332 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3334 PL_compiling.cop_warnings = pWARN_STD ;
3335 SAVESPTR(PL_compiling.cop_io);
3336 PL_compiling.cop_io = Nullsv;
3338 if (filter_sub || filter_child_proc) {
3339 SV *datasv = filter_add(run_user_filter, Nullsv);
3340 IoLINES(datasv) = filter_has_file;
3341 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3342 IoTOP_GV(datasv) = (GV *)filter_state;
3343 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3346 /* switch to eval mode */
3347 PUSHBLOCK(cx, CXt_EVAL, SP);
3348 PUSHEVAL(cx, name, Nullgv);
3349 cx->blk_eval.retop = PL_op->op_next;
3351 SAVECOPLINE(&PL_compiling);
3352 CopLINE_set(&PL_compiling, 0);
3356 /* Store and reset encoding. */
3357 encoding = PL_encoding;
3358 PL_encoding = Nullsv;
3360 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3362 /* Restore encoding. */
3363 PL_encoding = encoding;
3370 return pp_require();
3376 register PERL_CONTEXT *cx;
3378 I32 gimme = GIMME_V, was = PL_sub_generation;
3379 char tbuf[TYPE_DIGITS(long) + 12];
3380 char *tmpbuf = tbuf;
3389 TAINT_PROPER("eval");
3395 /* switch to eval mode */
3397 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3398 SV *sv = sv_newmortal();
3399 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3400 (unsigned long)++PL_evalseq,
3401 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3405 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3406 SAVECOPFILE_FREE(&PL_compiling);
3407 CopFILE_set(&PL_compiling, tmpbuf+2);
3408 SAVECOPLINE(&PL_compiling);
3409 CopLINE_set(&PL_compiling, 1);
3410 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3411 deleting the eval's FILEGV from the stash before gv_check() runs
3412 (i.e. before run-time proper). To work around the coredump that
3413 ensues, we always turn GvMULTI_on for any globals that were
3414 introduced within evals. See force_ident(). GSAR 96-10-12 */
3415 safestr = savepv(tmpbuf);
3416 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3418 PL_hints = PL_op->op_targ;
3419 SAVESPTR(PL_compiling.cop_warnings);
3420 if (specialWARN(PL_curcop->cop_warnings))
3421 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3423 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3424 SAVEFREESV(PL_compiling.cop_warnings);
3426 SAVESPTR(PL_compiling.cop_io);
3427 if (specialCopIO(PL_curcop->cop_io))
3428 PL_compiling.cop_io = PL_curcop->cop_io;
3430 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3431 SAVEFREESV(PL_compiling.cop_io);
3433 /* special case: an eval '' executed within the DB package gets lexically
3434 * placed in the first non-DB CV rather than the current CV - this
3435 * allows the debugger to execute code, find lexicals etc, in the
3436 * scope of the code being debugged. Passing &seq gets find_runcv
3437 * to do the dirty work for us */
3438 runcv = find_runcv(&seq);
3440 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3441 PUSHEVAL(cx, 0, Nullgv);
3442 cx->blk_eval.retop = PL_op->op_next;
3444 /* prepare to compile string */
3446 if (PERLDB_LINE && PL_curstash != PL_debstash)
3447 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3449 ret = doeval(gimme, NULL, runcv, seq);
3450 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3451 && ret != PL_op->op_next) { /* Successive compilation. */
3452 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3454 return DOCATCH(ret);
3464 register PERL_CONTEXT *cx;
3466 U8 save_flags = PL_op -> op_flags;
3471 retop = cx->blk_eval.retop;
3474 if (gimme == G_VOID)
3476 else if (gimme == G_SCALAR) {
3479 if (SvFLAGS(TOPs) & SVs_TEMP)
3482 *MARK = sv_mortalcopy(TOPs);
3486 *MARK = &PL_sv_undef;
3491 /* in case LEAVE wipes old return values */
3492 for (mark = newsp + 1; mark <= SP; mark++) {
3493 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3494 *mark = sv_mortalcopy(*mark);
3495 TAINT_NOT; /* Each item is independent */
3499 PL_curpm = newpm; /* Don't pop $1 et al till now */
3502 assert(CvDEPTH(PL_compcv) == 1);
3504 CvDEPTH(PL_compcv) = 0;
3507 if (optype == OP_REQUIRE &&
3508 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3510 /* Unassume the success we assumed earlier. */
3511 SV *nsv = cx->blk_eval.old_namesv;
3512 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3513 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3514 /* die_where() did LEAVE, or we won't be here */
3518 if (!(save_flags & OPf_SPECIAL))
3528 register PERL_CONTEXT *cx;
3529 I32 gimme = GIMME_V;
3534 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3536 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3538 PL_in_eval = EVAL_INEVAL;
3541 return DOCATCH(PL_op->op_next);
3552 register PERL_CONTEXT *cx;
3557 retop = cx->blk_eval.retop;
3560 if (gimme == G_VOID)
3562 else if (gimme == G_SCALAR) {
3565 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3568 *MARK = sv_mortalcopy(TOPs);
3572 *MARK = &PL_sv_undef;
3577 /* in case LEAVE wipes old return values */
3578 for (mark = newsp + 1; mark <= SP; mark++) {
3579 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3580 *mark = sv_mortalcopy(*mark);
3581 TAINT_NOT; /* Each item is independent */
3585 PL_curpm = newpm; /* Don't pop $1 et al till now */
3593 S_doparseform(pTHX_ SV *sv)
3596 register char *s = SvPV_force(sv, len);
3597 register char *send = s + len;
3598 register char *base = Nullch;
3599 register I32 skipspaces = 0;
3600 bool noblank = FALSE;
3601 bool repeat = FALSE;
3602 bool postspace = FALSE;
3608 bool unchopnum = FALSE;
3609 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3612 Perl_croak(aTHX_ "Null picture in formline");
3614 /* estimate the buffer size needed */
3615 for (base = s; s <= send; s++) {
3616 if (*s == '\n' || *s == '@' || *s == '^')
3622 New(804, fops, maxops, U32);
3627 *fpc++ = FF_LINEMARK;
3628 noblank = repeat = FALSE;
3646 case ' ': case '\t':
3653 } /* else FALL THROUGH */
3661 *fpc++ = FF_LITERAL;
3669 *fpc++ = (U16)skipspaces;
3673 *fpc++ = FF_NEWLINE;
3677 arg = fpc - linepc + 1;
3684 *fpc++ = FF_LINEMARK;
3685 noblank = repeat = FALSE;
3694 ischop = s[-1] == '^';
3700 arg = (s - base) - 1;
3702 *fpc++ = FF_LITERAL;
3710 *fpc++ = 2; /* skip the @* or ^* */
3712 *fpc++ = FF_LINESNGL;
3715 *fpc++ = FF_LINEGLOB;
3717 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3718 arg = ischop ? 512 : 0;
3728 arg |= 256 + (s - f);
3730 *fpc++ = s - base; /* fieldsize for FETCH */
3731 *fpc++ = FF_DECIMAL;
3733 unchopnum |= ! ischop;
3735 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3736 arg = ischop ? 512 : 0;
3738 s++; /* skip the '0' first */
3747 arg |= 256 + (s - f);
3749 *fpc++ = s - base; /* fieldsize for FETCH */
3750 *fpc++ = FF_0DECIMAL;
3752 unchopnum |= ! ischop;
3756 bool ismore = FALSE;
3759 while (*++s == '>') ;
3760 prespace = FF_SPACE;
3762 else if (*s == '|') {
3763 while (*++s == '|') ;
3764 prespace = FF_HALFSPACE;
3769 while (*++s == '<') ;
3772 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3776 *fpc++ = s - base; /* fieldsize for FETCH */
3778 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3781 *fpc++ = (U16)prespace;
3795 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3797 { /* need to jump to the next word */
3799 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3800 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3801 s = SvPVX(sv) + SvCUR(sv) + z;
3803 Copy(fops, s, arg, U32);
3805 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3808 if (unchopnum && repeat)
3809 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3815 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3817 /* Can value be printed in fldsize chars, using %*.*f ? */
3821 int intsize = fldsize - (value < 0 ? 1 : 0);
3828 while (intsize--) pwr *= 10.0;
3829 while (frcsize--) eps /= 10.0;
3832 if (value + eps >= pwr)
3835 if (value - eps <= -pwr)
3842 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3844 SV *datasv = FILTER_DATA(idx);
3845 int filter_has_file = IoLINES(datasv);
3846 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3847 SV *filter_state = (SV *)IoTOP_GV(datasv);
3848 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3851 /* I was having segfault trouble under Linux 2.2.5 after a
3852 parse error occured. (Had to hack around it with a test
3853 for PL_error_count == 0.) Solaris doesn't segfault --
3854 not sure where the trouble is yet. XXX */
3856 if (filter_has_file) {
3857 len = FILTER_READ(idx+1, buf_sv, maxlen);
3860 if (filter_sub && len >= 0) {
3871 PUSHs(sv_2mortal(newSViv(maxlen)));
3873 PUSHs(filter_state);
3876 count = call_sv(filter_sub, G_SCALAR);
3892 IoLINES(datasv) = 0;
3893 if (filter_child_proc) {
3894 SvREFCNT_dec(filter_child_proc);
3895 IoFMT_GV(datasv) = Nullgv;
3898 SvREFCNT_dec(filter_state);
3899 IoTOP_GV(datasv) = Nullgv;
3902 SvREFCNT_dec(filter_sub);
3903 IoBOTTOM_GV(datasv) = Nullgv;
3905 filter_del(run_user_filter);
3911 /* perhaps someone can come up with a better name for
3912 this? it is not really "absolute", per se ... */
3914 S_path_is_absolute(pTHX_ char *name)
3916 if (PERL_FILE_IS_ABSOLUTE(name)
3917 #ifdef MACOS_TRADITIONAL
3920 || (*name == '.' && (name[1] == '/' ||
3921 (name[1] == '.' && name[2] == '/'))))
3932 * c-indentation-style: bsd
3934 * indent-tabs-mode: t
3937 * vim: shiftwidth=4: