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;
442 const char *name = "???";
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 const 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_ const char *message, STRLEN msglen)
1405 if (PL_in_eval & EVAL_KEEPERR) {
1406 static const char prefix[] = "\t(in cleanup) ";
1411 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1414 if (*e != *message || strNE(e,message))
1418 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1419 sv_catpvn(err, prefix, sizeof(prefix)-1);
1420 sv_catpvn(err, message, msglen);
1421 if (ckWARN(WARN_MISC)) {
1422 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1423 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1428 sv_setpvn(ERRSV, message, msglen);
1432 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1433 && PL_curstackinfo->si_prev)
1441 register PERL_CONTEXT *cx;
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 const 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, const char *label, OP **opstack, OP **oplimit)
2192 static const 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];
2248 const char *label = 0;
2249 const bool do_dump = (PL_op->op_type == OP_DUMP);
2250 static const char must_have_label[] = "goto must have label";
2252 if (PL_op->op_flags & OPf_STACKED) {
2256 /* This egregious kludge implements goto &subroutine */
2257 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2259 register PERL_CONTEXT *cx;
2260 CV* cv = (CV*)SvRV(sv);
2267 if (!CvROOT(cv) && !CvXSUB(cv)) {
2268 const GV * const gv = CvGV(cv);
2272 /* autoloaded stub? */
2273 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2275 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2276 GvNAMELEN(gv), FALSE);
2277 if (autogv && (cv = GvCV(autogv)))
2279 tmpstr = sv_newmortal();
2280 gv_efullname3(tmpstr, gv, Nullch);
2281 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2283 DIE(aTHX_ "Goto undefined subroutine");
2286 /* First do some returnish stuff. */
2287 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2289 cxix = dopoptosub(cxstack_ix);
2291 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2292 if (cxix < cxstack_ix)
2296 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2297 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2298 /* put @_ back onto stack */
2299 AV* av = cx->blk_sub.argarray;
2301 items = AvFILLp(av) + 1;
2302 EXTEND(SP, items+1); /* @_ could have been extended. */
2303 Copy(AvARRAY(av), SP + 1, items, SV*);
2304 SvREFCNT_dec(GvAV(PL_defgv));
2305 GvAV(PL_defgv) = cx->blk_sub.savearray;
2307 /* abandon @_ if it got reified */
2312 av_extend(av, items-1);
2313 AvFLAGS(av) = AVf_REIFY;
2314 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2317 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2319 av = GvAV(PL_defgv);
2320 items = AvFILLp(av) + 1;
2321 EXTEND(SP, items+1); /* @_ could have been extended. */
2322 Copy(AvARRAY(av), SP + 1, items, SV*);
2326 if (CxTYPE(cx) == CXt_SUB &&
2327 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2328 SvREFCNT_dec(cx->blk_sub.cv);
2329 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2330 LEAVE_SCOPE(oldsave);
2332 /* Now do some callish stuff. */
2334 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2338 for (index=0; index<items; index++)
2339 sv_2mortal(SP[-index]);
2341 #ifdef PERL_XSUB_OLDSTYLE
2342 if (CvOLDSTYLE(cv)) {
2343 I32 (*fp3)(int,int,int);
2348 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2349 items = (*fp3)(CvXSUBANY(cv).any_i32,
2350 mark - PL_stack_base + 1,
2352 SP = PL_stack_base + items;
2355 #endif /* PERL_XSUB_OLDSTYLE */
2360 /* Push a mark for the start of arglist */
2363 (void)(*CvXSUB(cv))(aTHX_ cv);
2364 /* Pop the current context like a decent sub should */
2365 POPBLOCK(cx, PL_curpm);
2366 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2369 assert(CxTYPE(cx) == CXt_SUB);
2370 return cx->blk_sub.retop;
2373 AV* padlist = CvPADLIST(cv);
2374 if (CxTYPE(cx) == CXt_EVAL) {
2375 PL_in_eval = cx->blk_eval.old_in_eval;
2376 PL_eval_root = cx->blk_eval.old_eval_root;
2377 cx->cx_type = CXt_SUB;
2378 cx->blk_sub.hasargs = 0;
2380 cx->blk_sub.cv = cv;
2381 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2384 if (CvDEPTH(cv) < 2)
2385 (void)SvREFCNT_inc(cv);
2387 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2388 sub_crush_depth(cv);
2389 pad_push(padlist, CvDEPTH(cv));
2391 PAD_SET_CUR(padlist, CvDEPTH(cv));
2392 if (cx->blk_sub.hasargs)
2394 AV* av = (AV*)PAD_SVl(0);
2397 cx->blk_sub.savearray = GvAV(PL_defgv);
2398 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2399 CX_CURPAD_SAVE(cx->blk_sub);
2400 cx->blk_sub.argarray = av;
2402 if (items >= AvMAX(av) + 1) {
2404 if (AvARRAY(av) != ary) {
2405 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2406 SvPVX(av) = (char*)ary;
2408 if (items >= AvMAX(av) + 1) {
2409 AvMAX(av) = items - 1;
2410 Renew(ary,items+1,SV*);
2412 SvPVX(av) = (char*)ary;
2416 Copy(mark,AvARRAY(av),items,SV*);
2417 AvFILLp(av) = items - 1;
2418 assert(!AvREAL(av));
2420 /* transfer 'ownership' of refcnts to new @_ */
2430 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2432 * We do not care about using sv to call CV;
2433 * it's for informational purposes only.
2435 SV *sv = GvSV(PL_DBsub);
2438 if (PERLDB_SUB_NN) {
2439 (void)SvUPGRADE(sv, SVt_PVIV);
2442 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2445 gv_efullname3(sv, CvGV(cv), Nullch);
2448 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2449 PUSHMARK( PL_stack_sp );
2450 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2454 RETURNOP(CvSTART(cv));
2458 label = SvPV(sv,n_a);
2459 if (!(do_dump || *label))
2460 DIE(aTHX_ must_have_label);
2463 else if (PL_op->op_flags & OPf_SPECIAL) {
2465 DIE(aTHX_ must_have_label);
2468 label = cPVOP->op_pv;
2470 if (label && *label) {
2472 bool leaving_eval = FALSE;
2473 bool in_block = FALSE;
2474 PERL_CONTEXT *last_eval_cx = 0;
2478 PL_lastgotoprobe = 0;
2480 for (ix = cxstack_ix; ix >= 0; ix--) {
2482 switch (CxTYPE(cx)) {
2484 leaving_eval = TRUE;
2485 if (!CxTRYBLOCK(cx)) {
2486 gotoprobe = (last_eval_cx ?
2487 last_eval_cx->blk_eval.old_eval_root :
2492 /* else fall through */
2494 gotoprobe = cx->blk_oldcop->op_sibling;
2500 gotoprobe = cx->blk_oldcop->op_sibling;
2503 gotoprobe = PL_main_root;
2506 if (CvDEPTH(cx->blk_sub.cv)) {
2507 gotoprobe = CvROOT(cx->blk_sub.cv);
2513 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2516 DIE(aTHX_ "panic: goto");
2517 gotoprobe = PL_main_root;
2521 retop = dofindlabel(gotoprobe, label,
2522 enterops, enterops + GOTO_DEPTH);
2526 PL_lastgotoprobe = gotoprobe;
2529 DIE(aTHX_ "Can't find label %s", label);
2531 /* if we're leaving an eval, check before we pop any frames
2532 that we're not going to punt, otherwise the error
2535 if (leaving_eval && *enterops && enterops[1]) {
2537 for (i = 1; enterops[i]; i++)
2538 if (enterops[i]->op_type == OP_ENTERITER)
2539 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2542 /* pop unwanted frames */
2544 if (ix < cxstack_ix) {
2551 oldsave = PL_scopestack[PL_scopestack_ix];
2552 LEAVE_SCOPE(oldsave);
2555 /* push wanted frames */
2557 if (*enterops && enterops[1]) {
2559 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2560 for (; enterops[ix]; ix++) {
2561 PL_op = enterops[ix];
2562 /* Eventually we may want to stack the needed arguments
2563 * for each op. For now, we punt on the hard ones. */
2564 if (PL_op->op_type == OP_ENTERITER)
2565 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2566 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2574 if (!retop) retop = PL_main_start;
2576 PL_restartop = retop;
2577 PL_do_undump = TRUE;
2581 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2582 PL_do_undump = FALSE;
2598 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2600 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2603 PL_exit_flags |= PERL_EXIT_EXPECTED;
2605 PUSHs(&PL_sv_undef);
2613 NV value = SvNVx(GvSV(cCOP->cop_gv));
2614 register I32 match = I_32(value);
2617 if (((NV)match) > value)
2618 --match; /* was fractional--truncate other way */
2620 match -= cCOP->uop.scop.scop_offset;
2623 else if (match > cCOP->uop.scop.scop_max)
2624 match = cCOP->uop.scop.scop_max;
2625 PL_op = cCOP->uop.scop.scop_next[match];
2635 PL_op = PL_op->op_next; /* can't assume anything */
2638 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2639 match -= cCOP->uop.scop.scop_offset;
2642 else if (match > cCOP->uop.scop.scop_max)
2643 match = cCOP->uop.scop.scop_max;
2644 PL_op = cCOP->uop.scop.scop_next[match];
2653 S_save_lines(pTHX_ AV *array, SV *sv)
2655 register char *s = SvPVX(sv);
2656 register char *send = SvPVX(sv) + SvCUR(sv);
2658 register I32 line = 1;
2660 while (s && s < send) {
2661 SV *tmpstr = NEWSV(85,0);
2663 sv_upgrade(tmpstr, SVt_PVMG);
2664 t = strchr(s, '\n');
2670 sv_setpvn(tmpstr, s, t - s);
2671 av_store(array, line++, tmpstr);
2677 S_docatch_body(pTHX)
2684 S_docatch(pTHX_ OP *o)
2689 volatile PERL_SI *cursi = PL_curstackinfo;
2693 assert(CATCH_GET == TRUE);
2697 /* Normally, the leavetry at the end of this block of ops will
2698 * pop an op off the return stack and continue there. By setting
2699 * the op to Nullop, we force an exit from the inner runops()
2702 assert(cxstack_ix >= 0);
2703 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2704 retop = cxstack[cxstack_ix].blk_eval.retop;
2705 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2714 /* die caught by an inner eval - continue inner loop */
2715 if (PL_restartop && cursi == PL_curstackinfo) {
2716 PL_op = PL_restartop;
2720 /* a die in this eval - continue in outer loop */
2736 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2737 /* sv Text to convert to OP tree. */
2738 /* startop op_free() this to undo. */
2739 /* code Short string id of the caller. */
2741 dSP; /* Make POPBLOCK work. */
2744 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2748 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2749 char *tmpbuf = tbuf;
2752 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2757 /* switch to eval mode */
2759 if (IN_PERL_COMPILETIME) {
2760 SAVECOPSTASH_FREE(&PL_compiling);
2761 CopSTASH_set(&PL_compiling, PL_curstash);
2763 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2764 SV *sv = sv_newmortal();
2765 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2766 code, (unsigned long)++PL_evalseq,
2767 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2771 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2772 SAVECOPFILE_FREE(&PL_compiling);
2773 CopFILE_set(&PL_compiling, tmpbuf+2);
2774 SAVECOPLINE(&PL_compiling);
2775 CopLINE_set(&PL_compiling, 1);
2776 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2777 deleting the eval's FILEGV from the stash before gv_check() runs
2778 (i.e. before run-time proper). To work around the coredump that
2779 ensues, we always turn GvMULTI_on for any globals that were
2780 introduced within evals. See force_ident(). GSAR 96-10-12 */
2781 safestr = savepv(tmpbuf);
2782 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2784 #ifdef OP_IN_REGISTER
2790 /* we get here either during compilation, or via pp_regcomp at runtime */
2791 runtime = IN_PERL_RUNTIME;
2793 runcv = find_runcv(NULL);
2796 PL_op->op_type = OP_ENTEREVAL;
2797 PL_op->op_flags = 0; /* Avoid uninit warning. */
2798 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2799 PUSHEVAL(cx, 0, Nullgv);
2802 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2804 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2805 POPBLOCK(cx,PL_curpm);
2808 (*startop)->op_type = OP_NULL;
2809 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2811 /* XXX DAPM do this properly one year */
2812 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2814 if (IN_PERL_COMPILETIME)
2815 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2816 #ifdef OP_IN_REGISTER
2824 =for apidoc find_runcv
2826 Locate the CV corresponding to the currently executing sub or eval.
2827 If db_seqp is non_null, skip CVs that are in the DB package and populate
2828 *db_seqp with the cop sequence number at the point that the DB:: code was
2829 entered. (allows debuggers to eval in the scope of the breakpoint rather
2830 than in in the scope of the debugger itself).
2836 Perl_find_runcv(pTHX_ U32 *db_seqp)
2843 *db_seqp = PL_curcop->cop_seq;
2844 for (si = PL_curstackinfo; si; si = si->si_prev) {
2845 for (ix = si->si_cxix; ix >= 0; ix--) {
2846 cx = &(si->si_cxstack[ix]);
2847 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2848 CV *cv = cx->blk_sub.cv;
2849 /* skip DB:: code */
2850 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2851 *db_seqp = cx->blk_oldcop->cop_seq;
2856 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2864 /* Compile a require/do, an eval '', or a /(?{...})/.
2865 * In the last case, startop is non-null, and contains the address of
2866 * a pointer that should be set to the just-compiled code.
2867 * outside is the lexically enclosing CV (if any) that invoked us.
2870 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2872 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2877 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2878 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2883 SAVESPTR(PL_compcv);
2884 PL_compcv = (CV*)NEWSV(1104,0);
2885 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2886 CvEVAL_on(PL_compcv);
2887 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2888 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2890 CvOUTSIDE_SEQ(PL_compcv) = seq;
2891 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2893 /* set up a scratch pad */
2895 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2898 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2900 /* make sure we compile in the right package */
2902 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2903 SAVESPTR(PL_curstash);
2904 PL_curstash = CopSTASH(PL_curcop);
2906 SAVESPTR(PL_beginav);
2907 PL_beginav = newAV();
2908 SAVEFREESV(PL_beginav);
2909 SAVEI32(PL_error_count);
2911 /* try to compile it */
2913 PL_eval_root = Nullop;
2915 PL_curcop = &PL_compiling;
2916 PL_curcop->cop_arybase = 0;
2917 if (saveop && saveop->op_flags & OPf_SPECIAL)
2918 PL_in_eval |= EVAL_KEEPERR;
2921 if (yyparse() || PL_error_count || !PL_eval_root) {
2922 SV **newsp; /* Used by POPBLOCK. */
2923 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2924 I32 optype = 0; /* Might be reset by POPEVAL. */
2929 op_free(PL_eval_root);
2930 PL_eval_root = Nullop;
2932 SP = PL_stack_base + POPMARK; /* pop original mark */
2934 POPBLOCK(cx,PL_curpm);
2939 if (optype == OP_REQUIRE) {
2940 char* msg = SvPVx(ERRSV, n_a);
2941 SV *nsv = cx->blk_eval.old_namesv;
2942 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2944 DIE(aTHX_ "%sCompilation failed in require",
2945 *msg ? msg : "Unknown error\n");
2948 char* msg = SvPVx(ERRSV, n_a);
2950 POPBLOCK(cx,PL_curpm);
2952 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2953 (*msg ? msg : "Unknown error\n"));
2956 char* msg = SvPVx(ERRSV, n_a);
2958 sv_setpv(ERRSV, "Compilation error");
2963 CopLINE_set(&PL_compiling, 0);
2965 *startop = PL_eval_root;
2967 SAVEFREEOP(PL_eval_root);
2969 /* Set the context for this new optree.
2970 * If the last op is an OP_REQUIRE, force scalar context.
2971 * Otherwise, propagate the context from the eval(). */
2972 if (PL_eval_root->op_type == OP_LEAVEEVAL
2973 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2974 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2976 scalar(PL_eval_root);
2977 else if (gimme & G_VOID)
2978 scalarvoid(PL_eval_root);
2979 else if (gimme & G_ARRAY)
2982 scalar(PL_eval_root);
2984 DEBUG_x(dump_eval());
2986 /* Register with debugger: */
2987 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2988 CV *cv = get_cv("DB::postponed", FALSE);
2992 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2994 call_sv((SV*)cv, G_DISCARD);
2998 /* compiled okay, so do it */
3000 CvDEPTH(PL_compcv) = 1;
3001 SP = PL_stack_base + POPMARK; /* pop original mark */
3002 PL_op = saveop; /* The caller may need it. */
3003 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3005 RETURNOP(PL_eval_start);
3009 S_doopen_pm(pTHX_ const char *name, const char *mode)
3011 #ifndef PERL_DISABLE_PMC
3012 STRLEN namelen = strlen(name);
3015 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3016 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3017 char *pmc = SvPV_nolen(pmcsv);
3020 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3021 fp = PerlIO_open(name, mode);
3024 if (PerlLIO_stat(name, &pmstat) < 0 ||
3025 pmstat.st_mtime < pmcstat.st_mtime)
3027 fp = PerlIO_open(pmc, mode);
3030 fp = PerlIO_open(name, mode);
3033 SvREFCNT_dec(pmcsv);
3036 fp = PerlIO_open(name, mode);
3040 return PerlIO_open(name, mode);
3041 #endif /* !PERL_DISABLE_PMC */
3047 register PERL_CONTEXT *cx;
3051 char *tryname = Nullch;
3052 SV *namesv = Nullsv;
3054 I32 gimme = GIMME_V;
3055 PerlIO *tryrsfp = 0;
3057 int filter_has_file = 0;
3058 GV *filter_child_proc = 0;
3059 SV *filter_state = 0;
3066 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3067 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3068 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3069 "v-string in use/require non-portable");
3071 sv = new_version(sv);
3072 if (!sv_derived_from(PL_patchlevel, "version"))
3073 (void *)upg_version(PL_patchlevel);
3074 if ( vcmp(sv,PL_patchlevel) > 0 )
3075 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3076 vstringify(sv), vstringify(PL_patchlevel));
3080 name = SvPV(sv, len);
3081 if (!(name && len > 0 && *name))
3082 DIE(aTHX_ "Null filename used");
3083 TAINT_PROPER("require");
3084 if (PL_op->op_type == OP_REQUIRE &&
3085 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3086 if (*svp != &PL_sv_undef)
3089 DIE(aTHX_ "Compilation failed in require");
3092 /* prepare to compile file */
3094 if (path_is_absolute(name)) {
3096 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3098 #ifdef MACOS_TRADITIONAL
3102 MacPerl_CanonDir(name, newname, 1);
3103 if (path_is_absolute(newname)) {
3105 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3110 AV *ar = GvAVn(PL_incgv);
3114 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3117 namesv = NEWSV(806, 0);
3118 for (i = 0; i <= AvFILL(ar); i++) {
3119 SV *dirsv = *av_fetch(ar, i, TRUE);
3125 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3126 && !sv_isobject(loader))
3128 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3131 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3132 PTR2UV(SvRV(dirsv)), name);
3133 tryname = SvPVX(namesv);
3144 if (sv_isobject(loader))
3145 count = call_method("INC", G_ARRAY);
3147 count = call_sv(loader, G_ARRAY);
3157 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3161 if (SvTYPE(arg) == SVt_PVGV) {
3162 IO *io = GvIO((GV *)arg);
3167 tryrsfp = IoIFP(io);
3168 if (IoTYPE(io) == IoTYPE_PIPE) {
3169 /* reading from a child process doesn't
3170 nest -- when returning from reading
3171 the inner module, the outer one is
3172 unreadable (closed?) I've tried to
3173 save the gv to manage the lifespan of
3174 the pipe, but this didn't help. XXX */
3175 filter_child_proc = (GV *)arg;
3176 (void)SvREFCNT_inc(filter_child_proc);
3179 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3180 PerlIO_close(IoOFP(io));
3192 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3194 (void)SvREFCNT_inc(filter_sub);
3197 filter_state = SP[i];
3198 (void)SvREFCNT_inc(filter_state);
3202 tryrsfp = PerlIO_open("/dev/null",
3218 filter_has_file = 0;
3219 if (filter_child_proc) {
3220 SvREFCNT_dec(filter_child_proc);
3221 filter_child_proc = 0;
3224 SvREFCNT_dec(filter_state);
3228 SvREFCNT_dec(filter_sub);
3233 if (!path_is_absolute(name)
3234 #ifdef MACOS_TRADITIONAL
3235 /* We consider paths of the form :a:b ambiguous and interpret them first
3236 as global then as local
3238 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3241 char *dir = SvPVx(dirsv, n_a);
3242 #ifdef MACOS_TRADITIONAL
3246 MacPerl_CanonDir(name, buf2, 1);
3247 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3251 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3253 sv_setpv(namesv, unixdir);
3254 sv_catpv(namesv, unixname);
3256 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3259 TAINT_PROPER("require");
3260 tryname = SvPVX(namesv);
3261 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3263 if (tryname[0] == '.' && tryname[1] == '/')
3272 SAVECOPFILE_FREE(&PL_compiling);
3273 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3274 SvREFCNT_dec(namesv);
3276 if (PL_op->op_type == OP_REQUIRE) {
3277 char *msgstr = name;
3278 if (namesv) { /* did we lookup @INC? */
3279 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3280 SV *dirmsgsv = NEWSV(0, 0);
3281 AV *ar = GvAVn(PL_incgv);
3283 sv_catpvn(msg, " in @INC", 8);
3284 if (instr(SvPVX(msg), ".h "))
3285 sv_catpv(msg, " (change .h to .ph maybe?)");
3286 if (instr(SvPVX(msg), ".ph "))
3287 sv_catpv(msg, " (did you run h2ph?)");
3288 sv_catpv(msg, " (@INC contains:");
3289 for (i = 0; i <= AvFILL(ar); i++) {
3290 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3291 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3292 sv_catsv(msg, dirmsgsv);
3294 sv_catpvn(msg, ")", 1);
3295 SvREFCNT_dec(dirmsgsv);
3296 msgstr = SvPV_nolen(msg);
3298 DIE(aTHX_ "Can't locate %s", msgstr);
3304 SETERRNO(0, SS_NORMAL);
3306 /* Assume success here to prevent recursive requirement. */
3308 /* Check whether a hook in @INC has already filled %INC */
3309 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3310 (void)hv_store(GvHVn(PL_incgv), name, len,
3311 (hook_sv ? SvREFCNT_inc(hook_sv)
3312 : newSVpv(CopFILE(&PL_compiling), 0)),
3318 lex_start(sv_2mortal(newSVpvn("",0)));
3319 SAVEGENERICSV(PL_rsfp_filters);
3320 PL_rsfp_filters = Nullav;
3325 SAVESPTR(PL_compiling.cop_warnings);
3326 if (PL_dowarn & G_WARN_ALL_ON)
3327 PL_compiling.cop_warnings = pWARN_ALL ;
3328 else if (PL_dowarn & G_WARN_ALL_OFF)
3329 PL_compiling.cop_warnings = pWARN_NONE ;
3330 else if (PL_taint_warn)
3331 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3333 PL_compiling.cop_warnings = pWARN_STD ;
3334 SAVESPTR(PL_compiling.cop_io);
3335 PL_compiling.cop_io = Nullsv;
3337 if (filter_sub || filter_child_proc) {
3338 SV *datasv = filter_add(run_user_filter, Nullsv);
3339 IoLINES(datasv) = filter_has_file;
3340 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3341 IoTOP_GV(datasv) = (GV *)filter_state;
3342 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3345 /* switch to eval mode */
3346 PUSHBLOCK(cx, CXt_EVAL, SP);
3347 PUSHEVAL(cx, name, Nullgv);
3348 cx->blk_eval.retop = PL_op->op_next;
3350 SAVECOPLINE(&PL_compiling);
3351 CopLINE_set(&PL_compiling, 0);
3355 /* Store and reset encoding. */
3356 encoding = PL_encoding;
3357 PL_encoding = Nullsv;
3359 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3361 /* Restore encoding. */
3362 PL_encoding = encoding;
3369 return pp_require();
3375 register PERL_CONTEXT *cx;
3377 I32 gimme = GIMME_V, was = PL_sub_generation;
3378 char tbuf[TYPE_DIGITS(long) + 12];
3379 char *tmpbuf = tbuf;
3388 TAINT_PROPER("eval");
3394 /* switch to eval mode */
3396 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3397 SV *sv = sv_newmortal();
3398 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3399 (unsigned long)++PL_evalseq,
3400 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3404 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3405 SAVECOPFILE_FREE(&PL_compiling);
3406 CopFILE_set(&PL_compiling, tmpbuf+2);
3407 SAVECOPLINE(&PL_compiling);
3408 CopLINE_set(&PL_compiling, 1);
3409 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3410 deleting the eval's FILEGV from the stash before gv_check() runs
3411 (i.e. before run-time proper). To work around the coredump that
3412 ensues, we always turn GvMULTI_on for any globals that were
3413 introduced within evals. See force_ident(). GSAR 96-10-12 */
3414 safestr = savepv(tmpbuf);
3415 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3417 PL_hints = PL_op->op_targ;
3418 SAVESPTR(PL_compiling.cop_warnings);
3419 if (specialWARN(PL_curcop->cop_warnings))
3420 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3422 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3423 SAVEFREESV(PL_compiling.cop_warnings);
3425 SAVESPTR(PL_compiling.cop_io);
3426 if (specialCopIO(PL_curcop->cop_io))
3427 PL_compiling.cop_io = PL_curcop->cop_io;
3429 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3430 SAVEFREESV(PL_compiling.cop_io);
3432 /* special case: an eval '' executed within the DB package gets lexically
3433 * placed in the first non-DB CV rather than the current CV - this
3434 * allows the debugger to execute code, find lexicals etc, in the
3435 * scope of the code being debugged. Passing &seq gets find_runcv
3436 * to do the dirty work for us */
3437 runcv = find_runcv(&seq);
3439 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3440 PUSHEVAL(cx, 0, Nullgv);
3441 cx->blk_eval.retop = PL_op->op_next;
3443 /* prepare to compile string */
3445 if (PERLDB_LINE && PL_curstash != PL_debstash)
3446 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3448 ret = doeval(gimme, NULL, runcv, seq);
3449 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3450 && ret != PL_op->op_next) { /* Successive compilation. */
3451 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3453 return DOCATCH(ret);
3463 register PERL_CONTEXT *cx;
3465 U8 save_flags = PL_op -> op_flags;
3470 retop = cx->blk_eval.retop;
3473 if (gimme == G_VOID)
3475 else if (gimme == G_SCALAR) {
3478 if (SvFLAGS(TOPs) & SVs_TEMP)
3481 *MARK = sv_mortalcopy(TOPs);
3485 *MARK = &PL_sv_undef;
3490 /* in case LEAVE wipes old return values */
3491 for (mark = newsp + 1; mark <= SP; mark++) {
3492 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3493 *mark = sv_mortalcopy(*mark);
3494 TAINT_NOT; /* Each item is independent */
3498 PL_curpm = newpm; /* Don't pop $1 et al till now */
3501 assert(CvDEPTH(PL_compcv) == 1);
3503 CvDEPTH(PL_compcv) = 0;
3506 if (optype == OP_REQUIRE &&
3507 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3509 /* Unassume the success we assumed earlier. */
3510 SV *nsv = cx->blk_eval.old_namesv;
3511 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3512 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3513 /* die_where() did LEAVE, or we won't be here */
3517 if (!(save_flags & OPf_SPECIAL))
3527 register PERL_CONTEXT *cx;
3528 I32 gimme = GIMME_V;
3533 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3535 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3537 PL_in_eval = EVAL_INEVAL;
3540 return DOCATCH(PL_op->op_next);
3551 register PERL_CONTEXT *cx;
3556 retop = cx->blk_eval.retop;
3559 if (gimme == G_VOID)
3561 else if (gimme == G_SCALAR) {
3564 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3567 *MARK = sv_mortalcopy(TOPs);
3571 *MARK = &PL_sv_undef;
3576 /* in case LEAVE wipes old return values */
3577 for (mark = newsp + 1; mark <= SP; mark++) {
3578 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3579 *mark = sv_mortalcopy(*mark);
3580 TAINT_NOT; /* Each item is independent */
3584 PL_curpm = newpm; /* Don't pop $1 et al till now */
3592 S_doparseform(pTHX_ SV *sv)
3595 register char *s = SvPV_force(sv, len);
3596 register char *send = s + len;
3597 register char *base = Nullch;
3598 register I32 skipspaces = 0;
3599 bool noblank = FALSE;
3600 bool repeat = FALSE;
3601 bool postspace = FALSE;
3607 bool unchopnum = FALSE;
3608 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3611 Perl_croak(aTHX_ "Null picture in formline");
3613 /* estimate the buffer size needed */
3614 for (base = s; s <= send; s++) {
3615 if (*s == '\n' || *s == '@' || *s == '^')
3621 New(804, fops, maxops, U32);
3626 *fpc++ = FF_LINEMARK;
3627 noblank = repeat = FALSE;
3645 case ' ': case '\t':
3652 } /* else FALL THROUGH */
3660 *fpc++ = FF_LITERAL;
3668 *fpc++ = (U16)skipspaces;
3672 *fpc++ = FF_NEWLINE;
3676 arg = fpc - linepc + 1;
3683 *fpc++ = FF_LINEMARK;
3684 noblank = repeat = FALSE;
3693 ischop = s[-1] == '^';
3699 arg = (s - base) - 1;
3701 *fpc++ = FF_LITERAL;
3709 *fpc++ = 2; /* skip the @* or ^* */
3711 *fpc++ = FF_LINESNGL;
3714 *fpc++ = FF_LINEGLOB;
3716 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3717 arg = ischop ? 512 : 0;
3727 arg |= 256 + (s - f);
3729 *fpc++ = s - base; /* fieldsize for FETCH */
3730 *fpc++ = FF_DECIMAL;
3732 unchopnum |= ! ischop;
3734 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3735 arg = ischop ? 512 : 0;
3737 s++; /* skip the '0' first */
3746 arg |= 256 + (s - f);
3748 *fpc++ = s - base; /* fieldsize for FETCH */
3749 *fpc++ = FF_0DECIMAL;
3751 unchopnum |= ! ischop;
3755 bool ismore = FALSE;
3758 while (*++s == '>') ;
3759 prespace = FF_SPACE;
3761 else if (*s == '|') {
3762 while (*++s == '|') ;
3763 prespace = FF_HALFSPACE;
3768 while (*++s == '<') ;
3771 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3775 *fpc++ = s - base; /* fieldsize for FETCH */
3777 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3780 *fpc++ = (U16)prespace;
3794 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3796 { /* need to jump to the next word */
3798 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3799 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3800 s = SvPVX(sv) + SvCUR(sv) + z;
3802 Copy(fops, s, arg, U32);
3804 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3807 if (unchopnum && repeat)
3808 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3814 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3816 /* Can value be printed in fldsize chars, using %*.*f ? */
3820 int intsize = fldsize - (value < 0 ? 1 : 0);
3827 while (intsize--) pwr *= 10.0;
3828 while (frcsize--) eps /= 10.0;
3831 if (value + eps >= pwr)
3834 if (value - eps <= -pwr)
3841 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3843 SV *datasv = FILTER_DATA(idx);
3844 int filter_has_file = IoLINES(datasv);
3845 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3846 SV *filter_state = (SV *)IoTOP_GV(datasv);
3847 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3850 /* I was having segfault trouble under Linux 2.2.5 after a
3851 parse error occured. (Had to hack around it with a test
3852 for PL_error_count == 0.) Solaris doesn't segfault --
3853 not sure where the trouble is yet. XXX */
3855 if (filter_has_file) {
3856 len = FILTER_READ(idx+1, buf_sv, maxlen);
3859 if (filter_sub && len >= 0) {
3870 PUSHs(sv_2mortal(newSViv(maxlen)));
3872 PUSHs(filter_state);
3875 count = call_sv(filter_sub, G_SCALAR);
3891 IoLINES(datasv) = 0;
3892 if (filter_child_proc) {
3893 SvREFCNT_dec(filter_child_proc);
3894 IoFMT_GV(datasv) = Nullgv;
3897 SvREFCNT_dec(filter_state);
3898 IoTOP_GV(datasv) = Nullgv;
3901 SvREFCNT_dec(filter_sub);
3902 IoBOTTOM_GV(datasv) = Nullgv;
3904 filter_del(run_user_filter);
3910 /* perhaps someone can come up with a better name for
3911 this? it is not really "absolute", per se ... */
3913 S_path_is_absolute(pTHX_ char *name)
3915 if (PERL_FILE_IS_ABSOLUTE(name)
3916 #ifdef MACOS_TRADITIONAL
3919 || (*name == '.' && (name[1] == '/' ||
3920 (name[1] == '.' && name[2] == '/'))))
3931 * c-indentation-style: bsd
3933 * indent-tabs-mode: t
3936 * vim: shiftwidth=4: