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 SvPV_set(targ, SvPVX(dstr));
246 SvCUR_set(targ, SvCUR(dstr));
247 SvLEN_set(targ, SvLEN(dstr));
250 SvPV_set(dstr, (char*)0);
253 TAINT_IF(cx->sb_rxtainted & 1);
254 PUSHs(sv_2mortal(newSViv(saviters - 1)));
256 (void)SvPOK_only_UTF8(targ);
257 TAINT_IF(cx->sb_rxtainted);
261 LEAVE_SCOPE(cx->sb_oldsave);
264 RETURNOP(pm->op_next);
266 cx->sb_iters = saviters;
268 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
271 cx->sb_orig = orig = rx->subbeg;
273 cx->sb_strend = s + (cx->sb_strend - m);
275 cx->sb_m = m = rx->startp[0] + orig;
277 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
278 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
280 sv_catpvn(dstr, s, m-s);
282 cx->sb_s = rx->endp[0] + orig;
283 { /* Update the pos() information. */
284 SV *sv = cx->sb_targ;
287 if (SvTYPE(sv) < SVt_PVMG)
288 (void)SvUPGRADE(sv, SVt_PVMG);
289 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
290 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
291 mg = mg_find(sv, PERL_MAGIC_regex_global);
300 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
301 rxres_save(&cx->sb_rxres, rx);
302 RETURNOP(pm->op_pmreplstart);
306 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
311 if (!p || p[1] < rx->nparens) {
312 #ifdef PERL_COPY_ON_WRITE
313 i = 7 + rx->nparens * 2;
315 i = 6 + rx->nparens * 2;
324 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
325 RX_MATCH_COPIED_off(rx);
327 #ifdef PERL_COPY_ON_WRITE
328 *p++ = PTR2UV(rx->saved_copy);
329 rx->saved_copy = Nullsv;
334 *p++ = PTR2UV(rx->subbeg);
335 *p++ = (UV)rx->sublen;
336 for (i = 0; i <= rx->nparens; ++i) {
337 *p++ = (UV)rx->startp[i];
338 *p++ = (UV)rx->endp[i];
343 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
348 RX_MATCH_COPY_FREE(rx);
349 RX_MATCH_COPIED_set(rx, *p);
352 #ifdef PERL_COPY_ON_WRITE
354 SvREFCNT_dec (rx->saved_copy);
355 rx->saved_copy = INT2PTR(SV*,*p);
361 rx->subbeg = INT2PTR(char*,*p++);
362 rx->sublen = (I32)(*p++);
363 for (i = 0; i <= rx->nparens; ++i) {
364 rx->startp[i] = (I32)(*p++);
365 rx->endp[i] = (I32)(*p++);
370 Perl_rxres_free(pTHX_ void **rsp)
375 Safefree(INT2PTR(char*,*p));
376 #ifdef PERL_COPY_ON_WRITE
378 SvREFCNT_dec (INT2PTR(SV*,p[1]));
388 dSP; dMARK; dORIGMARK;
389 register SV *tmpForm = *++MARK;
396 register SV *sv = Nullsv;
401 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
402 char *chophere = Nullch;
403 char *linemark = Nullch;
405 bool gotsome = FALSE;
407 STRLEN fudge = SvPOK(tmpForm)
408 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
409 bool item_is_utf8 = FALSE;
410 bool targ_is_utf8 = FALSE;
416 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
417 if (SvREADONLY(tmpForm)) {
418 SvREADONLY_off(tmpForm);
419 parseres = doparseform(tmpForm);
420 SvREADONLY_on(tmpForm);
423 parseres = doparseform(tmpForm);
427 SvPV_force(PL_formtarget, len);
428 if (DO_UTF8(PL_formtarget))
430 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
432 f = SvPV(tmpForm, len);
433 /* need to jump to the next word */
434 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
440 const char *name = "???";
443 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
444 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
445 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
446 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
447 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
449 case FF_CHECKNL: name = "CHECKNL"; break;
450 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
451 case FF_SPACE: name = "SPACE"; break;
452 case FF_HALFSPACE: name = "HALFSPACE"; break;
453 case FF_ITEM: name = "ITEM"; break;
454 case FF_CHOP: name = "CHOP"; break;
455 case FF_LINEGLOB: name = "LINEGLOB"; break;
456 case FF_NEWLINE: name = "NEWLINE"; break;
457 case FF_MORE: name = "MORE"; break;
458 case FF_LINEMARK: name = "LINEMARK"; break;
459 case FF_END: name = "END"; break;
460 case FF_0DECIMAL: name = "0DECIMAL"; break;
461 case FF_LINESNGL: name = "LINESNGL"; break;
464 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
466 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
477 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
478 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
480 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
481 t = SvEND(PL_formtarget);
484 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
485 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
487 sv_utf8_upgrade(PL_formtarget);
488 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
489 t = SvEND(PL_formtarget);
509 if (ckWARN(WARN_SYNTAX))
510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
515 item = s = SvPV(sv, len);
518 itemsize = sv_len_utf8(sv);
519 if (itemsize != (I32)len) {
521 if (itemsize > fieldsize) {
522 itemsize = fieldsize;
523 itembytes = itemsize;
524 sv_pos_u2b(sv, &itembytes, 0);
528 send = chophere = s + itembytes;
538 sv_pos_b2u(sv, &itemsize);
542 item_is_utf8 = FALSE;
543 if (itemsize > fieldsize)
544 itemsize = fieldsize;
545 send = chophere = s + itemsize;
557 item = s = SvPV(sv, len);
560 itemsize = sv_len_utf8(sv);
561 if (itemsize != (I32)len) {
563 if (itemsize <= fieldsize) {
564 send = chophere = s + itemsize;
576 itemsize = fieldsize;
577 itembytes = itemsize;
578 sv_pos_u2b(sv, &itembytes, 0);
579 send = chophere = s + itembytes;
580 while (s < send || (s == send && isSPACE(*s))) {
590 if (strchr(PL_chopset, *s))
595 itemsize = chophere - item;
596 sv_pos_b2u(sv, &itemsize);
602 item_is_utf8 = FALSE;
603 if (itemsize <= fieldsize) {
604 send = chophere = s + itemsize;
616 itemsize = fieldsize;
617 send = chophere = s + itemsize;
618 while (s < send || (s == send && isSPACE(*s))) {
628 if (strchr(PL_chopset, *s))
633 itemsize = chophere - item;
638 arg = fieldsize - itemsize;
647 arg = fieldsize - itemsize;
661 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
663 sv_utf8_upgrade(PL_formtarget);
664 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
665 t = SvEND(PL_formtarget);
669 if (UTF8_IS_CONTINUED(*s)) {
670 STRLEN skip = UTF8SKIP(s);
687 if ( !((*t++ = *s++) & ~31) )
693 if (targ_is_utf8 && !item_is_utf8) {
694 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
696 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
697 for (; t < SvEND(PL_formtarget); t++) {
710 int ch = *t++ = *s++;
713 if ( !((*t++ = *s++) & ~31) )
722 while (*s && isSPACE(*s))
736 item = s = SvPV(sv, len);
738 if ((item_is_utf8 = DO_UTF8(sv)))
739 itemsize = sv_len_utf8(sv);
741 bool chopped = FALSE;
744 chophere = s + itemsize;
760 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
762 SvUTF8_on(PL_formtarget);
764 SvCUR_set(sv, chophere - item);
765 sv_catsv(PL_formtarget, sv);
766 SvCUR_set(sv, itemsize);
768 sv_catsv(PL_formtarget, sv);
770 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
771 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
772 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
780 #if defined(USE_LONG_DOUBLE)
781 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
783 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
788 #if defined(USE_LONG_DOUBLE)
789 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
791 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
794 /* If the field is marked with ^ and the value is undefined,
796 if ((arg & 512) && !SvOK(sv)) {
804 /* overflow evidence */
805 if (num_overflow(value, fieldsize, arg)) {
811 /* Formats aren't yet marked for locales, so assume "yes". */
813 STORE_NUMERIC_STANDARD_SET_LOCAL();
814 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
815 RESTORE_NUMERIC_STANDARD();
822 while (t-- > linemark && *t == ' ') ;
830 if (arg) { /* repeat until fields exhausted? */
832 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
833 lines += FmLINES(PL_formtarget);
836 if (strnEQ(linemark, linemark - arg, arg))
837 DIE(aTHX_ "Runaway format");
840 SvUTF8_on(PL_formtarget);
841 FmLINES(PL_formtarget) = lines;
843 RETURNOP(cLISTOP->op_first);
856 while (*s && isSPACE(*s) && s < send)
860 arg = fieldsize - itemsize;
867 if (strnEQ(s," ",3)) {
868 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
879 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
881 SvUTF8_on(PL_formtarget);
882 FmLINES(PL_formtarget) += lines;
894 if (PL_stack_base + *PL_markstack_ptr == SP) {
896 if (GIMME_V == G_SCALAR)
897 XPUSHs(sv_2mortal(newSViv(0)));
898 RETURNOP(PL_op->op_next->op_next);
900 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
901 pp_pushmark(); /* push dst */
902 pp_pushmark(); /* push src */
903 ENTER; /* enter outer scope */
906 if (PL_op->op_private & OPpGREP_LEX)
907 SAVESPTR(PAD_SVl(PL_op->op_targ));
910 ENTER; /* enter inner scope */
913 src = PL_stack_base[*PL_markstack_ptr];
915 if (PL_op->op_private & OPpGREP_LEX)
916 PAD_SVl(PL_op->op_targ) = src;
921 if (PL_op->op_type == OP_MAPSTART)
922 pp_pushmark(); /* push top */
923 return ((LOGOP*)PL_op->op_next)->op_other;
928 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
935 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
941 /* first, move source pointer to the next item in the source list */
942 ++PL_markstack_ptr[-1];
944 /* if there are new items, push them into the destination list */
945 if (items && gimme != G_VOID) {
946 /* might need to make room back there first */
947 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
948 /* XXX this implementation is very pessimal because the stack
949 * is repeatedly extended for every set of items. Is possible
950 * to do this without any stack extension or copying at all
951 * by maintaining a separate list over which the map iterates
952 * (like foreach does). --gsar */
954 /* everything in the stack after the destination list moves
955 * towards the end the stack by the amount of room needed */
956 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
958 /* items to shift up (accounting for the moved source pointer) */
959 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
961 /* This optimization is by Ben Tilly and it does
962 * things differently from what Sarathy (gsar)
963 * is describing. The downside of this optimization is
964 * that leaves "holes" (uninitialized and hopefully unused areas)
965 * to the Perl stack, but on the other hand this
966 * shouldn't be a problem. If Sarathy's idea gets
967 * implemented, this optimization should become
968 * irrelevant. --jhi */
970 shift = count; /* Avoid shifting too often --Ben Tilly */
975 PL_markstack_ptr[-1] += shift;
976 *PL_markstack_ptr += shift;
980 /* copy the new items down to the destination list */
981 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
982 if (gimme == G_ARRAY) {
984 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
987 /* scalar context: we don't care about which values map returns
988 * (we use undef here). And so we certainly don't want to do mortal
989 * copies of meaningless values. */
990 while (items-- > 0) {
992 *dst-- = &PL_sv_undef;
996 LEAVE; /* exit inner scope */
999 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1001 (void)POPMARK; /* pop top */
1002 LEAVE; /* exit outer scope */
1003 (void)POPMARK; /* pop src */
1004 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1005 (void)POPMARK; /* pop dst */
1006 SP = PL_stack_base + POPMARK; /* pop original mark */
1007 if (gimme == G_SCALAR) {
1008 if (PL_op->op_private & OPpGREP_LEX) {
1009 SV* sv = sv_newmortal();
1010 sv_setiv(sv, items);
1018 else if (gimme == G_ARRAY)
1025 ENTER; /* enter inner scope */
1028 /* set $_ to the new source item */
1029 src = PL_stack_base[PL_markstack_ptr[-1]];
1031 if (PL_op->op_private & OPpGREP_LEX)
1032 PAD_SVl(PL_op->op_targ) = src;
1036 RETURNOP(cLOGOP->op_other);
1044 if (GIMME == G_ARRAY)
1046 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1047 return cLOGOP->op_other;
1056 if (GIMME == G_ARRAY) {
1057 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1061 SV *targ = PAD_SV(PL_op->op_targ);
1064 if (PL_op->op_private & OPpFLIP_LINENUM) {
1065 if (GvIO(PL_last_in_gv)) {
1066 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1069 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1070 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1076 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1077 if (PL_op->op_flags & OPf_SPECIAL) {
1085 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1094 /* This code tries to decide if "$left .. $right" should use the
1095 magical string increment, or if the range is numeric (we make
1096 an exception for .."0" [#18165]). AMS 20021031. */
1098 #define RANGE_IS_NUMERIC(left,right) ( \
1099 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1100 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1101 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1102 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1103 && (!SvOK(right) || looks_like_number(right))))
1109 if (GIMME == G_ARRAY) {
1115 if (SvGMAGICAL(left))
1117 if (SvGMAGICAL(right))
1120 if (RANGE_IS_NUMERIC(left,right)) {
1121 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1122 (SvOK(right) && SvNV(right) > IV_MAX))
1123 DIE(aTHX_ "Range iterator outside integer range");
1134 sv = sv_2mortal(newSViv(i++));
1139 SV *final = sv_mortalcopy(right);
1141 char *tmps = SvPV(final, len);
1143 sv = sv_mortalcopy(left);
1145 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1147 if (strEQ(SvPVX(sv),tmps))
1149 sv = sv_2mortal(newSVsv(sv));
1156 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1160 if (PL_op->op_private & OPpFLIP_LINENUM) {
1161 if (GvIO(PL_last_in_gv)) {
1162 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1165 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1166 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1174 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1175 sv_catpv(targ, "E0");
1185 static const char * const context_name[] = {
1196 S_dopoptolabel(pTHX_ const char *label)
1200 for (i = cxstack_ix; i >= 0; i--) {
1201 register const PERL_CONTEXT *cx = &cxstack[i];
1202 switch (CxTYPE(cx)) {
1208 if (ckWARN(WARN_EXITING))
1209 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1210 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1211 if (CxTYPE(cx) == CXt_NULL)
1215 if (!cx->blk_loop.label ||
1216 strNE(label, cx->blk_loop.label) ) {
1217 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1218 (long)i, cx->blk_loop.label));
1221 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1229 Perl_dowantarray(pTHX)
1231 I32 gimme = block_gimme();
1232 return (gimme == G_VOID) ? G_SCALAR : gimme;
1236 Perl_block_gimme(pTHX)
1238 const I32 cxix = dopoptosub(cxstack_ix);
1242 switch (cxstack[cxix].blk_gimme) {
1250 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1257 Perl_is_lvalue_sub(pTHX)
1259 const I32 cxix = dopoptosub(cxstack_ix);
1260 assert(cxix >= 0); /* We should only be called from inside subs */
1262 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1263 return cxstack[cxix].blk_sub.lval;
1269 S_dopoptosub(pTHX_ I32 startingblock)
1271 return dopoptosub_at(cxstack, startingblock);
1275 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1278 for (i = startingblock; i >= 0; i--) {
1279 register const PERL_CONTEXT *cx = &cxstk[i];
1280 switch (CxTYPE(cx)) {
1286 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1294 S_dopoptoeval(pTHX_ I32 startingblock)
1297 for (i = startingblock; i >= 0; i--) {
1298 register const PERL_CONTEXT *cx = &cxstack[i];
1299 switch (CxTYPE(cx)) {
1303 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1311 S_dopoptoloop(pTHX_ I32 startingblock)
1314 for (i = startingblock; i >= 0; i--) {
1315 register const PERL_CONTEXT *cx = &cxstack[i];
1316 switch (CxTYPE(cx)) {
1322 if (ckWARN(WARN_EXITING))
1323 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1324 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1325 if ((CxTYPE(cx)) == CXt_NULL)
1329 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1337 Perl_dounwind(pTHX_ I32 cxix)
1341 while (cxstack_ix > cxix) {
1343 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1344 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1345 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1346 /* Note: we don't need to restore the base context info till the end. */
1347 switch (CxTYPE(cx)) {
1350 continue; /* not break */
1372 Perl_qerror(pTHX_ SV *err)
1375 sv_catsv(ERRSV, err);
1377 sv_catsv(PL_errors, err);
1379 Perl_warn(aTHX_ "%"SVf, err);
1384 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1395 if (PL_in_eval & EVAL_KEEPERR) {
1396 static const char prefix[] = "\t(in cleanup) ";
1398 const char *e = Nullch;
1401 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1404 if (*e != *message || strNE(e,message))
1408 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1409 sv_catpvn(err, prefix, sizeof(prefix)-1);
1410 sv_catpvn(err, message, msglen);
1411 if (ckWARN(WARN_MISC)) {
1412 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1413 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1418 sv_setpvn(ERRSV, message, msglen);
1422 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1423 && PL_curstackinfo->si_prev)
1431 register PERL_CONTEXT *cx;
1433 if (cxix < cxstack_ix)
1436 POPBLOCK(cx,PL_curpm);
1437 if (CxTYPE(cx) != CXt_EVAL) {
1439 message = SvPVx(ERRSV, msglen);
1440 PerlIO_write(Perl_error_log, "panic: die ", 11);
1441 PerlIO_write(Perl_error_log, message, msglen);
1446 if (gimme == G_SCALAR)
1447 *++newsp = &PL_sv_undef;
1448 PL_stack_sp = newsp;
1452 /* LEAVE could clobber PL_curcop (see save_re_context())
1453 * XXX it might be better to find a way to avoid messing with
1454 * PL_curcop in save_re_context() instead, but this is a more
1455 * minimal fix --GSAR */
1456 PL_curcop = cx->blk_oldcop;
1458 if (optype == OP_REQUIRE) {
1459 const char* msg = SvPVx(ERRSV, n_a);
1460 SV *nsv = cx->blk_eval.old_namesv;
1461 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1463 DIE(aTHX_ "%sCompilation failed in require",
1464 *msg ? msg : "Unknown error\n");
1466 assert(CxTYPE(cx) == CXt_EVAL);
1467 return cx->blk_eval.retop;
1471 message = SvPVx(ERRSV, msglen);
1473 write_to_stderr(message, msglen);
1482 if (SvTRUE(left) != SvTRUE(right))
1494 RETURNOP(cLOGOP->op_other);
1503 RETURNOP(cLOGOP->op_other);
1512 if (!sv || !SvANY(sv)) {
1513 RETURNOP(cLOGOP->op_other);
1516 switch (SvTYPE(sv)) {
1518 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1522 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1526 if (CvROOT(sv) || CvXSUB(sv))
1536 RETURNOP(cLOGOP->op_other);
1542 register I32 cxix = dopoptosub(cxstack_ix);
1543 register PERL_CONTEXT *cx;
1544 register PERL_CONTEXT *ccstack = cxstack;
1545 PERL_SI *top_si = PL_curstackinfo;
1548 const char *stashname;
1556 /* we may be in a higher stacklevel, so dig down deeper */
1557 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1558 top_si = top_si->si_prev;
1559 ccstack = top_si->si_cxstack;
1560 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1563 if (GIMME != G_ARRAY) {
1569 /* caller() should not report the automatic calls to &DB::sub */
1570 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1571 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1575 cxix = dopoptosub_at(ccstack, cxix - 1);
1578 cx = &ccstack[cxix];
1579 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1580 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1581 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1582 field below is defined for any cx. */
1583 /* caller() should not report the automatic calls to &DB::sub */
1584 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1585 cx = &ccstack[dbcxix];
1588 stashname = CopSTASHPV(cx->blk_oldcop);
1589 if (GIMME != G_ARRAY) {
1592 PUSHs(&PL_sv_undef);
1595 sv_setpv(TARG, stashname);
1604 PUSHs(&PL_sv_undef);
1606 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1607 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1608 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1611 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1612 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1613 /* So is ccstack[dbcxix]. */
1616 gv_efullname3(sv, cvgv, Nullch);
1617 PUSHs(sv_2mortal(sv));
1618 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1621 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1622 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1626 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1627 PUSHs(sv_2mortal(newSViv(0)));
1629 gimme = (I32)cx->blk_gimme;
1630 if (gimme == G_VOID)
1631 PUSHs(&PL_sv_undef);
1633 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1634 if (CxTYPE(cx) == CXt_EVAL) {
1636 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1637 PUSHs(cx->blk_eval.cur_text);
1641 else if (cx->blk_eval.old_namesv) {
1642 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1645 /* eval BLOCK (try blocks have old_namesv == 0) */
1647 PUSHs(&PL_sv_undef);
1648 PUSHs(&PL_sv_undef);
1652 PUSHs(&PL_sv_undef);
1653 PUSHs(&PL_sv_undef);
1655 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1656 && CopSTASH_eq(PL_curcop, PL_debstash))
1658 AV *ary = cx->blk_sub.argarray;
1659 const int off = AvARRAY(ary) - AvALLOC(ary);
1663 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1666 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1669 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1670 av_extend(PL_dbargs, AvFILLp(ary) + off);
1671 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1672 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1674 /* XXX only hints propagated via op_private are currently
1675 * visible (others are not easily accessible, since they
1676 * use the global PL_hints) */
1677 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1678 HINT_PRIVATE_MASK)));
1681 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1683 if (old_warnings == pWARN_NONE ||
1684 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1685 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1686 else if (old_warnings == pWARN_ALL ||
1687 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1688 /* Get the bit mask for $warnings::Bits{all}, because
1689 * it could have been extended by warnings::register */
1691 HV *bits = get_hv("warnings::Bits", FALSE);
1692 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1693 mask = newSVsv(*bits_all);
1696 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1700 mask = newSVsv(old_warnings);
1701 PUSHs(sv_2mortal(mask));
1716 sv_reset(tmps, CopSTASH(PL_curcop));
1726 /* like pp_nextstate, but used instead when the debugger is active */
1731 PL_curcop = (COP*)PL_op;
1732 TAINT_NOT; /* Each statement is presumed innocent */
1733 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1736 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1737 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1741 register PERL_CONTEXT *cx;
1742 I32 gimme = G_ARRAY;
1749 DIE(aTHX_ "No DB::DB routine defined");
1751 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1752 /* don't do recursive DB::DB call */
1764 PUSHBLOCK(cx, CXt_SUB, SP);
1766 cx->blk_sub.retop = PL_op->op_next;
1768 PAD_SET_CUR(CvPADLIST(cv),1);
1769 RETURNOP(CvSTART(cv));
1783 register PERL_CONTEXT *cx;
1784 I32 gimme = GIMME_V;
1786 U32 cxtype = CXt_LOOP;
1794 if (PL_op->op_targ) {
1795 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1796 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1797 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1798 SVs_PADSTALE, SVs_PADSTALE);
1800 #ifndef USE_ITHREADS
1801 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1804 SAVEPADSV(PL_op->op_targ);
1805 iterdata = INT2PTR(void*, PL_op->op_targ);
1806 cxtype |= CXp_PADVAR;
1811 svp = &GvSV(gv); /* symbol table variable */
1812 SAVEGENERICSV(*svp);
1815 iterdata = (void*)gv;
1821 PUSHBLOCK(cx, cxtype, SP);
1823 PUSHLOOP(cx, iterdata, MARK);
1825 PUSHLOOP(cx, svp, MARK);
1827 if (PL_op->op_flags & OPf_STACKED) {
1828 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1829 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1831 SV *right = (SV*)cx->blk_loop.iterary;
1832 if (RANGE_IS_NUMERIC(sv,right)) {
1833 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1834 (SvOK(right) && SvNV(right) >= IV_MAX))
1835 DIE(aTHX_ "Range iterator outside integer range");
1836 cx->blk_loop.iterix = SvIV(sv);
1837 cx->blk_loop.itermax = SvIV(right);
1841 cx->blk_loop.iterlval = newSVsv(sv);
1842 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1843 (void) SvPV(right,n_a);
1846 else if (PL_op->op_private & OPpITER_REVERSED) {
1847 cx->blk_loop.itermax = -1;
1848 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1853 cx->blk_loop.iterary = PL_curstack;
1854 AvFILLp(PL_curstack) = SP - PL_stack_base;
1855 if (PL_op->op_private & OPpITER_REVERSED) {
1856 cx->blk_loop.itermax = MARK - PL_stack_base;
1857 cx->blk_loop.iterix = cx->blk_oldsp;
1860 cx->blk_loop.iterix = MARK - PL_stack_base;
1870 register PERL_CONTEXT *cx;
1871 I32 gimme = GIMME_V;
1877 PUSHBLOCK(cx, CXt_LOOP, SP);
1878 PUSHLOOP(cx, 0, SP);
1886 register PERL_CONTEXT *cx;
1894 newsp = PL_stack_base + cx->blk_loop.resetsp;
1897 if (gimme == G_VOID)
1899 else if (gimme == G_SCALAR) {
1901 *++newsp = sv_mortalcopy(*SP);
1903 *++newsp = &PL_sv_undef;
1907 *++newsp = sv_mortalcopy(*++mark);
1908 TAINT_NOT; /* Each item is independent */
1914 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1915 PL_curpm = newpm; /* ... and pop $1 et al */
1927 register PERL_CONTEXT *cx;
1928 bool popsub2 = FALSE;
1929 bool clear_errsv = FALSE;
1937 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1938 if (cxstack_ix == PL_sortcxix
1939 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1941 if (cxstack_ix > PL_sortcxix)
1942 dounwind(PL_sortcxix);
1943 AvARRAY(PL_curstack)[1] = *SP;
1944 PL_stack_sp = PL_stack_base + 1;
1949 cxix = dopoptosub(cxstack_ix);
1951 DIE(aTHX_ "Can't return outside a subroutine");
1952 if (cxix < cxstack_ix)
1956 switch (CxTYPE(cx)) {
1959 retop = cx->blk_sub.retop;
1960 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1963 if (!(PL_in_eval & EVAL_KEEPERR))
1966 retop = cx->blk_eval.retop;
1970 if (optype == OP_REQUIRE &&
1971 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1973 /* Unassume the success we assumed earlier. */
1974 SV *nsv = cx->blk_eval.old_namesv;
1975 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1976 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1981 retop = cx->blk_sub.retop;
1984 DIE(aTHX_ "panic: return");
1988 if (gimme == G_SCALAR) {
1991 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1993 *++newsp = SvREFCNT_inc(*SP);
1998 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2000 *++newsp = sv_mortalcopy(sv);
2005 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2008 *++newsp = sv_mortalcopy(*SP);
2011 *++newsp = &PL_sv_undef;
2013 else if (gimme == G_ARRAY) {
2014 while (++MARK <= SP) {
2015 *++newsp = (popsub2 && SvTEMP(*MARK))
2016 ? *MARK : sv_mortalcopy(*MARK);
2017 TAINT_NOT; /* Each item is independent */
2020 PL_stack_sp = newsp;
2023 /* Stack values are safe: */
2026 POPSUB(cx,sv); /* release CV and @_ ... */
2030 PL_curpm = newpm; /* ... and pop $1 et al */
2042 register PERL_CONTEXT *cx;
2052 if (PL_op->op_flags & OPf_SPECIAL) {
2053 cxix = dopoptoloop(cxstack_ix);
2055 DIE(aTHX_ "Can't \"last\" outside a loop block");
2058 cxix = dopoptolabel(cPVOP->op_pv);
2060 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2062 if (cxix < cxstack_ix)
2066 cxstack_ix++; /* temporarily protect top context */
2068 switch (CxTYPE(cx)) {
2071 newsp = PL_stack_base + cx->blk_loop.resetsp;
2072 nextop = cx->blk_loop.last_op->op_next;
2076 nextop = cx->blk_sub.retop;
2080 nextop = cx->blk_eval.retop;
2084 nextop = cx->blk_sub.retop;
2087 DIE(aTHX_ "panic: last");
2091 if (gimme == G_SCALAR) {
2093 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2094 ? *SP : sv_mortalcopy(*SP);
2096 *++newsp = &PL_sv_undef;
2098 else if (gimme == G_ARRAY) {
2099 while (++MARK <= SP) {
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2101 ? *MARK : sv_mortalcopy(*MARK);
2102 TAINT_NOT; /* Each item is independent */
2110 /* Stack values are safe: */
2113 POPLOOP(cx); /* release loop vars ... */
2117 POPSUB(cx,sv); /* release CV and @_ ... */
2120 PL_curpm = newpm; /* ... and pop $1 et al */
2130 register PERL_CONTEXT *cx;
2133 if (PL_op->op_flags & OPf_SPECIAL) {
2134 cxix = dopoptoloop(cxstack_ix);
2136 DIE(aTHX_ "Can't \"next\" outside a loop block");
2139 cxix = dopoptolabel(cPVOP->op_pv);
2141 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2143 if (cxix < cxstack_ix)
2146 /* clear off anything above the scope we're re-entering, but
2147 * save the rest until after a possible continue block */
2148 inner = PL_scopestack_ix;
2150 if (PL_scopestack_ix < inner)
2151 leave_scope(PL_scopestack[PL_scopestack_ix]);
2152 return cx->blk_loop.next_op;
2159 register PERL_CONTEXT *cx;
2162 if (PL_op->op_flags & OPf_SPECIAL) {
2163 cxix = dopoptoloop(cxstack_ix);
2165 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2168 cxix = dopoptolabel(cPVOP->op_pv);
2170 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2172 if (cxix < cxstack_ix)
2176 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2177 LEAVE_SCOPE(oldsave);
2179 return cx->blk_loop.redo_op;
2183 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2187 static const char too_deep[] = "Target of goto is too deeply nested";
2190 Perl_croak(aTHX_ too_deep);
2191 if (o->op_type == OP_LEAVE ||
2192 o->op_type == OP_SCOPE ||
2193 o->op_type == OP_LEAVELOOP ||
2194 o->op_type == OP_LEAVESUB ||
2195 o->op_type == OP_LEAVETRY)
2197 *ops++ = cUNOPo->op_first;
2199 Perl_croak(aTHX_ too_deep);
2202 if (o->op_flags & OPf_KIDS) {
2203 /* First try all the kids at this level, since that's likeliest. */
2204 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2205 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2206 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2209 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2210 if (kid == PL_lastgotoprobe)
2212 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2215 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2216 ops[-1]->op_type == OP_DBSTATE)
2221 if ((o = dofindlabel(kid, label, ops, oplimit)))
2240 register PERL_CONTEXT *cx;
2241 #define GOTO_DEPTH 64
2242 OP *enterops[GOTO_DEPTH];
2243 const char *label = 0;
2244 const bool do_dump = (PL_op->op_type == OP_DUMP);
2245 static const char must_have_label[] = "goto must have label";
2247 if (PL_op->op_flags & OPf_STACKED) {
2251 /* This egregious kludge implements goto &subroutine */
2252 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2254 register PERL_CONTEXT *cx;
2255 CV* cv = (CV*)SvRV(sv);
2262 if (!CvROOT(cv) && !CvXSUB(cv)) {
2263 const GV * const gv = CvGV(cv);
2267 /* autoloaded stub? */
2268 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2270 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2271 GvNAMELEN(gv), FALSE);
2272 if (autogv && (cv = GvCV(autogv)))
2274 tmpstr = sv_newmortal();
2275 gv_efullname3(tmpstr, gv, Nullch);
2276 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2278 DIE(aTHX_ "Goto undefined subroutine");
2281 /* First do some returnish stuff. */
2282 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2284 cxix = dopoptosub(cxstack_ix);
2286 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2287 if (cxix < cxstack_ix)
2291 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2292 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2293 /* put @_ back onto stack */
2294 AV* av = cx->blk_sub.argarray;
2296 items = AvFILLp(av) + 1;
2297 EXTEND(SP, items+1); /* @_ could have been extended. */
2298 Copy(AvARRAY(av), SP + 1, items, SV*);
2299 SvREFCNT_dec(GvAV(PL_defgv));
2300 GvAV(PL_defgv) = cx->blk_sub.savearray;
2302 /* abandon @_ if it got reified */
2307 av_extend(av, items-1);
2308 AvFLAGS(av) = AVf_REIFY;
2309 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2312 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2314 av = GvAV(PL_defgv);
2315 items = AvFILLp(av) + 1;
2316 EXTEND(SP, items+1); /* @_ could have been extended. */
2317 Copy(AvARRAY(av), SP + 1, items, SV*);
2321 if (CxTYPE(cx) == CXt_SUB &&
2322 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2323 SvREFCNT_dec(cx->blk_sub.cv);
2324 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2325 LEAVE_SCOPE(oldsave);
2327 /* Now do some callish stuff. */
2329 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2333 for (index=0; index<items; index++)
2334 sv_2mortal(SP[-index]);
2336 #ifdef PERL_XSUB_OLDSTYLE
2337 if (CvOLDSTYLE(cv)) {
2338 I32 (*fp3)(int,int,int);
2343 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2344 items = (*fp3)(CvXSUBANY(cv).any_i32,
2345 mark - PL_stack_base + 1,
2347 SP = PL_stack_base + items;
2350 #endif /* PERL_XSUB_OLDSTYLE */
2355 /* Push a mark for the start of arglist */
2358 (void)(*CvXSUB(cv))(aTHX_ cv);
2359 /* Pop the current context like a decent sub should */
2360 POPBLOCK(cx, PL_curpm);
2361 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2364 assert(CxTYPE(cx) == CXt_SUB);
2365 return cx->blk_sub.retop;
2368 AV* padlist = CvPADLIST(cv);
2369 if (CxTYPE(cx) == CXt_EVAL) {
2370 PL_in_eval = cx->blk_eval.old_in_eval;
2371 PL_eval_root = cx->blk_eval.old_eval_root;
2372 cx->cx_type = CXt_SUB;
2373 cx->blk_sub.hasargs = 0;
2375 cx->blk_sub.cv = cv;
2376 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2379 if (CvDEPTH(cv) < 2)
2380 (void)SvREFCNT_inc(cv);
2382 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2383 sub_crush_depth(cv);
2384 pad_push(padlist, CvDEPTH(cv));
2386 PAD_SET_CUR(padlist, CvDEPTH(cv));
2387 if (cx->blk_sub.hasargs)
2389 AV* av = (AV*)PAD_SVl(0);
2392 cx->blk_sub.savearray = GvAV(PL_defgv);
2393 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2394 CX_CURPAD_SAVE(cx->blk_sub);
2395 cx->blk_sub.argarray = av;
2397 if (items >= AvMAX(av) + 1) {
2399 if (AvARRAY(av) != ary) {
2400 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2401 SvPV_set(av, (char*)ary);
2403 if (items >= AvMAX(av) + 1) {
2404 AvMAX(av) = items - 1;
2405 Renew(ary,items+1,SV*);
2407 SvPV_set(av, (char*)ary);
2411 Copy(mark,AvARRAY(av),items,SV*);
2412 AvFILLp(av) = items - 1;
2413 assert(!AvREAL(av));
2415 /* transfer 'ownership' of refcnts to new @_ */
2425 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2427 * We do not care about using sv to call CV;
2428 * it's for informational purposes only.
2430 SV *sv = GvSV(PL_DBsub);
2434 if (PERLDB_SUB_NN) {
2435 int type = SvTYPE(sv);
2436 if (type < SVt_PVIV && type != SVt_IV)
2437 sv_upgrade(sv, SVt_PVIV);
2439 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2441 gv_efullname3(sv, CvGV(cv), Nullch);
2444 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2445 PUSHMARK( PL_stack_sp );
2446 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2450 RETURNOP(CvSTART(cv));
2454 label = SvPV(sv,n_a);
2455 if (!(do_dump || *label))
2456 DIE(aTHX_ must_have_label);
2459 else if (PL_op->op_flags & OPf_SPECIAL) {
2461 DIE(aTHX_ must_have_label);
2464 label = cPVOP->op_pv;
2466 if (label && *label) {
2468 bool leaving_eval = FALSE;
2469 bool in_block = FALSE;
2470 PERL_CONTEXT *last_eval_cx = 0;
2474 PL_lastgotoprobe = 0;
2476 for (ix = cxstack_ix; ix >= 0; ix--) {
2478 switch (CxTYPE(cx)) {
2480 leaving_eval = TRUE;
2481 if (!CxTRYBLOCK(cx)) {
2482 gotoprobe = (last_eval_cx ?
2483 last_eval_cx->blk_eval.old_eval_root :
2488 /* else fall through */
2490 gotoprobe = cx->blk_oldcop->op_sibling;
2496 gotoprobe = cx->blk_oldcop->op_sibling;
2499 gotoprobe = PL_main_root;
2502 if (CvDEPTH(cx->blk_sub.cv)) {
2503 gotoprobe = CvROOT(cx->blk_sub.cv);
2509 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2512 DIE(aTHX_ "panic: goto");
2513 gotoprobe = PL_main_root;
2517 retop = dofindlabel(gotoprobe, label,
2518 enterops, enterops + GOTO_DEPTH);
2522 PL_lastgotoprobe = gotoprobe;
2525 DIE(aTHX_ "Can't find label %s", label);
2527 /* if we're leaving an eval, check before we pop any frames
2528 that we're not going to punt, otherwise the error
2531 if (leaving_eval && *enterops && enterops[1]) {
2533 for (i = 1; enterops[i]; i++)
2534 if (enterops[i]->op_type == OP_ENTERITER)
2535 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2538 /* pop unwanted frames */
2540 if (ix < cxstack_ix) {
2547 oldsave = PL_scopestack[PL_scopestack_ix];
2548 LEAVE_SCOPE(oldsave);
2551 /* push wanted frames */
2553 if (*enterops && enterops[1]) {
2555 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2556 for (; enterops[ix]; ix++) {
2557 PL_op = enterops[ix];
2558 /* Eventually we may want to stack the needed arguments
2559 * for each op. For now, we punt on the hard ones. */
2560 if (PL_op->op_type == OP_ENTERITER)
2561 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2562 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2570 if (!retop) retop = PL_main_start;
2572 PL_restartop = retop;
2573 PL_do_undump = TRUE;
2577 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2578 PL_do_undump = FALSE;
2594 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2596 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2599 PL_exit_flags |= PERL_EXIT_EXPECTED;
2601 PUSHs(&PL_sv_undef);
2609 NV value = SvNVx(GvSV(cCOP->cop_gv));
2610 register I32 match = I_32(value);
2613 if (((NV)match) > value)
2614 --match; /* was fractional--truncate other way */
2616 match -= cCOP->uop.scop.scop_offset;
2619 else if (match > cCOP->uop.scop.scop_max)
2620 match = cCOP->uop.scop.scop_max;
2621 PL_op = cCOP->uop.scop.scop_next[match];
2631 PL_op = PL_op->op_next; /* can't assume anything */
2634 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2635 match -= cCOP->uop.scop.scop_offset;
2638 else if (match > cCOP->uop.scop.scop_max)
2639 match = cCOP->uop.scop.scop_max;
2640 PL_op = cCOP->uop.scop.scop_next[match];
2649 S_save_lines(pTHX_ AV *array, SV *sv)
2651 register const char *s = SvPVX(sv);
2652 register const char *send = SvPVX(sv) + SvCUR(sv);
2653 register const char *t;
2654 register I32 line = 1;
2656 while (s && s < send) {
2657 SV *tmpstr = NEWSV(85,0);
2659 sv_upgrade(tmpstr, SVt_PVMG);
2660 t = strchr(s, '\n');
2666 sv_setpvn(tmpstr, s, t - s);
2667 av_store(array, line++, tmpstr);
2673 S_docatch_body(pTHX)
2680 S_docatch(pTHX_ OP *o)
2683 OP * const oldop = PL_op;
2684 volatile PERL_SI *cursi = PL_curstackinfo;
2688 assert(CATCH_GET == TRUE);
2699 /* die caught by an inner eval - continue inner loop */
2700 if (PL_restartop && cursi == PL_curstackinfo) {
2701 PL_op = PL_restartop;
2718 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2719 /* sv Text to convert to OP tree. */
2720 /* startop op_free() this to undo. */
2721 /* code Short string id of the caller. */
2723 dVAR; dSP; /* Make POPBLOCK work. */
2726 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2730 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2731 char *tmpbuf = tbuf;
2734 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2739 /* switch to eval mode */
2741 if (IN_PERL_COMPILETIME) {
2742 SAVECOPSTASH_FREE(&PL_compiling);
2743 CopSTASH_set(&PL_compiling, PL_curstash);
2745 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2746 SV *sv = sv_newmortal();
2747 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2748 code, (unsigned long)++PL_evalseq,
2749 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2753 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2754 SAVECOPFILE_FREE(&PL_compiling);
2755 CopFILE_set(&PL_compiling, tmpbuf+2);
2756 SAVECOPLINE(&PL_compiling);
2757 CopLINE_set(&PL_compiling, 1);
2758 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2759 deleting the eval's FILEGV from the stash before gv_check() runs
2760 (i.e. before run-time proper). To work around the coredump that
2761 ensues, we always turn GvMULTI_on for any globals that were
2762 introduced within evals. See force_ident(). GSAR 96-10-12 */
2763 safestr = savepv(tmpbuf);
2764 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2766 #ifdef OP_IN_REGISTER
2772 /* we get here either during compilation, or via pp_regcomp at runtime */
2773 runtime = IN_PERL_RUNTIME;
2775 runcv = find_runcv(NULL);
2778 PL_op->op_type = OP_ENTEREVAL;
2779 PL_op->op_flags = 0; /* Avoid uninit warning. */
2780 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2781 PUSHEVAL(cx, 0, Nullgv);
2784 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2786 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2787 POPBLOCK(cx,PL_curpm);
2790 (*startop)->op_type = OP_NULL;
2791 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2793 /* XXX DAPM do this properly one year */
2794 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2796 if (IN_PERL_COMPILETIME)
2797 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2798 #ifdef OP_IN_REGISTER
2806 =for apidoc find_runcv
2808 Locate the CV corresponding to the currently executing sub or eval.
2809 If db_seqp is non_null, skip CVs that are in the DB package and populate
2810 *db_seqp with the cop sequence number at the point that the DB:: code was
2811 entered. (allows debuggers to eval in the scope of the breakpoint rather
2812 than in in the scope of the debugger itself).
2818 Perl_find_runcv(pTHX_ U32 *db_seqp)
2823 *db_seqp = PL_curcop->cop_seq;
2824 for (si = PL_curstackinfo; si; si = si->si_prev) {
2826 for (ix = si->si_cxix; ix >= 0; ix--) {
2827 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2828 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2829 CV *cv = cx->blk_sub.cv;
2830 /* skip DB:: code */
2831 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2832 *db_seqp = cx->blk_oldcop->cop_seq;
2837 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2845 /* Compile a require/do, an eval '', or a /(?{...})/.
2846 * In the last case, startop is non-null, and contains the address of
2847 * a pointer that should be set to the just-compiled code.
2848 * outside is the lexically enclosing CV (if any) that invoked us.
2851 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2853 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2858 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2859 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2864 SAVESPTR(PL_compcv);
2865 PL_compcv = (CV*)NEWSV(1104,0);
2866 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2867 CvEVAL_on(PL_compcv);
2868 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2869 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2871 CvOUTSIDE_SEQ(PL_compcv) = seq;
2872 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2874 /* set up a scratch pad */
2876 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2879 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2881 /* make sure we compile in the right package */
2883 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2884 SAVESPTR(PL_curstash);
2885 PL_curstash = CopSTASH(PL_curcop);
2887 SAVESPTR(PL_beginav);
2888 PL_beginav = newAV();
2889 SAVEFREESV(PL_beginav);
2890 SAVEI32(PL_error_count);
2892 /* try to compile it */
2894 PL_eval_root = Nullop;
2896 PL_curcop = &PL_compiling;
2897 PL_curcop->cop_arybase = 0;
2898 if (saveop && saveop->op_flags & OPf_SPECIAL)
2899 PL_in_eval |= EVAL_KEEPERR;
2902 if (yyparse() || PL_error_count || !PL_eval_root) {
2903 SV **newsp; /* Used by POPBLOCK. */
2904 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2905 I32 optype = 0; /* Might be reset by POPEVAL. */
2910 op_free(PL_eval_root);
2911 PL_eval_root = Nullop;
2913 SP = PL_stack_base + POPMARK; /* pop original mark */
2915 POPBLOCK(cx,PL_curpm);
2920 if (optype == OP_REQUIRE) {
2921 const char* msg = SvPVx(ERRSV, n_a);
2922 SV *nsv = cx->blk_eval.old_namesv;
2923 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2925 DIE(aTHX_ "%sCompilation failed in require",
2926 *msg ? msg : "Unknown error\n");
2929 const char* msg = SvPVx(ERRSV, n_a);
2931 POPBLOCK(cx,PL_curpm);
2933 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2934 (*msg ? msg : "Unknown error\n"));
2937 const char* msg = SvPVx(ERRSV, n_a);
2939 sv_setpv(ERRSV, "Compilation error");
2944 CopLINE_set(&PL_compiling, 0);
2946 *startop = PL_eval_root;
2948 SAVEFREEOP(PL_eval_root);
2950 /* Set the context for this new optree.
2951 * If the last op is an OP_REQUIRE, force scalar context.
2952 * Otherwise, propagate the context from the eval(). */
2953 if (PL_eval_root->op_type == OP_LEAVEEVAL
2954 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2955 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2957 scalar(PL_eval_root);
2958 else if (gimme & G_VOID)
2959 scalarvoid(PL_eval_root);
2960 else if (gimme & G_ARRAY)
2963 scalar(PL_eval_root);
2965 DEBUG_x(dump_eval());
2967 /* Register with debugger: */
2968 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2969 CV *cv = get_cv("DB::postponed", FALSE);
2973 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2975 call_sv((SV*)cv, G_DISCARD);
2979 /* compiled okay, so do it */
2981 CvDEPTH(PL_compcv) = 1;
2982 SP = PL_stack_base + POPMARK; /* pop original mark */
2983 PL_op = saveop; /* The caller may need it. */
2984 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2986 RETURNOP(PL_eval_start);
2990 S_doopen_pm(pTHX_ const char *name, const char *mode)
2992 #ifndef PERL_DISABLE_PMC
2993 STRLEN namelen = strlen(name);
2996 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2997 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2998 const char * const pmc = SvPV_nolen(pmcsv);
3001 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3002 fp = PerlIO_open(name, mode);
3005 if (PerlLIO_stat(name, &pmstat) < 0 ||
3006 pmstat.st_mtime < pmcstat.st_mtime)
3008 fp = PerlIO_open(pmc, mode);
3011 fp = PerlIO_open(name, mode);
3014 SvREFCNT_dec(pmcsv);
3017 fp = PerlIO_open(name, mode);
3021 return PerlIO_open(name, mode);
3022 #endif /* !PERL_DISABLE_PMC */
3028 register PERL_CONTEXT *cx;
3032 char *tryname = Nullch;
3033 SV *namesv = Nullsv;
3035 I32 gimme = GIMME_V;
3036 PerlIO *tryrsfp = 0;
3038 int filter_has_file = 0;
3039 GV *filter_child_proc = 0;
3040 SV *filter_state = 0;
3047 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3048 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3049 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3050 "v-string in use/require non-portable");
3052 sv = new_version(sv);
3053 if (!sv_derived_from(PL_patchlevel, "version"))
3054 (void *)upg_version(PL_patchlevel);
3055 if ( vcmp(sv,PL_patchlevel) > 0 )
3056 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3057 vstringify(sv), vstringify(PL_patchlevel));
3061 name = SvPV(sv, len);
3062 if (!(name && len > 0 && *name))
3063 DIE(aTHX_ "Null filename used");
3064 TAINT_PROPER("require");
3065 if (PL_op->op_type == OP_REQUIRE &&
3066 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3067 if (*svp != &PL_sv_undef)
3070 DIE(aTHX_ "Compilation failed in require");
3073 /* prepare to compile file */
3075 if (path_is_absolute(name)) {
3077 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3079 #ifdef MACOS_TRADITIONAL
3083 MacPerl_CanonDir(name, newname, 1);
3084 if (path_is_absolute(newname)) {
3086 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3091 AV *ar = GvAVn(PL_incgv);
3095 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3098 namesv = NEWSV(806, 0);
3099 for (i = 0; i <= AvFILL(ar); i++) {
3100 SV *dirsv = *av_fetch(ar, i, TRUE);
3106 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3107 && !sv_isobject(loader))
3109 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3112 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3113 PTR2UV(SvRV(dirsv)), name);
3114 tryname = SvPVX(namesv);
3125 if (sv_isobject(loader))
3126 count = call_method("INC", G_ARRAY);
3128 count = call_sv(loader, G_ARRAY);
3138 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3142 if (SvTYPE(arg) == SVt_PVGV) {
3143 IO *io = GvIO((GV *)arg);
3148 tryrsfp = IoIFP(io);
3149 if (IoTYPE(io) == IoTYPE_PIPE) {
3150 /* reading from a child process doesn't
3151 nest -- when returning from reading
3152 the inner module, the outer one is
3153 unreadable (closed?) I've tried to
3154 save the gv to manage the lifespan of
3155 the pipe, but this didn't help. XXX */
3156 filter_child_proc = (GV *)arg;
3157 (void)SvREFCNT_inc(filter_child_proc);
3160 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3161 PerlIO_close(IoOFP(io));
3173 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3175 (void)SvREFCNT_inc(filter_sub);
3178 filter_state = SP[i];
3179 (void)SvREFCNT_inc(filter_state);
3183 tryrsfp = PerlIO_open("/dev/null",
3199 filter_has_file = 0;
3200 if (filter_child_proc) {
3201 SvREFCNT_dec(filter_child_proc);
3202 filter_child_proc = 0;
3205 SvREFCNT_dec(filter_state);
3209 SvREFCNT_dec(filter_sub);
3214 if (!path_is_absolute(name)
3215 #ifdef MACOS_TRADITIONAL
3216 /* We consider paths of the form :a:b ambiguous and interpret them first
3217 as global then as local
3219 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3222 char *dir = SvPVx(dirsv, n_a);
3223 #ifdef MACOS_TRADITIONAL
3227 MacPerl_CanonDir(name, buf2, 1);
3228 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3232 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3234 sv_setpv(namesv, unixdir);
3235 sv_catpv(namesv, unixname);
3238 if (PL_origfilename[0] &&
3239 PL_origfilename[1] == ':' &&
3240 !(dir[0] && dir[1] == ':'))
3241 Perl_sv_setpvf(aTHX_ namesv,
3246 Perl_sv_setpvf(aTHX_ namesv,
3250 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3254 TAINT_PROPER("require");
3255 tryname = SvPVX(namesv);
3256 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3258 if (tryname[0] == '.' && tryname[1] == '/')
3267 SAVECOPFILE_FREE(&PL_compiling);
3268 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3269 SvREFCNT_dec(namesv);
3271 if (PL_op->op_type == OP_REQUIRE) {
3272 char *msgstr = name;
3273 if (namesv) { /* did we lookup @INC? */
3274 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3275 SV *dirmsgsv = NEWSV(0, 0);
3276 AV *ar = GvAVn(PL_incgv);
3278 sv_catpvn(msg, " in @INC", 8);
3279 if (instr(SvPVX(msg), ".h "))
3280 sv_catpv(msg, " (change .h to .ph maybe?)");
3281 if (instr(SvPVX(msg), ".ph "))
3282 sv_catpv(msg, " (did you run h2ph?)");
3283 sv_catpv(msg, " (@INC contains:");
3284 for (i = 0; i <= AvFILL(ar); i++) {
3285 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3286 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3287 sv_catsv(msg, dirmsgsv);
3289 sv_catpvn(msg, ")", 1);
3290 SvREFCNT_dec(dirmsgsv);
3291 msgstr = SvPV_nolen(msg);
3293 DIE(aTHX_ "Can't locate %s", msgstr);
3299 SETERRNO(0, SS_NORMAL);
3301 /* Assume success here to prevent recursive requirement. */
3303 /* Check whether a hook in @INC has already filled %INC */
3304 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3305 (void)hv_store(GvHVn(PL_incgv), name, len,
3306 (hook_sv ? SvREFCNT_inc(hook_sv)
3307 : newSVpv(CopFILE(&PL_compiling), 0)),
3313 lex_start(sv_2mortal(newSVpvn("",0)));
3314 SAVEGENERICSV(PL_rsfp_filters);
3315 PL_rsfp_filters = Nullav;
3320 SAVESPTR(PL_compiling.cop_warnings);
3321 if (PL_dowarn & G_WARN_ALL_ON)
3322 PL_compiling.cop_warnings = pWARN_ALL ;
3323 else if (PL_dowarn & G_WARN_ALL_OFF)
3324 PL_compiling.cop_warnings = pWARN_NONE ;
3325 else if (PL_taint_warn)
3326 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3328 PL_compiling.cop_warnings = pWARN_STD ;
3329 SAVESPTR(PL_compiling.cop_io);
3330 PL_compiling.cop_io = Nullsv;
3332 if (filter_sub || filter_child_proc) {
3333 SV *datasv = filter_add(run_user_filter, Nullsv);
3334 IoLINES(datasv) = filter_has_file;
3335 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3336 IoTOP_GV(datasv) = (GV *)filter_state;
3337 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3340 /* switch to eval mode */
3341 PUSHBLOCK(cx, CXt_EVAL, SP);
3342 PUSHEVAL(cx, name, Nullgv);
3343 cx->blk_eval.retop = PL_op->op_next;
3345 SAVECOPLINE(&PL_compiling);
3346 CopLINE_set(&PL_compiling, 0);
3350 /* Store and reset encoding. */
3351 encoding = PL_encoding;
3352 PL_encoding = Nullsv;
3354 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3356 /* Restore encoding. */
3357 PL_encoding = encoding;
3364 return pp_require();
3370 register PERL_CONTEXT *cx;
3372 I32 gimme = GIMME_V, was = PL_sub_generation;
3373 char tbuf[TYPE_DIGITS(long) + 12];
3374 char *tmpbuf = tbuf;
3383 TAINT_PROPER("eval");
3389 /* switch to eval mode */
3391 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3392 SV *sv = sv_newmortal();
3393 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3394 (unsigned long)++PL_evalseq,
3395 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3399 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3400 SAVECOPFILE_FREE(&PL_compiling);
3401 CopFILE_set(&PL_compiling, tmpbuf+2);
3402 SAVECOPLINE(&PL_compiling);
3403 CopLINE_set(&PL_compiling, 1);
3404 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3405 deleting the eval's FILEGV from the stash before gv_check() runs
3406 (i.e. before run-time proper). To work around the coredump that
3407 ensues, we always turn GvMULTI_on for any globals that were
3408 introduced within evals. See force_ident(). GSAR 96-10-12 */
3409 safestr = savepv(tmpbuf);
3410 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3412 PL_hints = PL_op->op_targ;
3413 SAVESPTR(PL_compiling.cop_warnings);
3414 if (specialWARN(PL_curcop->cop_warnings))
3415 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3417 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3418 SAVEFREESV(PL_compiling.cop_warnings);
3420 SAVESPTR(PL_compiling.cop_io);
3421 if (specialCopIO(PL_curcop->cop_io))
3422 PL_compiling.cop_io = PL_curcop->cop_io;
3424 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3425 SAVEFREESV(PL_compiling.cop_io);
3427 /* special case: an eval '' executed within the DB package gets lexically
3428 * placed in the first non-DB CV rather than the current CV - this
3429 * allows the debugger to execute code, find lexicals etc, in the
3430 * scope of the code being debugged. Passing &seq gets find_runcv
3431 * to do the dirty work for us */
3432 runcv = find_runcv(&seq);
3434 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3435 PUSHEVAL(cx, 0, Nullgv);
3436 cx->blk_eval.retop = PL_op->op_next;
3438 /* prepare to compile string */
3440 if (PERLDB_LINE && PL_curstash != PL_debstash)
3441 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3443 ret = doeval(gimme, NULL, runcv, seq);
3444 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3445 && ret != PL_op->op_next) { /* Successive compilation. */
3446 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3448 return DOCATCH(ret);
3458 register PERL_CONTEXT *cx;
3460 const U8 save_flags = PL_op -> op_flags;
3465 retop = cx->blk_eval.retop;
3468 if (gimme == G_VOID)
3470 else if (gimme == G_SCALAR) {
3473 if (SvFLAGS(TOPs) & SVs_TEMP)
3476 *MARK = sv_mortalcopy(TOPs);
3480 *MARK = &PL_sv_undef;
3485 /* in case LEAVE wipes old return values */
3486 for (mark = newsp + 1; mark <= SP; mark++) {
3487 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3488 *mark = sv_mortalcopy(*mark);
3489 TAINT_NOT; /* Each item is independent */
3493 PL_curpm = newpm; /* Don't pop $1 et al till now */
3496 assert(CvDEPTH(PL_compcv) == 1);
3498 CvDEPTH(PL_compcv) = 0;
3501 if (optype == OP_REQUIRE &&
3502 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3504 /* Unassume the success we assumed earlier. */
3505 SV *nsv = cx->blk_eval.old_namesv;
3506 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3507 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3508 /* die_where() did LEAVE, or we won't be here */
3512 if (!(save_flags & OPf_SPECIAL))
3522 register PERL_CONTEXT *cx;
3523 I32 gimme = GIMME_V;
3528 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3530 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3532 PL_in_eval = EVAL_INEVAL;
3535 return DOCATCH(PL_op->op_next);
3545 register PERL_CONTEXT *cx;
3552 if (gimme == G_VOID)
3554 else if (gimme == G_SCALAR) {
3557 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3560 *MARK = sv_mortalcopy(TOPs);
3564 *MARK = &PL_sv_undef;
3569 /* in case LEAVE wipes old return values */
3570 for (mark = newsp + 1; mark <= SP; mark++) {
3571 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3572 *mark = sv_mortalcopy(*mark);
3573 TAINT_NOT; /* Each item is independent */
3577 PL_curpm = newpm; /* Don't pop $1 et al till now */
3585 S_doparseform(pTHX_ SV *sv)
3588 register char *s = SvPV_force(sv, len);
3589 register char *send = s + len;
3590 register char *base = Nullch;
3591 register I32 skipspaces = 0;
3592 bool noblank = FALSE;
3593 bool repeat = FALSE;
3594 bool postspace = FALSE;
3600 bool unchopnum = FALSE;
3601 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3604 Perl_croak(aTHX_ "Null picture in formline");
3606 /* estimate the buffer size needed */
3607 for (base = s; s <= send; s++) {
3608 if (*s == '\n' || *s == '@' || *s == '^')
3614 New(804, fops, maxops, U32);
3619 *fpc++ = FF_LINEMARK;
3620 noblank = repeat = FALSE;
3638 case ' ': case '\t':
3645 } /* else FALL THROUGH */
3653 *fpc++ = FF_LITERAL;
3661 *fpc++ = (U16)skipspaces;
3665 *fpc++ = FF_NEWLINE;
3669 arg = fpc - linepc + 1;
3676 *fpc++ = FF_LINEMARK;
3677 noblank = repeat = FALSE;
3686 ischop = s[-1] == '^';
3692 arg = (s - base) - 1;
3694 *fpc++ = FF_LITERAL;
3702 *fpc++ = 2; /* skip the @* or ^* */
3704 *fpc++ = FF_LINESNGL;
3707 *fpc++ = FF_LINEGLOB;
3709 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3710 arg = ischop ? 512 : 0;
3715 const char * const f = ++s;
3718 arg |= 256 + (s - f);
3720 *fpc++ = s - base; /* fieldsize for FETCH */
3721 *fpc++ = FF_DECIMAL;
3723 unchopnum |= ! ischop;
3725 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3726 arg = ischop ? 512 : 0;
3728 s++; /* skip the '0' first */
3732 const char * const f = ++s;
3735 arg |= 256 + (s - f);
3737 *fpc++ = s - base; /* fieldsize for FETCH */
3738 *fpc++ = FF_0DECIMAL;
3740 unchopnum |= ! ischop;
3744 bool ismore = FALSE;
3747 while (*++s == '>') ;
3748 prespace = FF_SPACE;
3750 else if (*s == '|') {
3751 while (*++s == '|') ;
3752 prespace = FF_HALFSPACE;
3757 while (*++s == '<') ;
3760 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3764 *fpc++ = s - base; /* fieldsize for FETCH */
3766 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3769 *fpc++ = (U16)prespace;
3783 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3785 { /* need to jump to the next word */
3787 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3788 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3789 s = SvPVX(sv) + SvCUR(sv) + z;
3791 Copy(fops, s, arg, U32);
3793 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3796 if (unchopnum && repeat)
3797 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3803 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3805 /* Can value be printed in fldsize chars, using %*.*f ? */
3809 int intsize = fldsize - (value < 0 ? 1 : 0);
3816 while (intsize--) pwr *= 10.0;
3817 while (frcsize--) eps /= 10.0;
3820 if (value + eps >= pwr)
3823 if (value - eps <= -pwr)
3830 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3833 SV *datasv = FILTER_DATA(idx);
3834 int filter_has_file = IoLINES(datasv);
3835 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3836 SV *filter_state = (SV *)IoTOP_GV(datasv);
3837 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3840 /* I was having segfault trouble under Linux 2.2.5 after a
3841 parse error occured. (Had to hack around it with a test
3842 for PL_error_count == 0.) Solaris doesn't segfault --
3843 not sure where the trouble is yet. XXX */
3845 if (filter_has_file) {
3846 len = FILTER_READ(idx+1, buf_sv, maxlen);
3849 if (filter_sub && len >= 0) {
3860 PUSHs(sv_2mortal(newSViv(maxlen)));
3862 PUSHs(filter_state);
3865 count = call_sv(filter_sub, G_SCALAR);
3881 IoLINES(datasv) = 0;
3882 if (filter_child_proc) {
3883 SvREFCNT_dec(filter_child_proc);
3884 IoFMT_GV(datasv) = Nullgv;
3887 SvREFCNT_dec(filter_state);
3888 IoTOP_GV(datasv) = Nullgv;
3891 SvREFCNT_dec(filter_sub);
3892 IoBOTTOM_GV(datasv) = Nullgv;
3894 filter_del(run_user_filter);
3900 /* perhaps someone can come up with a better name for
3901 this? it is not really "absolute", per se ... */
3903 S_path_is_absolute(pTHX_ const char *name)
3905 if (PERL_FILE_IS_ABSOLUTE(name)
3906 #ifdef MACOS_TRADITIONAL
3909 || (*name == '.' && (name[1] == '/' ||
3910 (name[1] == '.' && name[2] == '/'))))
3921 * c-indentation-style: bsd
3923 * indent-tabs-mode: t
3926 * vim: shiftwidth=4: