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;
2687 assert(CATCH_GET == TRUE);
2694 assert(cxstack_ix >= 0);
2695 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2696 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2701 /* die caught by an inner eval - continue inner loop */
2703 /* NB XXX we rely on the old popped CxEVAL still being at the top
2704 * of the stack; the way die_where() currently works, this
2705 * assumption is valid. In theory The cur_top_env value should be
2706 * returned in another global, the way retop (aka PL_restartop)
2708 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2711 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2713 PL_op = PL_restartop;
2730 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2731 /* sv Text to convert to OP tree. */
2732 /* startop op_free() this to undo. */
2733 /* code Short string id of the caller. */
2735 dVAR; dSP; /* Make POPBLOCK work. */
2738 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2742 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2743 char *tmpbuf = tbuf;
2746 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2751 /* switch to eval mode */
2753 if (IN_PERL_COMPILETIME) {
2754 SAVECOPSTASH_FREE(&PL_compiling);
2755 CopSTASH_set(&PL_compiling, PL_curstash);
2757 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2758 SV *sv = sv_newmortal();
2759 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2760 code, (unsigned long)++PL_evalseq,
2761 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2765 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2766 SAVECOPFILE_FREE(&PL_compiling);
2767 CopFILE_set(&PL_compiling, tmpbuf+2);
2768 SAVECOPLINE(&PL_compiling);
2769 CopLINE_set(&PL_compiling, 1);
2770 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2771 deleting the eval's FILEGV from the stash before gv_check() runs
2772 (i.e. before run-time proper). To work around the coredump that
2773 ensues, we always turn GvMULTI_on for any globals that were
2774 introduced within evals. See force_ident(). GSAR 96-10-12 */
2775 safestr = savepv(tmpbuf);
2776 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2778 #ifdef OP_IN_REGISTER
2784 /* we get here either during compilation, or via pp_regcomp at runtime */
2785 runtime = IN_PERL_RUNTIME;
2787 runcv = find_runcv(NULL);
2790 PL_op->op_type = OP_ENTEREVAL;
2791 PL_op->op_flags = 0; /* Avoid uninit warning. */
2792 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2793 PUSHEVAL(cx, 0, Nullgv);
2796 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2798 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2799 POPBLOCK(cx,PL_curpm);
2802 (*startop)->op_type = OP_NULL;
2803 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2805 /* XXX DAPM do this properly one year */
2806 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2808 if (IN_PERL_COMPILETIME)
2809 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2810 #ifdef OP_IN_REGISTER
2818 =for apidoc find_runcv
2820 Locate the CV corresponding to the currently executing sub or eval.
2821 If db_seqp is non_null, skip CVs that are in the DB package and populate
2822 *db_seqp with the cop sequence number at the point that the DB:: code was
2823 entered. (allows debuggers to eval in the scope of the breakpoint rather
2824 than in in the scope of the debugger itself).
2830 Perl_find_runcv(pTHX_ U32 *db_seqp)
2835 *db_seqp = PL_curcop->cop_seq;
2836 for (si = PL_curstackinfo; si; si = si->si_prev) {
2838 for (ix = si->si_cxix; ix >= 0; ix--) {
2839 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2840 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2841 CV *cv = cx->blk_sub.cv;
2842 /* skip DB:: code */
2843 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2844 *db_seqp = cx->blk_oldcop->cop_seq;
2849 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2857 /* Compile a require/do, an eval '', or a /(?{...})/.
2858 * In the last case, startop is non-null, and contains the address of
2859 * a pointer that should be set to the just-compiled code.
2860 * outside is the lexically enclosing CV (if any) that invoked us.
2863 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2865 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2870 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2871 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2876 SAVESPTR(PL_compcv);
2877 PL_compcv = (CV*)NEWSV(1104,0);
2878 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2879 CvEVAL_on(PL_compcv);
2880 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2881 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2883 CvOUTSIDE_SEQ(PL_compcv) = seq;
2884 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2886 /* set up a scratch pad */
2888 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2891 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2893 /* make sure we compile in the right package */
2895 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2896 SAVESPTR(PL_curstash);
2897 PL_curstash = CopSTASH(PL_curcop);
2899 SAVESPTR(PL_beginav);
2900 PL_beginav = newAV();
2901 SAVEFREESV(PL_beginav);
2902 SAVEI32(PL_error_count);
2904 /* try to compile it */
2906 PL_eval_root = Nullop;
2908 PL_curcop = &PL_compiling;
2909 PL_curcop->cop_arybase = 0;
2910 if (saveop && saveop->op_flags & OPf_SPECIAL)
2911 PL_in_eval |= EVAL_KEEPERR;
2914 if (yyparse() || PL_error_count || !PL_eval_root) {
2915 SV **newsp; /* Used by POPBLOCK. */
2916 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2917 I32 optype = 0; /* Might be reset by POPEVAL. */
2922 op_free(PL_eval_root);
2923 PL_eval_root = Nullop;
2925 SP = PL_stack_base + POPMARK; /* pop original mark */
2927 POPBLOCK(cx,PL_curpm);
2932 if (optype == OP_REQUIRE) {
2933 const char* msg = SvPVx(ERRSV, n_a);
2934 SV *nsv = cx->blk_eval.old_namesv;
2935 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2937 DIE(aTHX_ "%sCompilation failed in require",
2938 *msg ? msg : "Unknown error\n");
2941 const char* msg = SvPVx(ERRSV, n_a);
2943 POPBLOCK(cx,PL_curpm);
2945 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2946 (*msg ? msg : "Unknown error\n"));
2949 const char* msg = SvPVx(ERRSV, n_a);
2951 sv_setpv(ERRSV, "Compilation error");
2956 CopLINE_set(&PL_compiling, 0);
2958 *startop = PL_eval_root;
2960 SAVEFREEOP(PL_eval_root);
2962 /* Set the context for this new optree.
2963 * If the last op is an OP_REQUIRE, force scalar context.
2964 * Otherwise, propagate the context from the eval(). */
2965 if (PL_eval_root->op_type == OP_LEAVEEVAL
2966 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2967 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2969 scalar(PL_eval_root);
2970 else if (gimme & G_VOID)
2971 scalarvoid(PL_eval_root);
2972 else if (gimme & G_ARRAY)
2975 scalar(PL_eval_root);
2977 DEBUG_x(dump_eval());
2979 /* Register with debugger: */
2980 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2981 CV *cv = get_cv("DB::postponed", FALSE);
2985 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2987 call_sv((SV*)cv, G_DISCARD);
2991 /* compiled okay, so do it */
2993 CvDEPTH(PL_compcv) = 1;
2994 SP = PL_stack_base + POPMARK; /* pop original mark */
2995 PL_op = saveop; /* The caller may need it. */
2996 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2998 RETURNOP(PL_eval_start);
3002 S_doopen_pm(pTHX_ const char *name, const char *mode)
3004 #ifndef PERL_DISABLE_PMC
3005 STRLEN namelen = strlen(name);
3008 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3009 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3010 const char * const pmc = SvPV_nolen(pmcsv);
3013 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3014 fp = PerlIO_open(name, mode);
3017 if (PerlLIO_stat(name, &pmstat) < 0 ||
3018 pmstat.st_mtime < pmcstat.st_mtime)
3020 fp = PerlIO_open(pmc, mode);
3023 fp = PerlIO_open(name, mode);
3026 SvREFCNT_dec(pmcsv);
3029 fp = PerlIO_open(name, mode);
3033 return PerlIO_open(name, mode);
3034 #endif /* !PERL_DISABLE_PMC */
3040 register PERL_CONTEXT *cx;
3044 char *tryname = Nullch;
3045 SV *namesv = Nullsv;
3047 I32 gimme = GIMME_V;
3048 PerlIO *tryrsfp = 0;
3050 int filter_has_file = 0;
3051 GV *filter_child_proc = 0;
3052 SV *filter_state = 0;
3059 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3060 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3061 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3062 "v-string in use/require non-portable");
3064 sv = new_version(sv);
3065 if (!sv_derived_from(PL_patchlevel, "version"))
3066 (void *)upg_version(PL_patchlevel);
3067 if ( vcmp(sv,PL_patchlevel) > 0 )
3068 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3069 vstringify(sv), vstringify(PL_patchlevel));
3073 name = SvPV(sv, len);
3074 if (!(name && len > 0 && *name))
3075 DIE(aTHX_ "Null filename used");
3076 TAINT_PROPER("require");
3077 if (PL_op->op_type == OP_REQUIRE &&
3078 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3079 if (*svp != &PL_sv_undef)
3082 DIE(aTHX_ "Compilation failed in require");
3085 /* prepare to compile file */
3087 if (path_is_absolute(name)) {
3089 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3091 #ifdef MACOS_TRADITIONAL
3095 MacPerl_CanonDir(name, newname, 1);
3096 if (path_is_absolute(newname)) {
3098 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3103 AV *ar = GvAVn(PL_incgv);
3107 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3110 namesv = NEWSV(806, 0);
3111 for (i = 0; i <= AvFILL(ar); i++) {
3112 SV *dirsv = *av_fetch(ar, i, TRUE);
3118 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3119 && !sv_isobject(loader))
3121 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3124 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3125 PTR2UV(SvRV(dirsv)), name);
3126 tryname = SvPVX(namesv);
3137 if (sv_isobject(loader))
3138 count = call_method("INC", G_ARRAY);
3140 count = call_sv(loader, G_ARRAY);
3150 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3154 if (SvTYPE(arg) == SVt_PVGV) {
3155 IO *io = GvIO((GV *)arg);
3160 tryrsfp = IoIFP(io);
3161 if (IoTYPE(io) == IoTYPE_PIPE) {
3162 /* reading from a child process doesn't
3163 nest -- when returning from reading
3164 the inner module, the outer one is
3165 unreadable (closed?) I've tried to
3166 save the gv to manage the lifespan of
3167 the pipe, but this didn't help. XXX */
3168 filter_child_proc = (GV *)arg;
3169 (void)SvREFCNT_inc(filter_child_proc);
3172 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3173 PerlIO_close(IoOFP(io));
3185 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3187 (void)SvREFCNT_inc(filter_sub);
3190 filter_state = SP[i];
3191 (void)SvREFCNT_inc(filter_state);
3195 tryrsfp = PerlIO_open("/dev/null",
3211 filter_has_file = 0;
3212 if (filter_child_proc) {
3213 SvREFCNT_dec(filter_child_proc);
3214 filter_child_proc = 0;
3217 SvREFCNT_dec(filter_state);
3221 SvREFCNT_dec(filter_sub);
3226 if (!path_is_absolute(name)
3227 #ifdef MACOS_TRADITIONAL
3228 /* We consider paths of the form :a:b ambiguous and interpret them first
3229 as global then as local
3231 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3234 char *dir = SvPVx(dirsv, n_a);
3235 #ifdef MACOS_TRADITIONAL
3239 MacPerl_CanonDir(name, buf2, 1);
3240 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3244 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3246 sv_setpv(namesv, unixdir);
3247 sv_catpv(namesv, unixname);
3250 if (PL_origfilename[0] &&
3251 PL_origfilename[1] == ':' &&
3252 !(dir[0] && dir[1] == ':'))
3253 Perl_sv_setpvf(aTHX_ namesv,
3258 Perl_sv_setpvf(aTHX_ namesv,
3262 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3266 TAINT_PROPER("require");
3267 tryname = SvPVX(namesv);
3268 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3270 if (tryname[0] == '.' && tryname[1] == '/')
3279 SAVECOPFILE_FREE(&PL_compiling);
3280 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3281 SvREFCNT_dec(namesv);
3283 if (PL_op->op_type == OP_REQUIRE) {
3284 char *msgstr = name;
3285 if (namesv) { /* did we lookup @INC? */
3286 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3287 SV *dirmsgsv = NEWSV(0, 0);
3288 AV *ar = GvAVn(PL_incgv);
3290 sv_catpvn(msg, " in @INC", 8);
3291 if (instr(SvPVX(msg), ".h "))
3292 sv_catpv(msg, " (change .h to .ph maybe?)");
3293 if (instr(SvPVX(msg), ".ph "))
3294 sv_catpv(msg, " (did you run h2ph?)");
3295 sv_catpv(msg, " (@INC contains:");
3296 for (i = 0; i <= AvFILL(ar); i++) {
3297 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3298 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3299 sv_catsv(msg, dirmsgsv);
3301 sv_catpvn(msg, ")", 1);
3302 SvREFCNT_dec(dirmsgsv);
3303 msgstr = SvPV_nolen(msg);
3305 DIE(aTHX_ "Can't locate %s", msgstr);
3311 SETERRNO(0, SS_NORMAL);
3313 /* Assume success here to prevent recursive requirement. */
3315 /* Check whether a hook in @INC has already filled %INC */
3316 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3317 (void)hv_store(GvHVn(PL_incgv), name, len,
3318 (hook_sv ? SvREFCNT_inc(hook_sv)
3319 : newSVpv(CopFILE(&PL_compiling), 0)),
3325 lex_start(sv_2mortal(newSVpvn("",0)));
3326 SAVEGENERICSV(PL_rsfp_filters);
3327 PL_rsfp_filters = Nullav;
3332 SAVESPTR(PL_compiling.cop_warnings);
3333 if (PL_dowarn & G_WARN_ALL_ON)
3334 PL_compiling.cop_warnings = pWARN_ALL ;
3335 else if (PL_dowarn & G_WARN_ALL_OFF)
3336 PL_compiling.cop_warnings = pWARN_NONE ;
3337 else if (PL_taint_warn)
3338 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3340 PL_compiling.cop_warnings = pWARN_STD ;
3341 SAVESPTR(PL_compiling.cop_io);
3342 PL_compiling.cop_io = Nullsv;
3344 if (filter_sub || filter_child_proc) {
3345 SV *datasv = filter_add(run_user_filter, Nullsv);
3346 IoLINES(datasv) = filter_has_file;
3347 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3348 IoTOP_GV(datasv) = (GV *)filter_state;
3349 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3352 /* switch to eval mode */
3353 PUSHBLOCK(cx, CXt_EVAL, SP);
3354 PUSHEVAL(cx, name, Nullgv);
3355 cx->blk_eval.retop = PL_op->op_next;
3357 SAVECOPLINE(&PL_compiling);
3358 CopLINE_set(&PL_compiling, 0);
3362 /* Store and reset encoding. */
3363 encoding = PL_encoding;
3364 PL_encoding = Nullsv;
3366 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3368 /* Restore encoding. */
3369 PL_encoding = encoding;
3376 return pp_require();
3382 register PERL_CONTEXT *cx;
3384 I32 gimme = GIMME_V, was = PL_sub_generation;
3385 char tbuf[TYPE_DIGITS(long) + 12];
3386 char *tmpbuf = tbuf;
3395 TAINT_PROPER("eval");
3401 /* switch to eval mode */
3403 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3404 SV *sv = sv_newmortal();
3405 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3406 (unsigned long)++PL_evalseq,
3407 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3411 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3412 SAVECOPFILE_FREE(&PL_compiling);
3413 CopFILE_set(&PL_compiling, tmpbuf+2);
3414 SAVECOPLINE(&PL_compiling);
3415 CopLINE_set(&PL_compiling, 1);
3416 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3417 deleting the eval's FILEGV from the stash before gv_check() runs
3418 (i.e. before run-time proper). To work around the coredump that
3419 ensues, we always turn GvMULTI_on for any globals that were
3420 introduced within evals. See force_ident(). GSAR 96-10-12 */
3421 safestr = savepv(tmpbuf);
3422 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3424 PL_hints = PL_op->op_targ;
3425 SAVESPTR(PL_compiling.cop_warnings);
3426 if (specialWARN(PL_curcop->cop_warnings))
3427 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3429 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3430 SAVEFREESV(PL_compiling.cop_warnings);
3432 SAVESPTR(PL_compiling.cop_io);
3433 if (specialCopIO(PL_curcop->cop_io))
3434 PL_compiling.cop_io = PL_curcop->cop_io;
3436 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3437 SAVEFREESV(PL_compiling.cop_io);
3439 /* special case: an eval '' executed within the DB package gets lexically
3440 * placed in the first non-DB CV rather than the current CV - this
3441 * allows the debugger to execute code, find lexicals etc, in the
3442 * scope of the code being debugged. Passing &seq gets find_runcv
3443 * to do the dirty work for us */
3444 runcv = find_runcv(&seq);
3446 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3447 PUSHEVAL(cx, 0, Nullgv);
3448 cx->blk_eval.retop = PL_op->op_next;
3450 /* prepare to compile string */
3452 if (PERLDB_LINE && PL_curstash != PL_debstash)
3453 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3455 ret = doeval(gimme, NULL, runcv, seq);
3456 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3457 && ret != PL_op->op_next) { /* Successive compilation. */
3458 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3460 return DOCATCH(ret);
3470 register PERL_CONTEXT *cx;
3472 const U8 save_flags = PL_op -> op_flags;
3477 retop = cx->blk_eval.retop;
3480 if (gimme == G_VOID)
3482 else if (gimme == G_SCALAR) {
3485 if (SvFLAGS(TOPs) & SVs_TEMP)
3488 *MARK = sv_mortalcopy(TOPs);
3492 *MARK = &PL_sv_undef;
3497 /* in case LEAVE wipes old return values */
3498 for (mark = newsp + 1; mark <= SP; mark++) {
3499 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3500 *mark = sv_mortalcopy(*mark);
3501 TAINT_NOT; /* Each item is independent */
3505 PL_curpm = newpm; /* Don't pop $1 et al till now */
3508 assert(CvDEPTH(PL_compcv) == 1);
3510 CvDEPTH(PL_compcv) = 0;
3513 if (optype == OP_REQUIRE &&
3514 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3516 /* Unassume the success we assumed earlier. */
3517 SV *nsv = cx->blk_eval.old_namesv;
3518 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3519 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3520 /* die_where() did LEAVE, or we won't be here */
3524 if (!(save_flags & OPf_SPECIAL))
3534 register PERL_CONTEXT *cx;
3535 I32 gimme = GIMME_V;
3540 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3542 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3544 PL_in_eval = EVAL_INEVAL;
3547 return DOCATCH(PL_op->op_next);
3557 register PERL_CONTEXT *cx;
3564 if (gimme == G_VOID)
3566 else if (gimme == G_SCALAR) {
3569 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3572 *MARK = sv_mortalcopy(TOPs);
3576 *MARK = &PL_sv_undef;
3581 /* in case LEAVE wipes old return values */
3582 for (mark = newsp + 1; mark <= SP; mark++) {
3583 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3584 *mark = sv_mortalcopy(*mark);
3585 TAINT_NOT; /* Each item is independent */
3589 PL_curpm = newpm; /* Don't pop $1 et al till now */
3597 S_doparseform(pTHX_ SV *sv)
3600 register char *s = SvPV_force(sv, len);
3601 register char *send = s + len;
3602 register char *base = Nullch;
3603 register I32 skipspaces = 0;
3604 bool noblank = FALSE;
3605 bool repeat = FALSE;
3606 bool postspace = FALSE;
3612 bool unchopnum = FALSE;
3613 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3616 Perl_croak(aTHX_ "Null picture in formline");
3618 /* estimate the buffer size needed */
3619 for (base = s; s <= send; s++) {
3620 if (*s == '\n' || *s == '@' || *s == '^')
3626 New(804, fops, maxops, U32);
3631 *fpc++ = FF_LINEMARK;
3632 noblank = repeat = FALSE;
3650 case ' ': case '\t':
3657 } /* else FALL THROUGH */
3665 *fpc++ = FF_LITERAL;
3673 *fpc++ = (U16)skipspaces;
3677 *fpc++ = FF_NEWLINE;
3681 arg = fpc - linepc + 1;
3688 *fpc++ = FF_LINEMARK;
3689 noblank = repeat = FALSE;
3698 ischop = s[-1] == '^';
3704 arg = (s - base) - 1;
3706 *fpc++ = FF_LITERAL;
3714 *fpc++ = 2; /* skip the @* or ^* */
3716 *fpc++ = FF_LINESNGL;
3719 *fpc++ = FF_LINEGLOB;
3721 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3722 arg = ischop ? 512 : 0;
3727 const char * const f = ++s;
3730 arg |= 256 + (s - f);
3732 *fpc++ = s - base; /* fieldsize for FETCH */
3733 *fpc++ = FF_DECIMAL;
3735 unchopnum |= ! ischop;
3737 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3738 arg = ischop ? 512 : 0;
3740 s++; /* skip the '0' first */
3744 const char * const f = ++s;
3747 arg |= 256 + (s - f);
3749 *fpc++ = s - base; /* fieldsize for FETCH */
3750 *fpc++ = FF_0DECIMAL;
3752 unchopnum |= ! ischop;
3756 bool ismore = FALSE;
3759 while (*++s == '>') ;
3760 prespace = FF_SPACE;
3762 else if (*s == '|') {
3763 while (*++s == '|') ;
3764 prespace = FF_HALFSPACE;
3769 while (*++s == '<') ;
3772 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3776 *fpc++ = s - base; /* fieldsize for FETCH */
3778 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3781 *fpc++ = (U16)prespace;
3795 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3797 { /* need to jump to the next word */
3799 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3800 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3801 s = SvPVX(sv) + SvCUR(sv) + z;
3803 Copy(fops, s, arg, U32);
3805 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3808 if (unchopnum && repeat)
3809 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3815 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3817 /* Can value be printed in fldsize chars, using %*.*f ? */
3821 int intsize = fldsize - (value < 0 ? 1 : 0);
3828 while (intsize--) pwr *= 10.0;
3829 while (frcsize--) eps /= 10.0;
3832 if (value + eps >= pwr)
3835 if (value - eps <= -pwr)
3842 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3845 SV *datasv = FILTER_DATA(idx);
3846 int filter_has_file = IoLINES(datasv);
3847 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3848 SV *filter_state = (SV *)IoTOP_GV(datasv);
3849 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3852 /* I was having segfault trouble under Linux 2.2.5 after a
3853 parse error occured. (Had to hack around it with a test
3854 for PL_error_count == 0.) Solaris doesn't segfault --
3855 not sure where the trouble is yet. XXX */
3857 if (filter_has_file) {
3858 len = FILTER_READ(idx+1, buf_sv, maxlen);
3861 if (filter_sub && len >= 0) {
3872 PUSHs(sv_2mortal(newSViv(maxlen)));
3874 PUSHs(filter_state);
3877 count = call_sv(filter_sub, G_SCALAR);
3893 IoLINES(datasv) = 0;
3894 if (filter_child_proc) {
3895 SvREFCNT_dec(filter_child_proc);
3896 IoFMT_GV(datasv) = Nullgv;
3899 SvREFCNT_dec(filter_state);
3900 IoTOP_GV(datasv) = Nullgv;
3903 SvREFCNT_dec(filter_sub);
3904 IoBOTTOM_GV(datasv) = Nullgv;
3906 filter_del(run_user_filter);
3912 /* perhaps someone can come up with a better name for
3913 this? it is not really "absolute", per se ... */
3915 S_path_is_absolute(pTHX_ const char *name)
3917 if (PERL_FILE_IS_ABSOLUTE(name)
3918 #ifdef MACOS_TRADITIONAL
3921 || (*name == '.' && (name[1] == '/' ||
3922 (name[1] == '.' && name[2] == '/'))))
3933 * c-indentation-style: bsd
3935 * indent-tabs-mode: t
3938 * vim: shiftwidth=4: