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;
1893 assert(CxTYPE(cx) == CXt_LOOP);
1895 newsp = PL_stack_base + cx->blk_loop.resetsp;
1898 if (gimme == G_VOID)
1900 else if (gimme == G_SCALAR) {
1902 *++newsp = sv_mortalcopy(*SP);
1904 *++newsp = &PL_sv_undef;
1908 *++newsp = sv_mortalcopy(*++mark);
1909 TAINT_NOT; /* Each item is independent */
1915 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1916 PL_curpm = newpm; /* ... and pop $1 et al */
1928 register PERL_CONTEXT *cx;
1929 bool popsub2 = FALSE;
1930 bool clear_errsv = FALSE;
1938 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1939 if (cxstack_ix == PL_sortcxix
1940 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1942 if (cxstack_ix > PL_sortcxix)
1943 dounwind(PL_sortcxix);
1944 AvARRAY(PL_curstack)[1] = *SP;
1945 PL_stack_sp = PL_stack_base + 1;
1950 cxix = dopoptosub(cxstack_ix);
1952 DIE(aTHX_ "Can't return outside a subroutine");
1953 if (cxix < cxstack_ix)
1957 switch (CxTYPE(cx)) {
1960 retop = cx->blk_sub.retop;
1961 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1964 if (!(PL_in_eval & EVAL_KEEPERR))
1967 retop = cx->blk_eval.retop;
1971 if (optype == OP_REQUIRE &&
1972 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1974 /* Unassume the success we assumed earlier. */
1975 SV *nsv = cx->blk_eval.old_namesv;
1976 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1977 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1982 retop = cx->blk_sub.retop;
1985 DIE(aTHX_ "panic: return");
1989 if (gimme == G_SCALAR) {
1992 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1994 *++newsp = SvREFCNT_inc(*SP);
1999 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2001 *++newsp = sv_mortalcopy(sv);
2006 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2009 *++newsp = sv_mortalcopy(*SP);
2012 *++newsp = &PL_sv_undef;
2014 else if (gimme == G_ARRAY) {
2015 while (++MARK <= SP) {
2016 *++newsp = (popsub2 && SvTEMP(*MARK))
2017 ? *MARK : sv_mortalcopy(*MARK);
2018 TAINT_NOT; /* Each item is independent */
2021 PL_stack_sp = newsp;
2024 /* Stack values are safe: */
2027 POPSUB(cx,sv); /* release CV and @_ ... */
2031 PL_curpm = newpm; /* ... and pop $1 et al */
2043 register PERL_CONTEXT *cx;
2053 if (PL_op->op_flags & OPf_SPECIAL) {
2054 cxix = dopoptoloop(cxstack_ix);
2056 DIE(aTHX_ "Can't \"last\" outside a loop block");
2059 cxix = dopoptolabel(cPVOP->op_pv);
2061 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2063 if (cxix < cxstack_ix)
2067 cxstack_ix++; /* temporarily protect top context */
2069 switch (CxTYPE(cx)) {
2072 newsp = PL_stack_base + cx->blk_loop.resetsp;
2073 nextop = cx->blk_loop.last_op->op_next;
2077 nextop = cx->blk_sub.retop;
2081 nextop = cx->blk_eval.retop;
2085 nextop = cx->blk_sub.retop;
2088 DIE(aTHX_ "panic: last");
2092 if (gimme == G_SCALAR) {
2094 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2095 ? *SP : sv_mortalcopy(*SP);
2097 *++newsp = &PL_sv_undef;
2099 else if (gimme == G_ARRAY) {
2100 while (++MARK <= SP) {
2101 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2102 ? *MARK : sv_mortalcopy(*MARK);
2103 TAINT_NOT; /* Each item is independent */
2111 /* Stack values are safe: */
2114 POPLOOP(cx); /* release loop vars ... */
2118 POPSUB(cx,sv); /* release CV and @_ ... */
2121 PL_curpm = newpm; /* ... and pop $1 et al */
2131 register PERL_CONTEXT *cx;
2134 if (PL_op->op_flags & OPf_SPECIAL) {
2135 cxix = dopoptoloop(cxstack_ix);
2137 DIE(aTHX_ "Can't \"next\" outside a loop block");
2140 cxix = dopoptolabel(cPVOP->op_pv);
2142 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2144 if (cxix < cxstack_ix)
2147 /* clear off anything above the scope we're re-entering, but
2148 * save the rest until after a possible continue block */
2149 inner = PL_scopestack_ix;
2151 if (PL_scopestack_ix < inner)
2152 leave_scope(PL_scopestack[PL_scopestack_ix]);
2153 PL_curcop = cx->blk_oldcop;
2154 return cx->blk_loop.next_op;
2161 register PERL_CONTEXT *cx;
2164 if (PL_op->op_flags & OPf_SPECIAL) {
2165 cxix = dopoptoloop(cxstack_ix);
2167 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2170 cxix = dopoptolabel(cPVOP->op_pv);
2172 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2174 if (cxix < cxstack_ix)
2178 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2179 LEAVE_SCOPE(oldsave);
2181 PL_curcop = cx->blk_oldcop;
2182 return cx->blk_loop.redo_op;
2186 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2190 static const char too_deep[] = "Target of goto is too deeply nested";
2193 Perl_croak(aTHX_ too_deep);
2194 if (o->op_type == OP_LEAVE ||
2195 o->op_type == OP_SCOPE ||
2196 o->op_type == OP_LEAVELOOP ||
2197 o->op_type == OP_LEAVESUB ||
2198 o->op_type == OP_LEAVETRY)
2200 *ops++ = cUNOPo->op_first;
2202 Perl_croak(aTHX_ too_deep);
2205 if (o->op_flags & OPf_KIDS) {
2206 /* First try all the kids at this level, since that's likeliest. */
2207 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2208 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2209 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2212 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2213 if (kid == PL_lastgotoprobe)
2215 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2218 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2219 ops[-1]->op_type == OP_DBSTATE)
2224 if ((o = dofindlabel(kid, label, ops, oplimit)))
2243 register PERL_CONTEXT *cx;
2244 #define GOTO_DEPTH 64
2245 OP *enterops[GOTO_DEPTH];
2246 const char *label = 0;
2247 const bool do_dump = (PL_op->op_type == OP_DUMP);
2248 static const char must_have_label[] = "goto must have label";
2250 if (PL_op->op_flags & OPf_STACKED) {
2254 /* This egregious kludge implements goto &subroutine */
2255 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2257 register PERL_CONTEXT *cx;
2258 CV* cv = (CV*)SvRV(sv);
2265 if (!CvROOT(cv) && !CvXSUB(cv)) {
2266 const GV * const gv = CvGV(cv);
2270 /* autoloaded stub? */
2271 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2273 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2274 GvNAMELEN(gv), FALSE);
2275 if (autogv && (cv = GvCV(autogv)))
2277 tmpstr = sv_newmortal();
2278 gv_efullname3(tmpstr, gv, Nullch);
2279 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2281 DIE(aTHX_ "Goto undefined subroutine");
2284 /* First do some returnish stuff. */
2285 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2287 cxix = dopoptosub(cxstack_ix);
2289 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2290 if (cxix < cxstack_ix)
2294 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2295 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2296 /* put @_ back onto stack */
2297 AV* av = cx->blk_sub.argarray;
2299 items = AvFILLp(av) + 1;
2300 EXTEND(SP, items+1); /* @_ could have been extended. */
2301 Copy(AvARRAY(av), SP + 1, items, SV*);
2302 SvREFCNT_dec(GvAV(PL_defgv));
2303 GvAV(PL_defgv) = cx->blk_sub.savearray;
2305 /* abandon @_ if it got reified */
2310 av_extend(av, items-1);
2311 AvFLAGS(av) = AVf_REIFY;
2312 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2315 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2317 av = GvAV(PL_defgv);
2318 items = AvFILLp(av) + 1;
2319 EXTEND(SP, items+1); /* @_ could have been extended. */
2320 Copy(AvARRAY(av), SP + 1, items, SV*);
2324 if (CxTYPE(cx) == CXt_SUB &&
2325 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2326 SvREFCNT_dec(cx->blk_sub.cv);
2327 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2328 LEAVE_SCOPE(oldsave);
2330 /* Now do some callish stuff. */
2332 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2336 for (index=0; index<items; index++)
2337 sv_2mortal(SP[-index]);
2339 #ifdef PERL_XSUB_OLDSTYLE
2340 if (CvOLDSTYLE(cv)) {
2341 I32 (*fp3)(int,int,int);
2346 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2347 items = (*fp3)(CvXSUBANY(cv).any_i32,
2348 mark - PL_stack_base + 1,
2350 SP = PL_stack_base + items;
2353 #endif /* PERL_XSUB_OLDSTYLE */
2358 /* Push a mark for the start of arglist */
2361 (void)(*CvXSUB(cv))(aTHX_ cv);
2362 /* Pop the current context like a decent sub should */
2363 POPBLOCK(cx, PL_curpm);
2364 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2367 assert(CxTYPE(cx) == CXt_SUB);
2368 return cx->blk_sub.retop;
2371 AV* padlist = CvPADLIST(cv);
2372 if (CxTYPE(cx) == CXt_EVAL) {
2373 PL_in_eval = cx->blk_eval.old_in_eval;
2374 PL_eval_root = cx->blk_eval.old_eval_root;
2375 cx->cx_type = CXt_SUB;
2376 cx->blk_sub.hasargs = 0;
2378 cx->blk_sub.cv = cv;
2379 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2382 if (CvDEPTH(cv) < 2)
2383 (void)SvREFCNT_inc(cv);
2385 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2386 sub_crush_depth(cv);
2387 pad_push(padlist, CvDEPTH(cv));
2389 PAD_SET_CUR(padlist, CvDEPTH(cv));
2390 if (cx->blk_sub.hasargs)
2392 AV* av = (AV*)PAD_SVl(0);
2395 cx->blk_sub.savearray = GvAV(PL_defgv);
2396 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2397 CX_CURPAD_SAVE(cx->blk_sub);
2398 cx->blk_sub.argarray = av;
2400 if (items >= AvMAX(av) + 1) {
2402 if (AvARRAY(av) != ary) {
2403 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2404 SvPV_set(av, (char*)ary);
2406 if (items >= AvMAX(av) + 1) {
2407 AvMAX(av) = items - 1;
2408 Renew(ary,items+1,SV*);
2410 SvPV_set(av, (char*)ary);
2414 Copy(mark,AvARRAY(av),items,SV*);
2415 AvFILLp(av) = items - 1;
2416 assert(!AvREAL(av));
2418 /* transfer 'ownership' of refcnts to new @_ */
2428 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2430 * We do not care about using sv to call CV;
2431 * it's for informational purposes only.
2433 SV *sv = GvSV(PL_DBsub);
2437 if (PERLDB_SUB_NN) {
2438 int type = SvTYPE(sv);
2439 if (type < SVt_PVIV && type != SVt_IV)
2440 sv_upgrade(sv, SVt_PVIV);
2442 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2444 gv_efullname3(sv, CvGV(cv), Nullch);
2447 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2448 PUSHMARK( PL_stack_sp );
2449 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2453 RETURNOP(CvSTART(cv));
2457 label = SvPV(sv,n_a);
2458 if (!(do_dump || *label))
2459 DIE(aTHX_ must_have_label);
2462 else if (PL_op->op_flags & OPf_SPECIAL) {
2464 DIE(aTHX_ must_have_label);
2467 label = cPVOP->op_pv;
2469 if (label && *label) {
2471 bool leaving_eval = FALSE;
2472 bool in_block = FALSE;
2473 PERL_CONTEXT *last_eval_cx = 0;
2477 PL_lastgotoprobe = 0;
2479 for (ix = cxstack_ix; ix >= 0; ix--) {
2481 switch (CxTYPE(cx)) {
2483 leaving_eval = TRUE;
2484 if (!CxTRYBLOCK(cx)) {
2485 gotoprobe = (last_eval_cx ?
2486 last_eval_cx->blk_eval.old_eval_root :
2491 /* else fall through */
2493 gotoprobe = cx->blk_oldcop->op_sibling;
2499 gotoprobe = cx->blk_oldcop->op_sibling;
2502 gotoprobe = PL_main_root;
2505 if (CvDEPTH(cx->blk_sub.cv)) {
2506 gotoprobe = CvROOT(cx->blk_sub.cv);
2512 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2515 DIE(aTHX_ "panic: goto");
2516 gotoprobe = PL_main_root;
2520 retop = dofindlabel(gotoprobe, label,
2521 enterops, enterops + GOTO_DEPTH);
2525 PL_lastgotoprobe = gotoprobe;
2528 DIE(aTHX_ "Can't find label %s", label);
2530 /* if we're leaving an eval, check before we pop any frames
2531 that we're not going to punt, otherwise the error
2534 if (leaving_eval && *enterops && enterops[1]) {
2536 for (i = 1; enterops[i]; i++)
2537 if (enterops[i]->op_type == OP_ENTERITER)
2538 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2541 /* pop unwanted frames */
2543 if (ix < cxstack_ix) {
2550 oldsave = PL_scopestack[PL_scopestack_ix];
2551 LEAVE_SCOPE(oldsave);
2554 /* push wanted frames */
2556 if (*enterops && enterops[1]) {
2558 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2559 for (; enterops[ix]; ix++) {
2560 PL_op = enterops[ix];
2561 /* Eventually we may want to stack the needed arguments
2562 * for each op. For now, we punt on the hard ones. */
2563 if (PL_op->op_type == OP_ENTERITER)
2564 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2565 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2573 if (!retop) retop = PL_main_start;
2575 PL_restartop = retop;
2576 PL_do_undump = TRUE;
2580 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2581 PL_do_undump = FALSE;
2597 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2599 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2602 PL_exit_flags |= PERL_EXIT_EXPECTED;
2604 PUSHs(&PL_sv_undef);
2612 NV value = SvNVx(GvSV(cCOP->cop_gv));
2613 register I32 match = I_32(value);
2616 if (((NV)match) > value)
2617 --match; /* was fractional--truncate other way */
2619 match -= cCOP->uop.scop.scop_offset;
2622 else if (match > cCOP->uop.scop.scop_max)
2623 match = cCOP->uop.scop.scop_max;
2624 PL_op = cCOP->uop.scop.scop_next[match];
2634 PL_op = PL_op->op_next; /* can't assume anything */
2637 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2638 match -= cCOP->uop.scop.scop_offset;
2641 else if (match > cCOP->uop.scop.scop_max)
2642 match = cCOP->uop.scop.scop_max;
2643 PL_op = cCOP->uop.scop.scop_next[match];
2652 S_save_lines(pTHX_ AV *array, SV *sv)
2654 register const char *s = SvPVX(sv);
2655 register const char *send = SvPVX(sv) + SvCUR(sv);
2656 register const char *t;
2657 register I32 line = 1;
2659 while (s && s < send) {
2660 SV *tmpstr = NEWSV(85,0);
2662 sv_upgrade(tmpstr, SVt_PVMG);
2663 t = strchr(s, '\n');
2669 sv_setpvn(tmpstr, s, t - s);
2670 av_store(array, line++, tmpstr);
2676 S_docatch_body(pTHX)
2683 S_docatch(pTHX_ OP *o)
2686 OP * const oldop = PL_op;
2690 assert(CATCH_GET == TRUE);
2697 assert(cxstack_ix >= 0);
2698 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2699 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2704 /* die caught by an inner eval - continue inner loop */
2706 /* NB XXX we rely on the old popped CxEVAL still being at the top
2707 * of the stack; the way die_where() currently works, this
2708 * assumption is valid. In theory The cur_top_env value should be
2709 * returned in another global, the way retop (aka PL_restartop)
2711 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2714 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2716 PL_op = PL_restartop;
2733 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2734 /* sv Text to convert to OP tree. */
2735 /* startop op_free() this to undo. */
2736 /* code Short string id of the caller. */
2738 dVAR; dSP; /* Make POPBLOCK work. */
2741 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2745 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2746 char *tmpbuf = tbuf;
2749 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2754 /* switch to eval mode */
2756 if (IN_PERL_COMPILETIME) {
2757 SAVECOPSTASH_FREE(&PL_compiling);
2758 CopSTASH_set(&PL_compiling, PL_curstash);
2760 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2761 SV *sv = sv_newmortal();
2762 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2763 code, (unsigned long)++PL_evalseq,
2764 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2768 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2769 SAVECOPFILE_FREE(&PL_compiling);
2770 CopFILE_set(&PL_compiling, tmpbuf+2);
2771 SAVECOPLINE(&PL_compiling);
2772 CopLINE_set(&PL_compiling, 1);
2773 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2774 deleting the eval's FILEGV from the stash before gv_check() runs
2775 (i.e. before run-time proper). To work around the coredump that
2776 ensues, we always turn GvMULTI_on for any globals that were
2777 introduced within evals. See force_ident(). GSAR 96-10-12 */
2778 safestr = savepv(tmpbuf);
2779 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2781 #ifdef OP_IN_REGISTER
2787 /* we get here either during compilation, or via pp_regcomp at runtime */
2788 runtime = IN_PERL_RUNTIME;
2790 runcv = find_runcv(NULL);
2793 PL_op->op_type = OP_ENTEREVAL;
2794 PL_op->op_flags = 0; /* Avoid uninit warning. */
2795 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2796 PUSHEVAL(cx, 0, Nullgv);
2799 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2801 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2802 POPBLOCK(cx,PL_curpm);
2805 (*startop)->op_type = OP_NULL;
2806 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2808 /* XXX DAPM do this properly one year */
2809 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2811 if (IN_PERL_COMPILETIME)
2812 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2813 #ifdef OP_IN_REGISTER
2821 =for apidoc find_runcv
2823 Locate the CV corresponding to the currently executing sub or eval.
2824 If db_seqp is non_null, skip CVs that are in the DB package and populate
2825 *db_seqp with the cop sequence number at the point that the DB:: code was
2826 entered. (allows debuggers to eval in the scope of the breakpoint rather
2827 than in in the scope of the debugger itself).
2833 Perl_find_runcv(pTHX_ U32 *db_seqp)
2838 *db_seqp = PL_curcop->cop_seq;
2839 for (si = PL_curstackinfo; si; si = si->si_prev) {
2841 for (ix = si->si_cxix; ix >= 0; ix--) {
2842 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2843 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2844 CV *cv = cx->blk_sub.cv;
2845 /* skip DB:: code */
2846 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2847 *db_seqp = cx->blk_oldcop->cop_seq;
2852 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2860 /* Compile a require/do, an eval '', or a /(?{...})/.
2861 * In the last case, startop is non-null, and contains the address of
2862 * a pointer that should be set to the just-compiled code.
2863 * outside is the lexically enclosing CV (if any) that invoked us.
2866 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2868 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2873 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2874 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2879 SAVESPTR(PL_compcv);
2880 PL_compcv = (CV*)NEWSV(1104,0);
2881 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2882 CvEVAL_on(PL_compcv);
2883 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2884 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2886 CvOUTSIDE_SEQ(PL_compcv) = seq;
2887 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2889 /* set up a scratch pad */
2891 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2894 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2896 /* make sure we compile in the right package */
2898 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2899 SAVESPTR(PL_curstash);
2900 PL_curstash = CopSTASH(PL_curcop);
2902 SAVESPTR(PL_beginav);
2903 PL_beginav = newAV();
2904 SAVEFREESV(PL_beginav);
2905 SAVEI32(PL_error_count);
2907 /* try to compile it */
2909 PL_eval_root = Nullop;
2911 PL_curcop = &PL_compiling;
2912 PL_curcop->cop_arybase = 0;
2913 if (saveop && saveop->op_flags & OPf_SPECIAL)
2914 PL_in_eval |= EVAL_KEEPERR;
2917 if (yyparse() || PL_error_count || !PL_eval_root) {
2918 SV **newsp; /* Used by POPBLOCK. */
2919 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2920 I32 optype = 0; /* Might be reset by POPEVAL. */
2925 op_free(PL_eval_root);
2926 PL_eval_root = Nullop;
2928 SP = PL_stack_base + POPMARK; /* pop original mark */
2930 POPBLOCK(cx,PL_curpm);
2935 if (optype == OP_REQUIRE) {
2936 const char* msg = SvPVx(ERRSV, n_a);
2937 SV *nsv = cx->blk_eval.old_namesv;
2938 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2940 DIE(aTHX_ "%sCompilation failed in require",
2941 *msg ? msg : "Unknown error\n");
2944 const char* msg = SvPVx(ERRSV, n_a);
2946 POPBLOCK(cx,PL_curpm);
2948 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2949 (*msg ? msg : "Unknown error\n"));
2952 const char* msg = SvPVx(ERRSV, n_a);
2954 sv_setpv(ERRSV, "Compilation error");
2959 CopLINE_set(&PL_compiling, 0);
2961 *startop = PL_eval_root;
2963 SAVEFREEOP(PL_eval_root);
2965 /* Set the context for this new optree.
2966 * If the last op is an OP_REQUIRE, force scalar context.
2967 * Otherwise, propagate the context from the eval(). */
2968 if (PL_eval_root->op_type == OP_LEAVEEVAL
2969 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2970 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2972 scalar(PL_eval_root);
2973 else if (gimme & G_VOID)
2974 scalarvoid(PL_eval_root);
2975 else if (gimme & G_ARRAY)
2978 scalar(PL_eval_root);
2980 DEBUG_x(dump_eval());
2982 /* Register with debugger: */
2983 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2984 CV *cv = get_cv("DB::postponed", FALSE);
2988 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2990 call_sv((SV*)cv, G_DISCARD);
2994 /* compiled okay, so do it */
2996 CvDEPTH(PL_compcv) = 1;
2997 SP = PL_stack_base + POPMARK; /* pop original mark */
2998 PL_op = saveop; /* The caller may need it. */
2999 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3001 RETURNOP(PL_eval_start);
3005 S_doopen_pm(pTHX_ const char *name, const char *mode)
3007 #ifndef PERL_DISABLE_PMC
3008 STRLEN namelen = strlen(name);
3011 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3012 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3013 const char * const pmc = SvPV_nolen(pmcsv);
3016 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3017 fp = PerlIO_open(name, mode);
3020 if (PerlLIO_stat(name, &pmstat) < 0 ||
3021 pmstat.st_mtime < pmcstat.st_mtime)
3023 fp = PerlIO_open(pmc, mode);
3026 fp = PerlIO_open(name, mode);
3029 SvREFCNT_dec(pmcsv);
3032 fp = PerlIO_open(name, mode);
3036 return PerlIO_open(name, mode);
3037 #endif /* !PERL_DISABLE_PMC */
3043 register PERL_CONTEXT *cx;
3047 char *tryname = Nullch;
3048 SV *namesv = Nullsv;
3050 I32 gimme = GIMME_V;
3051 PerlIO *tryrsfp = 0;
3053 int filter_has_file = 0;
3054 GV *filter_child_proc = 0;
3055 SV *filter_state = 0;
3062 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3063 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3064 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3065 "v-string in use/require non-portable");
3067 sv = new_version(sv);
3068 if (!sv_derived_from(PL_patchlevel, "version"))
3069 (void *)upg_version(PL_patchlevel);
3070 if ( vcmp(sv,PL_patchlevel) > 0 )
3071 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3072 vstringify(sv), vstringify(PL_patchlevel));
3076 name = SvPV(sv, len);
3077 if (!(name && len > 0 && *name))
3078 DIE(aTHX_ "Null filename used");
3079 TAINT_PROPER("require");
3080 if (PL_op->op_type == OP_REQUIRE &&
3081 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3082 if (*svp != &PL_sv_undef)
3085 DIE(aTHX_ "Compilation failed in require");
3088 /* prepare to compile file */
3090 if (path_is_absolute(name)) {
3092 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3094 #ifdef MACOS_TRADITIONAL
3098 MacPerl_CanonDir(name, newname, 1);
3099 if (path_is_absolute(newname)) {
3101 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3106 AV *ar = GvAVn(PL_incgv);
3110 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3113 namesv = NEWSV(806, 0);
3114 for (i = 0; i <= AvFILL(ar); i++) {
3115 SV *dirsv = *av_fetch(ar, i, TRUE);
3121 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3122 && !sv_isobject(loader))
3124 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3127 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3128 PTR2UV(SvRV(dirsv)), name);
3129 tryname = SvPVX(namesv);
3140 if (sv_isobject(loader))
3141 count = call_method("INC", G_ARRAY);
3143 count = call_sv(loader, G_ARRAY);
3153 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3157 if (SvTYPE(arg) == SVt_PVGV) {
3158 IO *io = GvIO((GV *)arg);
3163 tryrsfp = IoIFP(io);
3164 if (IoTYPE(io) == IoTYPE_PIPE) {
3165 /* reading from a child process doesn't
3166 nest -- when returning from reading
3167 the inner module, the outer one is
3168 unreadable (closed?) I've tried to
3169 save the gv to manage the lifespan of
3170 the pipe, but this didn't help. XXX */
3171 filter_child_proc = (GV *)arg;
3172 (void)SvREFCNT_inc(filter_child_proc);
3175 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3176 PerlIO_close(IoOFP(io));
3188 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3190 (void)SvREFCNT_inc(filter_sub);
3193 filter_state = SP[i];
3194 (void)SvREFCNT_inc(filter_state);
3198 tryrsfp = PerlIO_open("/dev/null",
3214 filter_has_file = 0;
3215 if (filter_child_proc) {
3216 SvREFCNT_dec(filter_child_proc);
3217 filter_child_proc = 0;
3220 SvREFCNT_dec(filter_state);
3224 SvREFCNT_dec(filter_sub);
3229 if (!path_is_absolute(name)
3230 #ifdef MACOS_TRADITIONAL
3231 /* We consider paths of the form :a:b ambiguous and interpret them first
3232 as global then as local
3234 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3237 char *dir = SvPVx(dirsv, n_a);
3238 #ifdef MACOS_TRADITIONAL
3242 MacPerl_CanonDir(name, buf2, 1);
3243 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3247 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3249 sv_setpv(namesv, unixdir);
3250 sv_catpv(namesv, unixname);
3253 if (PL_origfilename[0] &&
3254 PL_origfilename[1] == ':' &&
3255 !(dir[0] && dir[1] == ':'))
3256 Perl_sv_setpvf(aTHX_ namesv,
3261 Perl_sv_setpvf(aTHX_ namesv,
3265 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3269 TAINT_PROPER("require");
3270 tryname = SvPVX(namesv);
3271 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3273 if (tryname[0] == '.' && tryname[1] == '/')
3282 SAVECOPFILE_FREE(&PL_compiling);
3283 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3284 SvREFCNT_dec(namesv);
3286 if (PL_op->op_type == OP_REQUIRE) {
3287 char *msgstr = name;
3288 if (namesv) { /* did we lookup @INC? */
3289 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3290 SV *dirmsgsv = NEWSV(0, 0);
3291 AV *ar = GvAVn(PL_incgv);
3293 sv_catpvn(msg, " in @INC", 8);
3294 if (instr(SvPVX(msg), ".h "))
3295 sv_catpv(msg, " (change .h to .ph maybe?)");
3296 if (instr(SvPVX(msg), ".ph "))
3297 sv_catpv(msg, " (did you run h2ph?)");
3298 sv_catpv(msg, " (@INC contains:");
3299 for (i = 0; i <= AvFILL(ar); i++) {
3300 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3301 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3302 sv_catsv(msg, dirmsgsv);
3304 sv_catpvn(msg, ")", 1);
3305 SvREFCNT_dec(dirmsgsv);
3306 msgstr = SvPV_nolen(msg);
3308 DIE(aTHX_ "Can't locate %s", msgstr);
3314 SETERRNO(0, SS_NORMAL);
3316 /* Assume success here to prevent recursive requirement. */
3318 /* Check whether a hook in @INC has already filled %INC */
3319 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3320 (void)hv_store(GvHVn(PL_incgv), name, len,
3321 (hook_sv ? SvREFCNT_inc(hook_sv)
3322 : newSVpv(CopFILE(&PL_compiling), 0)),
3328 lex_start(sv_2mortal(newSVpvn("",0)));
3329 SAVEGENERICSV(PL_rsfp_filters);
3330 PL_rsfp_filters = Nullav;
3335 SAVESPTR(PL_compiling.cop_warnings);
3336 if (PL_dowarn & G_WARN_ALL_ON)
3337 PL_compiling.cop_warnings = pWARN_ALL ;
3338 else if (PL_dowarn & G_WARN_ALL_OFF)
3339 PL_compiling.cop_warnings = pWARN_NONE ;
3340 else if (PL_taint_warn)
3341 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3343 PL_compiling.cop_warnings = pWARN_STD ;
3344 SAVESPTR(PL_compiling.cop_io);
3345 PL_compiling.cop_io = Nullsv;
3347 if (filter_sub || filter_child_proc) {
3348 SV *datasv = filter_add(run_user_filter, Nullsv);
3349 IoLINES(datasv) = filter_has_file;
3350 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3351 IoTOP_GV(datasv) = (GV *)filter_state;
3352 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3355 /* switch to eval mode */
3356 PUSHBLOCK(cx, CXt_EVAL, SP);
3357 PUSHEVAL(cx, name, Nullgv);
3358 cx->blk_eval.retop = PL_op->op_next;
3360 SAVECOPLINE(&PL_compiling);
3361 CopLINE_set(&PL_compiling, 0);
3365 /* Store and reset encoding. */
3366 encoding = PL_encoding;
3367 PL_encoding = Nullsv;
3369 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3371 /* Restore encoding. */
3372 PL_encoding = encoding;
3379 return pp_require();
3385 register PERL_CONTEXT *cx;
3387 I32 gimme = GIMME_V, was = PL_sub_generation;
3388 char tbuf[TYPE_DIGITS(long) + 12];
3389 char *tmpbuf = tbuf;
3398 TAINT_PROPER("eval");
3404 /* switch to eval mode */
3406 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3407 SV *sv = sv_newmortal();
3408 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3409 (unsigned long)++PL_evalseq,
3410 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3414 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3415 SAVECOPFILE_FREE(&PL_compiling);
3416 CopFILE_set(&PL_compiling, tmpbuf+2);
3417 SAVECOPLINE(&PL_compiling);
3418 CopLINE_set(&PL_compiling, 1);
3419 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3420 deleting the eval's FILEGV from the stash before gv_check() runs
3421 (i.e. before run-time proper). To work around the coredump that
3422 ensues, we always turn GvMULTI_on for any globals that were
3423 introduced within evals. See force_ident(). GSAR 96-10-12 */
3424 safestr = savepv(tmpbuf);
3425 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3427 PL_hints = PL_op->op_targ;
3428 SAVESPTR(PL_compiling.cop_warnings);
3429 if (specialWARN(PL_curcop->cop_warnings))
3430 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3432 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3433 SAVEFREESV(PL_compiling.cop_warnings);
3435 SAVESPTR(PL_compiling.cop_io);
3436 if (specialCopIO(PL_curcop->cop_io))
3437 PL_compiling.cop_io = PL_curcop->cop_io;
3439 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3440 SAVEFREESV(PL_compiling.cop_io);
3442 /* special case: an eval '' executed within the DB package gets lexically
3443 * placed in the first non-DB CV rather than the current CV - this
3444 * allows the debugger to execute code, find lexicals etc, in the
3445 * scope of the code being debugged. Passing &seq gets find_runcv
3446 * to do the dirty work for us */
3447 runcv = find_runcv(&seq);
3449 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3450 PUSHEVAL(cx, 0, Nullgv);
3451 cx->blk_eval.retop = PL_op->op_next;
3453 /* prepare to compile string */
3455 if (PERLDB_LINE && PL_curstash != PL_debstash)
3456 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3458 ret = doeval(gimme, NULL, runcv, seq);
3459 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3460 && ret != PL_op->op_next) { /* Successive compilation. */
3461 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3463 return DOCATCH(ret);
3473 register PERL_CONTEXT *cx;
3475 const U8 save_flags = PL_op -> op_flags;
3480 retop = cx->blk_eval.retop;
3483 if (gimme == G_VOID)
3485 else if (gimme == G_SCALAR) {
3488 if (SvFLAGS(TOPs) & SVs_TEMP)
3491 *MARK = sv_mortalcopy(TOPs);
3495 *MARK = &PL_sv_undef;
3500 /* in case LEAVE wipes old return values */
3501 for (mark = newsp + 1; mark <= SP; mark++) {
3502 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3503 *mark = sv_mortalcopy(*mark);
3504 TAINT_NOT; /* Each item is independent */
3508 PL_curpm = newpm; /* Don't pop $1 et al till now */
3511 assert(CvDEPTH(PL_compcv) == 1);
3513 CvDEPTH(PL_compcv) = 0;
3516 if (optype == OP_REQUIRE &&
3517 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3519 /* Unassume the success we assumed earlier. */
3520 SV *nsv = cx->blk_eval.old_namesv;
3521 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3522 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3523 /* die_where() did LEAVE, or we won't be here */
3527 if (!(save_flags & OPf_SPECIAL))
3537 register PERL_CONTEXT *cx;
3538 I32 gimme = GIMME_V;
3543 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3545 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3547 PL_in_eval = EVAL_INEVAL;
3550 return DOCATCH(PL_op->op_next);
3560 register PERL_CONTEXT *cx;
3567 if (gimme == G_VOID)
3569 else if (gimme == G_SCALAR) {
3572 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3575 *MARK = sv_mortalcopy(TOPs);
3579 *MARK = &PL_sv_undef;
3584 /* in case LEAVE wipes old return values */
3585 for (mark = newsp + 1; mark <= SP; mark++) {
3586 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3587 *mark = sv_mortalcopy(*mark);
3588 TAINT_NOT; /* Each item is independent */
3592 PL_curpm = newpm; /* Don't pop $1 et al till now */
3600 S_doparseform(pTHX_ SV *sv)
3603 register char *s = SvPV_force(sv, len);
3604 register char *send = s + len;
3605 register char *base = Nullch;
3606 register I32 skipspaces = 0;
3607 bool noblank = FALSE;
3608 bool repeat = FALSE;
3609 bool postspace = FALSE;
3615 bool unchopnum = FALSE;
3616 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3619 Perl_croak(aTHX_ "Null picture in formline");
3621 /* estimate the buffer size needed */
3622 for (base = s; s <= send; s++) {
3623 if (*s == '\n' || *s == '@' || *s == '^')
3629 New(804, fops, maxops, U32);
3634 *fpc++ = FF_LINEMARK;
3635 noblank = repeat = FALSE;
3653 case ' ': case '\t':
3660 } /* else FALL THROUGH */
3668 *fpc++ = FF_LITERAL;
3676 *fpc++ = (U16)skipspaces;
3680 *fpc++ = FF_NEWLINE;
3684 arg = fpc - linepc + 1;
3691 *fpc++ = FF_LINEMARK;
3692 noblank = repeat = FALSE;
3701 ischop = s[-1] == '^';
3707 arg = (s - base) - 1;
3709 *fpc++ = FF_LITERAL;
3717 *fpc++ = 2; /* skip the @* or ^* */
3719 *fpc++ = FF_LINESNGL;
3722 *fpc++ = FF_LINEGLOB;
3724 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3725 arg = ischop ? 512 : 0;
3730 const char * const f = ++s;
3733 arg |= 256 + (s - f);
3735 *fpc++ = s - base; /* fieldsize for FETCH */
3736 *fpc++ = FF_DECIMAL;
3738 unchopnum |= ! ischop;
3740 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3741 arg = ischop ? 512 : 0;
3743 s++; /* skip the '0' first */
3747 const char * const f = ++s;
3750 arg |= 256 + (s - f);
3752 *fpc++ = s - base; /* fieldsize for FETCH */
3753 *fpc++ = FF_0DECIMAL;
3755 unchopnum |= ! ischop;
3759 bool ismore = FALSE;
3762 while (*++s == '>') ;
3763 prespace = FF_SPACE;
3765 else if (*s == '|') {
3766 while (*++s == '|') ;
3767 prespace = FF_HALFSPACE;
3772 while (*++s == '<') ;
3775 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3779 *fpc++ = s - base; /* fieldsize for FETCH */
3781 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3784 *fpc++ = (U16)prespace;
3798 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3800 { /* need to jump to the next word */
3802 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3803 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3804 s = SvPVX(sv) + SvCUR(sv) + z;
3806 Copy(fops, s, arg, U32);
3808 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3811 if (unchopnum && repeat)
3812 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3818 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3820 /* Can value be printed in fldsize chars, using %*.*f ? */
3824 int intsize = fldsize - (value < 0 ? 1 : 0);
3831 while (intsize--) pwr *= 10.0;
3832 while (frcsize--) eps /= 10.0;
3835 if (value + eps >= pwr)
3838 if (value - eps <= -pwr)
3845 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3848 SV *datasv = FILTER_DATA(idx);
3849 int filter_has_file = IoLINES(datasv);
3850 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3851 SV *filter_state = (SV *)IoTOP_GV(datasv);
3852 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3855 /* I was having segfault trouble under Linux 2.2.5 after a
3856 parse error occured. (Had to hack around it with a test
3857 for PL_error_count == 0.) Solaris doesn't segfault --
3858 not sure where the trouble is yet. XXX */
3860 if (filter_has_file) {
3861 len = FILTER_READ(idx+1, buf_sv, maxlen);
3864 if (filter_sub && len >= 0) {
3875 PUSHs(sv_2mortal(newSViv(maxlen)));
3877 PUSHs(filter_state);
3880 count = call_sv(filter_sub, G_SCALAR);
3896 IoLINES(datasv) = 0;
3897 if (filter_child_proc) {
3898 SvREFCNT_dec(filter_child_proc);
3899 IoFMT_GV(datasv) = Nullgv;
3902 SvREFCNT_dec(filter_state);
3903 IoTOP_GV(datasv) = Nullgv;
3906 SvREFCNT_dec(filter_sub);
3907 IoBOTTOM_GV(datasv) = Nullgv;
3909 filter_del(run_user_filter);
3915 /* perhaps someone can come up with a better name for
3916 this? it is not really "absolute", per se ... */
3918 S_path_is_absolute(pTHX_ const char *name)
3920 if (PERL_FILE_IS_ABSOLUTE(name)
3921 #ifdef MACOS_TRADITIONAL
3924 || (*name == '.' && (name[1] == '/' ||
3925 (name[1] == '.' && name[2] == '/'))))
3936 * c-indentation-style: bsd
3938 * indent-tabs-mode: t
3941 * vim: shiftwidth=4: