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 const 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_const(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_const(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_const(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_const(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_const(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_const(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_const(PL_formtarget) && isSPACE(s[-1]))
879 SvCUR_set(PL_formtarget, t - SvPVX_const(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 */
934 const I32 gimme = GIMME_V;
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);
1088 sv_setpvn(TARG, "", 0);
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_const(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 const char *tmps = SvPV(final, len);
1143 sv = sv_mortalcopy(left);
1145 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1147 if (strEQ(SvPVX_const(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 const 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;
1400 sv_setpvn(err,"",0);
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 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1413 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(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_const(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;
1547 const char *stashname;
1554 /* we may be in a higher stacklevel, so dig down deeper */
1555 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1556 top_si = top_si->si_prev;
1557 ccstack = top_si->si_cxstack;
1558 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1561 if (GIMME != G_ARRAY) {
1567 /* caller() should not report the automatic calls to &DB::sub */
1568 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1569 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1573 cxix = dopoptosub_at(ccstack, cxix - 1);
1576 cx = &ccstack[cxix];
1577 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1578 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1579 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1580 field below is defined for any cx. */
1581 /* caller() should not report the automatic calls to &DB::sub */
1582 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1583 cx = &ccstack[dbcxix];
1586 stashname = CopSTASHPV(cx->blk_oldcop);
1587 if (GIMME != G_ARRAY) {
1590 PUSHs(&PL_sv_undef);
1593 sv_setpv(TARG, stashname);
1602 PUSHs(&PL_sv_undef);
1604 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1605 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1606 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1609 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1610 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1611 /* So is ccstack[dbcxix]. */
1613 SV * const sv = NEWSV(49, 0);
1614 gv_efullname3(sv, cvgv, Nullch);
1615 PUSHs(sv_2mortal(sv));
1616 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1619 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1620 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1624 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1625 PUSHs(sv_2mortal(newSViv(0)));
1627 gimme = (I32)cx->blk_gimme;
1628 if (gimme == G_VOID)
1629 PUSHs(&PL_sv_undef);
1631 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1632 if (CxTYPE(cx) == CXt_EVAL) {
1634 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1635 PUSHs(cx->blk_eval.cur_text);
1639 else if (cx->blk_eval.old_namesv) {
1640 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1643 /* eval BLOCK (try blocks have old_namesv == 0) */
1645 PUSHs(&PL_sv_undef);
1646 PUSHs(&PL_sv_undef);
1650 PUSHs(&PL_sv_undef);
1651 PUSHs(&PL_sv_undef);
1653 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1654 && CopSTASH_eq(PL_curcop, PL_debstash))
1656 AV *ary = cx->blk_sub.argarray;
1657 const int off = AvARRAY(ary) - AvALLOC(ary);
1661 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1664 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1667 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1668 av_extend(PL_dbargs, AvFILLp(ary) + off);
1669 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1670 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1672 /* XXX only hints propagated via op_private are currently
1673 * visible (others are not easily accessible, since they
1674 * use the global PL_hints) */
1675 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1676 HINT_PRIVATE_MASK)));
1679 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1681 if (old_warnings == pWARN_NONE ||
1682 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1683 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1684 else if (old_warnings == pWARN_ALL ||
1685 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1686 /* Get the bit mask for $warnings::Bits{all}, because
1687 * it could have been extended by warnings::register */
1689 HV *bits = get_hv("warnings::Bits", FALSE);
1690 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1691 mask = newSVsv(*bits_all);
1694 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1698 mask = newSVsv(old_warnings);
1699 PUSHs(sv_2mortal(mask));
1714 sv_reset(tmps, CopSTASH(PL_curcop));
1724 /* like pp_nextstate, but used instead when the debugger is active */
1729 PL_curcop = (COP*)PL_op;
1730 TAINT_NOT; /* Each statement is presumed innocent */
1731 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1734 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1735 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1739 register PERL_CONTEXT *cx;
1740 const I32 gimme = G_ARRAY;
1747 DIE(aTHX_ "No DB::DB routine defined");
1749 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1750 /* don't do recursive DB::DB call */
1762 PUSHBLOCK(cx, CXt_SUB, SP);
1764 cx->blk_sub.retop = PL_op->op_next;
1766 PAD_SET_CUR(CvPADLIST(cv),1);
1767 RETURNOP(CvSTART(cv));
1781 register PERL_CONTEXT *cx;
1782 const I32 gimme = GIMME_V;
1784 U32 cxtype = CXt_LOOP;
1792 if (PL_op->op_targ) {
1793 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1794 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1795 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1796 SVs_PADSTALE, SVs_PADSTALE);
1798 #ifndef USE_ITHREADS
1799 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1802 SAVEPADSV(PL_op->op_targ);
1803 iterdata = INT2PTR(void*, PL_op->op_targ);
1804 cxtype |= CXp_PADVAR;
1809 svp = &GvSV(gv); /* symbol table variable */
1810 SAVEGENERICSV(*svp);
1813 iterdata = (void*)gv;
1819 PUSHBLOCK(cx, cxtype, SP);
1821 PUSHLOOP(cx, iterdata, MARK);
1823 PUSHLOOP(cx, svp, MARK);
1825 if (PL_op->op_flags & OPf_STACKED) {
1826 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1827 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1829 SV *right = (SV*)cx->blk_loop.iterary;
1830 if (RANGE_IS_NUMERIC(sv,right)) {
1831 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1832 (SvOK(right) && SvNV(right) >= IV_MAX))
1833 DIE(aTHX_ "Range iterator outside integer range");
1834 cx->blk_loop.iterix = SvIV(sv);
1835 cx->blk_loop.itermax = SvIV(right);
1839 cx->blk_loop.iterlval = newSVsv(sv);
1840 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1841 (void) SvPV(right,n_a);
1844 else if (PL_op->op_private & OPpITER_REVERSED) {
1845 cx->blk_loop.itermax = -1;
1846 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1851 cx->blk_loop.iterary = PL_curstack;
1852 AvFILLp(PL_curstack) = SP - PL_stack_base;
1853 if (PL_op->op_private & OPpITER_REVERSED) {
1854 cx->blk_loop.itermax = MARK - PL_stack_base;
1855 cx->blk_loop.iterix = cx->blk_oldsp;
1858 cx->blk_loop.iterix = MARK - PL_stack_base;
1868 register PERL_CONTEXT *cx;
1869 const I32 gimme = GIMME_V;
1875 PUSHBLOCK(cx, CXt_LOOP, SP);
1876 PUSHLOOP(cx, 0, SP);
1884 register PERL_CONTEXT *cx;
1891 assert(CxTYPE(cx) == CXt_LOOP);
1893 newsp = PL_stack_base + cx->blk_loop.resetsp;
1896 if (gimme == G_VOID)
1898 else if (gimme == G_SCALAR) {
1900 *++newsp = sv_mortalcopy(*SP);
1902 *++newsp = &PL_sv_undef;
1906 *++newsp = sv_mortalcopy(*++mark);
1907 TAINT_NOT; /* Each item is independent */
1913 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1914 PL_curpm = newpm; /* ... and pop $1 et al */
1926 register PERL_CONTEXT *cx;
1927 bool popsub2 = FALSE;
1928 bool clear_errsv = FALSE;
1936 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1937 if (cxstack_ix == PL_sortcxix
1938 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1940 if (cxstack_ix > PL_sortcxix)
1941 dounwind(PL_sortcxix);
1942 AvARRAY(PL_curstack)[1] = *SP;
1943 PL_stack_sp = PL_stack_base + 1;
1948 cxix = dopoptosub(cxstack_ix);
1950 DIE(aTHX_ "Can't return outside a subroutine");
1951 if (cxix < cxstack_ix)
1955 switch (CxTYPE(cx)) {
1958 retop = cx->blk_sub.retop;
1959 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1962 if (!(PL_in_eval & EVAL_KEEPERR))
1965 retop = cx->blk_eval.retop;
1969 if (optype == OP_REQUIRE &&
1970 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1972 /* Unassume the success we assumed earlier. */
1973 SV *nsv = cx->blk_eval.old_namesv;
1974 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1975 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1980 retop = cx->blk_sub.retop;
1983 DIE(aTHX_ "panic: return");
1987 if (gimme == G_SCALAR) {
1990 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1992 *++newsp = SvREFCNT_inc(*SP);
1997 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1999 *++newsp = sv_mortalcopy(sv);
2004 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2007 *++newsp = sv_mortalcopy(*SP);
2010 *++newsp = &PL_sv_undef;
2012 else if (gimme == G_ARRAY) {
2013 while (++MARK <= SP) {
2014 *++newsp = (popsub2 && SvTEMP(*MARK))
2015 ? *MARK : sv_mortalcopy(*MARK);
2016 TAINT_NOT; /* Each item is independent */
2019 PL_stack_sp = newsp;
2022 /* Stack values are safe: */
2025 POPSUB(cx,sv); /* release CV and @_ ... */
2029 PL_curpm = newpm; /* ... and pop $1 et al */
2033 sv_setpvn(ERRSV,"",0);
2041 register PERL_CONTEXT *cx;
2051 if (PL_op->op_flags & OPf_SPECIAL) {
2052 cxix = dopoptoloop(cxstack_ix);
2054 DIE(aTHX_ "Can't \"last\" outside a loop block");
2057 cxix = dopoptolabel(cPVOP->op_pv);
2059 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2061 if (cxix < cxstack_ix)
2065 cxstack_ix++; /* temporarily protect top context */
2067 switch (CxTYPE(cx)) {
2070 newsp = PL_stack_base + cx->blk_loop.resetsp;
2071 nextop = cx->blk_loop.last_op->op_next;
2075 nextop = cx->blk_sub.retop;
2079 nextop = cx->blk_eval.retop;
2083 nextop = cx->blk_sub.retop;
2086 DIE(aTHX_ "panic: last");
2090 if (gimme == G_SCALAR) {
2092 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2093 ? *SP : sv_mortalcopy(*SP);
2095 *++newsp = &PL_sv_undef;
2097 else if (gimme == G_ARRAY) {
2098 while (++MARK <= SP) {
2099 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2100 ? *MARK : sv_mortalcopy(*MARK);
2101 TAINT_NOT; /* Each item is independent */
2109 /* Stack values are safe: */
2112 POPLOOP(cx); /* release loop vars ... */
2116 POPSUB(cx,sv); /* release CV and @_ ... */
2119 PL_curpm = newpm; /* ... and pop $1 et al */
2129 register PERL_CONTEXT *cx;
2132 if (PL_op->op_flags & OPf_SPECIAL) {
2133 cxix = dopoptoloop(cxstack_ix);
2135 DIE(aTHX_ "Can't \"next\" outside a loop block");
2138 cxix = dopoptolabel(cPVOP->op_pv);
2140 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2142 if (cxix < cxstack_ix)
2145 /* clear off anything above the scope we're re-entering, but
2146 * save the rest until after a possible continue block */
2147 inner = PL_scopestack_ix;
2149 if (PL_scopestack_ix < inner)
2150 leave_scope(PL_scopestack[PL_scopestack_ix]);
2151 PL_curcop = cx->blk_oldcop;
2152 return cx->blk_loop.next_op;
2159 register PERL_CONTEXT *cx;
2163 if (PL_op->op_flags & OPf_SPECIAL) {
2164 cxix = dopoptoloop(cxstack_ix);
2166 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2169 cxix = dopoptolabel(cPVOP->op_pv);
2171 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2173 if (cxix < cxstack_ix)
2176 redo_op = cxstack[cxix].blk_loop.redo_op;
2177 if (redo_op->op_type == OP_ENTER) {
2178 /* pop one less context to avoid $x being freed in while (my $x..) */
2180 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2181 redo_op = redo_op->op_next;
2185 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2186 LEAVE_SCOPE(oldsave);
2188 PL_curcop = cx->blk_oldcop;
2193 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2197 static const char too_deep[] = "Target of goto is too deeply nested";
2200 Perl_croak(aTHX_ too_deep);
2201 if (o->op_type == OP_LEAVE ||
2202 o->op_type == OP_SCOPE ||
2203 o->op_type == OP_LEAVELOOP ||
2204 o->op_type == OP_LEAVESUB ||
2205 o->op_type == OP_LEAVETRY)
2207 *ops++ = cUNOPo->op_first;
2209 Perl_croak(aTHX_ too_deep);
2212 if (o->op_flags & OPf_KIDS) {
2213 /* First try all the kids at this level, since that's likeliest. */
2214 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2215 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2216 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2219 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2220 if (kid == PL_lastgotoprobe)
2222 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2225 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2226 ops[-1]->op_type == OP_DBSTATE)
2231 if ((o = dofindlabel(kid, label, ops, oplimit)))
2250 register PERL_CONTEXT *cx;
2251 #define GOTO_DEPTH 64
2252 OP *enterops[GOTO_DEPTH];
2253 const char *label = 0;
2254 const bool do_dump = (PL_op->op_type == OP_DUMP);
2255 static const char must_have_label[] = "goto must have label";
2257 if (PL_op->op_flags & OPf_STACKED) {
2261 /* This egregious kludge implements goto &subroutine */
2262 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2264 register PERL_CONTEXT *cx;
2265 CV* cv = (CV*)SvRV(sv);
2272 if (!CvROOT(cv) && !CvXSUB(cv)) {
2273 const GV * const gv = CvGV(cv);
2277 /* autoloaded stub? */
2278 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2280 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2281 GvNAMELEN(gv), FALSE);
2282 if (autogv && (cv = GvCV(autogv)))
2284 tmpstr = sv_newmortal();
2285 gv_efullname3(tmpstr, gv, Nullch);
2286 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2288 DIE(aTHX_ "Goto undefined subroutine");
2291 /* First do some returnish stuff. */
2292 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2294 cxix = dopoptosub(cxstack_ix);
2296 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2297 if (cxix < cxstack_ix)
2301 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2302 if (CxTYPE(cx) == CXt_EVAL) {
2304 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2306 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2308 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2309 /* put @_ back onto stack */
2310 AV* av = cx->blk_sub.argarray;
2312 items = AvFILLp(av) + 1;
2313 EXTEND(SP, items+1); /* @_ could have been extended. */
2314 Copy(AvARRAY(av), SP + 1, items, SV*);
2315 SvREFCNT_dec(GvAV(PL_defgv));
2316 GvAV(PL_defgv) = cx->blk_sub.savearray;
2318 /* abandon @_ if it got reified */
2323 av_extend(av, items-1);
2325 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2328 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2330 av = GvAV(PL_defgv);
2331 items = AvFILLp(av) + 1;
2332 EXTEND(SP, items+1); /* @_ could have been extended. */
2333 Copy(AvARRAY(av), SP + 1, items, SV*);
2337 if (CxTYPE(cx) == CXt_SUB &&
2338 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2339 SvREFCNT_dec(cx->blk_sub.cv);
2340 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2341 LEAVE_SCOPE(oldsave);
2343 /* Now do some callish stuff. */
2345 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2347 OP* retop = cx->blk_sub.retop;
2350 for (index=0; index<items; index++)
2351 sv_2mortal(SP[-index]);
2353 #ifdef PERL_XSUB_OLDSTYLE
2354 if (CvOLDSTYLE(cv)) {
2355 I32 (*fp3)(int,int,int);
2360 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2361 items = (*fp3)(CvXSUBANY(cv).any_i32,
2362 mark - PL_stack_base + 1,
2364 SP = PL_stack_base + items;
2367 #endif /* PERL_XSUB_OLDSTYLE */
2372 /* XS subs don't have a CxSUB, so pop it */
2373 POPBLOCK(cx, PL_curpm);
2374 /* Push a mark for the start of arglist */
2377 (void)(*CvXSUB(cv))(aTHX_ cv);
2383 AV* padlist = CvPADLIST(cv);
2384 if (CxTYPE(cx) == CXt_EVAL) {
2385 PL_in_eval = cx->blk_eval.old_in_eval;
2386 PL_eval_root = cx->blk_eval.old_eval_root;
2387 cx->cx_type = CXt_SUB;
2388 cx->blk_sub.hasargs = 0;
2390 cx->blk_sub.cv = cv;
2391 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2394 if (CvDEPTH(cv) < 2)
2395 (void)SvREFCNT_inc(cv);
2397 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2398 sub_crush_depth(cv);
2399 pad_push(padlist, CvDEPTH(cv));
2401 PAD_SET_CUR(padlist, CvDEPTH(cv));
2402 if (cx->blk_sub.hasargs)
2404 AV* av = (AV*)PAD_SVl(0);
2407 cx->blk_sub.savearray = GvAV(PL_defgv);
2408 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2409 CX_CURPAD_SAVE(cx->blk_sub);
2410 cx->blk_sub.argarray = av;
2412 if (items >= AvMAX(av) + 1) {
2414 if (AvARRAY(av) != ary) {
2415 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2416 SvPV_set(av, (char*)ary);
2418 if (items >= AvMAX(av) + 1) {
2419 AvMAX(av) = items - 1;
2420 Renew(ary,items+1,SV*);
2422 SvPV_set(av, (char*)ary);
2426 Copy(mark,AvARRAY(av),items,SV*);
2427 AvFILLp(av) = items - 1;
2428 assert(!AvREAL(av));
2430 /* transfer 'ownership' of refcnts to new @_ */
2440 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2442 * We do not care about using sv to call CV;
2443 * it's for informational purposes only.
2445 SV *sv = GvSV(PL_DBsub);
2449 if (PERLDB_SUB_NN) {
2450 int type = SvTYPE(sv);
2451 if (type < SVt_PVIV && type != SVt_IV)
2452 sv_upgrade(sv, SVt_PVIV);
2454 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2456 gv_efullname3(sv, CvGV(cv), Nullch);
2459 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2460 PUSHMARK( PL_stack_sp );
2461 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2465 RETURNOP(CvSTART(cv));
2469 label = SvPV(sv,n_a);
2470 if (!(do_dump || *label))
2471 DIE(aTHX_ must_have_label);
2474 else if (PL_op->op_flags & OPf_SPECIAL) {
2476 DIE(aTHX_ must_have_label);
2479 label = cPVOP->op_pv;
2481 if (label && *label) {
2483 bool leaving_eval = FALSE;
2484 bool in_block = FALSE;
2485 PERL_CONTEXT *last_eval_cx = 0;
2489 PL_lastgotoprobe = 0;
2491 for (ix = cxstack_ix; ix >= 0; ix--) {
2493 switch (CxTYPE(cx)) {
2495 leaving_eval = TRUE;
2496 if (!CxTRYBLOCK(cx)) {
2497 gotoprobe = (last_eval_cx ?
2498 last_eval_cx->blk_eval.old_eval_root :
2503 /* else fall through */
2505 gotoprobe = cx->blk_oldcop->op_sibling;
2511 gotoprobe = cx->blk_oldcop->op_sibling;
2514 gotoprobe = PL_main_root;
2517 if (CvDEPTH(cx->blk_sub.cv)) {
2518 gotoprobe = CvROOT(cx->blk_sub.cv);
2524 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2527 DIE(aTHX_ "panic: goto");
2528 gotoprobe = PL_main_root;
2532 retop = dofindlabel(gotoprobe, label,
2533 enterops, enterops + GOTO_DEPTH);
2537 PL_lastgotoprobe = gotoprobe;
2540 DIE(aTHX_ "Can't find label %s", label);
2542 /* if we're leaving an eval, check before we pop any frames
2543 that we're not going to punt, otherwise the error
2546 if (leaving_eval && *enterops && enterops[1]) {
2548 for (i = 1; enterops[i]; i++)
2549 if (enterops[i]->op_type == OP_ENTERITER)
2550 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2553 /* pop unwanted frames */
2555 if (ix < cxstack_ix) {
2562 oldsave = PL_scopestack[PL_scopestack_ix];
2563 LEAVE_SCOPE(oldsave);
2566 /* push wanted frames */
2568 if (*enterops && enterops[1]) {
2570 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2571 for (; enterops[ix]; ix++) {
2572 PL_op = enterops[ix];
2573 /* Eventually we may want to stack the needed arguments
2574 * for each op. For now, we punt on the hard ones. */
2575 if (PL_op->op_type == OP_ENTERITER)
2576 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2577 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2585 if (!retop) retop = PL_main_start;
2587 PL_restartop = retop;
2588 PL_do_undump = TRUE;
2592 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2593 PL_do_undump = FALSE;
2609 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2611 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2614 PL_exit_flags |= PERL_EXIT_EXPECTED;
2616 PUSHs(&PL_sv_undef);
2624 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2625 register I32 match = I_32(value);
2628 if (((NV)match) > value)
2629 --match; /* was fractional--truncate other way */
2631 match -= cCOP->uop.scop.scop_offset;
2634 else if (match > cCOP->uop.scop.scop_max)
2635 match = cCOP->uop.scop.scop_max;
2636 PL_op = cCOP->uop.scop.scop_next[match];
2646 PL_op = PL_op->op_next; /* can't assume anything */
2649 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2650 match -= cCOP->uop.scop.scop_offset;
2653 else if (match > cCOP->uop.scop.scop_max)
2654 match = cCOP->uop.scop.scop_max;
2655 PL_op = cCOP->uop.scop.scop_next[match];
2664 S_save_lines(pTHX_ AV *array, SV *sv)
2666 const char *s = SvPVX_const(sv);
2667 const char *send = SvPVX_const(sv) + SvCUR(sv);
2670 while (s && s < send) {
2672 SV *tmpstr = NEWSV(85,0);
2674 sv_upgrade(tmpstr, SVt_PVMG);
2675 t = strchr(s, '\n');
2681 sv_setpvn(tmpstr, s, t - s);
2682 av_store(array, line++, tmpstr);
2688 S_docatch_body(pTHX)
2695 S_docatch(pTHX_ OP *o)
2698 OP * const oldop = PL_op;
2702 assert(CATCH_GET == TRUE);
2709 assert(cxstack_ix >= 0);
2710 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2711 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2716 /* die caught by an inner eval - continue inner loop */
2718 /* NB XXX we rely on the old popped CxEVAL still being at the top
2719 * of the stack; the way die_where() currently works, this
2720 * assumption is valid. In theory The cur_top_env value should be
2721 * returned in another global, the way retop (aka PL_restartop)
2723 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2726 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2728 PL_op = PL_restartop;
2745 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2746 /* sv Text to convert to OP tree. */
2747 /* startop op_free() this to undo. */
2748 /* code Short string id of the caller. */
2750 dVAR; dSP; /* Make POPBLOCK work. */
2753 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2757 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2758 char *tmpbuf = tbuf;
2761 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2766 /* switch to eval mode */
2768 if (IN_PERL_COMPILETIME) {
2769 SAVECOPSTASH_FREE(&PL_compiling);
2770 CopSTASH_set(&PL_compiling, PL_curstash);
2772 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2773 SV *sv = sv_newmortal();
2774 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2775 code, (unsigned long)++PL_evalseq,
2776 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2780 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2781 SAVECOPFILE_FREE(&PL_compiling);
2782 CopFILE_set(&PL_compiling, tmpbuf+2);
2783 SAVECOPLINE(&PL_compiling);
2784 CopLINE_set(&PL_compiling, 1);
2785 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2786 deleting the eval's FILEGV from the stash before gv_check() runs
2787 (i.e. before run-time proper). To work around the coredump that
2788 ensues, we always turn GvMULTI_on for any globals that were
2789 introduced within evals. See force_ident(). GSAR 96-10-12 */
2790 safestr = savepv(tmpbuf);
2791 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2793 #ifdef OP_IN_REGISTER
2799 /* we get here either during compilation, or via pp_regcomp at runtime */
2800 runtime = IN_PERL_RUNTIME;
2802 runcv = find_runcv(NULL);
2805 PL_op->op_type = OP_ENTEREVAL;
2806 PL_op->op_flags = 0; /* Avoid uninit warning. */
2807 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2808 PUSHEVAL(cx, 0, Nullgv);
2811 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2813 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2814 POPBLOCK(cx,PL_curpm);
2817 (*startop)->op_type = OP_NULL;
2818 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2820 /* XXX DAPM do this properly one year */
2821 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2823 if (IN_PERL_COMPILETIME)
2824 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2825 #ifdef OP_IN_REGISTER
2833 =for apidoc find_runcv
2835 Locate the CV corresponding to the currently executing sub or eval.
2836 If db_seqp is non_null, skip CVs that are in the DB package and populate
2837 *db_seqp with the cop sequence number at the point that the DB:: code was
2838 entered. (allows debuggers to eval in the scope of the breakpoint rather
2839 than in in the scope of the debugger itself).
2845 Perl_find_runcv(pTHX_ U32 *db_seqp)
2850 *db_seqp = PL_curcop->cop_seq;
2851 for (si = PL_curstackinfo; si; si = si->si_prev) {
2853 for (ix = si->si_cxix; ix >= 0; ix--) {
2854 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2855 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2856 CV *cv = cx->blk_sub.cv;
2857 /* skip DB:: code */
2858 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2859 *db_seqp = cx->blk_oldcop->cop_seq;
2864 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2872 /* Compile a require/do, an eval '', or a /(?{...})/.
2873 * In the last case, startop is non-null, and contains the address of
2874 * a pointer that should be set to the just-compiled code.
2875 * outside is the lexically enclosing CV (if any) that invoked us.
2878 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2880 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2885 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2886 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2891 SAVESPTR(PL_compcv);
2892 PL_compcv = (CV*)NEWSV(1104,0);
2893 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2894 CvEVAL_on(PL_compcv);
2895 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2896 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2898 CvOUTSIDE_SEQ(PL_compcv) = seq;
2899 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2901 /* set up a scratch pad */
2903 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2906 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2908 /* make sure we compile in the right package */
2910 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2911 SAVESPTR(PL_curstash);
2912 PL_curstash = CopSTASH(PL_curcop);
2914 SAVESPTR(PL_beginav);
2915 PL_beginav = newAV();
2916 SAVEFREESV(PL_beginav);
2917 SAVEI32(PL_error_count);
2919 /* try to compile it */
2921 PL_eval_root = Nullop;
2923 PL_curcop = &PL_compiling;
2924 PL_curcop->cop_arybase = 0;
2925 if (saveop && saveop->op_flags & OPf_SPECIAL)
2926 PL_in_eval |= EVAL_KEEPERR;
2928 sv_setpvn(ERRSV,"",0);
2929 if (yyparse() || PL_error_count || !PL_eval_root) {
2930 SV **newsp; /* Used by POPBLOCK. */
2931 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2932 I32 optype = 0; /* Might be reset by POPEVAL. */
2937 op_free(PL_eval_root);
2938 PL_eval_root = Nullop;
2940 SP = PL_stack_base + POPMARK; /* pop original mark */
2942 POPBLOCK(cx,PL_curpm);
2947 if (optype == OP_REQUIRE) {
2948 const char* msg = SvPVx(ERRSV, n_a);
2949 SV *nsv = cx->blk_eval.old_namesv;
2950 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2952 DIE(aTHX_ "%sCompilation failed in require",
2953 *msg ? msg : "Unknown error\n");
2956 const char* msg = SvPVx(ERRSV, n_a);
2958 POPBLOCK(cx,PL_curpm);
2960 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2961 (*msg ? msg : "Unknown error\n"));
2964 const char* msg = SvPVx(ERRSV, n_a);
2966 sv_setpv(ERRSV, "Compilation error");
2971 CopLINE_set(&PL_compiling, 0);
2973 *startop = PL_eval_root;
2975 SAVEFREEOP(PL_eval_root);
2977 /* Set the context for this new optree.
2978 * If the last op is an OP_REQUIRE, force scalar context.
2979 * Otherwise, propagate the context from the eval(). */
2980 if (PL_eval_root->op_type == OP_LEAVEEVAL
2981 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2982 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2984 scalar(PL_eval_root);
2985 else if (gimme & G_VOID)
2986 scalarvoid(PL_eval_root);
2987 else if (gimme & G_ARRAY)
2990 scalar(PL_eval_root);
2992 DEBUG_x(dump_eval());
2994 /* Register with debugger: */
2995 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2996 CV *cv = get_cv("DB::postponed", FALSE);
3000 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3002 call_sv((SV*)cv, G_DISCARD);
3006 /* compiled okay, so do it */
3008 CvDEPTH(PL_compcv) = 1;
3009 SP = PL_stack_base + POPMARK; /* pop original mark */
3010 PL_op = saveop; /* The caller may need it. */
3011 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3013 RETURNOP(PL_eval_start);
3017 S_doopen_pm(pTHX_ const char *name, const char *mode)
3019 #ifndef PERL_DISABLE_PMC
3020 const STRLEN namelen = strlen(name);
3023 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3024 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3025 const char * const pmc = SvPV_nolen(pmcsv);
3028 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3029 fp = PerlIO_open(name, mode);
3032 if (PerlLIO_stat(name, &pmstat) < 0 ||
3033 pmstat.st_mtime < pmcstat.st_mtime)
3035 fp = PerlIO_open(pmc, mode);
3038 fp = PerlIO_open(name, mode);
3041 SvREFCNT_dec(pmcsv);
3044 fp = PerlIO_open(name, mode);
3048 return PerlIO_open(name, mode);
3049 #endif /* !PERL_DISABLE_PMC */
3055 register PERL_CONTEXT *cx;
3059 char *tryname = Nullch;
3060 SV *namesv = Nullsv;
3062 const I32 gimme = GIMME_V;
3063 PerlIO *tryrsfp = 0;
3064 int filter_has_file = 0;
3065 GV *filter_child_proc = 0;
3066 SV *filter_state = 0;
3073 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3074 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3075 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3076 "v-string in use/require non-portable");
3078 sv = new_version(sv);
3079 if (!sv_derived_from(PL_patchlevel, "version"))
3080 (void *)upg_version(PL_patchlevel);
3081 if ( vcmp(sv,PL_patchlevel) > 0 )
3082 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3083 vstringify(sv), vstringify(PL_patchlevel));
3087 name = SvPV(sv, len);
3088 if (!(name && len > 0 && *name))
3089 DIE(aTHX_ "Null filename used");
3090 TAINT_PROPER("require");
3091 if (PL_op->op_type == OP_REQUIRE &&
3092 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3093 if (*svp != &PL_sv_undef)
3096 DIE(aTHX_ "Compilation failed in require");
3099 /* prepare to compile file */
3101 if (path_is_absolute(name)) {
3103 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3105 #ifdef MACOS_TRADITIONAL
3109 MacPerl_CanonDir(name, newname, 1);
3110 if (path_is_absolute(newname)) {
3112 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3117 AV *ar = GvAVn(PL_incgv);
3121 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3124 namesv = NEWSV(806, 0);
3125 for (i = 0; i <= AvFILL(ar); i++) {
3126 SV *dirsv = *av_fetch(ar, i, TRUE);
3132 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3133 && !sv_isobject(loader))
3135 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3138 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3139 PTR2UV(SvRV(dirsv)), name);
3140 tryname = SvPVX(namesv);
3151 if (sv_isobject(loader))
3152 count = call_method("INC", G_ARRAY);
3154 count = call_sv(loader, G_ARRAY);
3164 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3168 if (SvTYPE(arg) == SVt_PVGV) {
3169 IO *io = GvIO((GV *)arg);
3174 tryrsfp = IoIFP(io);
3175 if (IoTYPE(io) == IoTYPE_PIPE) {
3176 /* reading from a child process doesn't
3177 nest -- when returning from reading
3178 the inner module, the outer one is
3179 unreadable (closed?) I've tried to
3180 save the gv to manage the lifespan of
3181 the pipe, but this didn't help. XXX */
3182 filter_child_proc = (GV *)arg;
3183 (void)SvREFCNT_inc(filter_child_proc);
3186 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3187 PerlIO_close(IoOFP(io));
3199 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3201 (void)SvREFCNT_inc(filter_sub);
3204 filter_state = SP[i];
3205 (void)SvREFCNT_inc(filter_state);
3209 tryrsfp = PerlIO_open("/dev/null",
3225 filter_has_file = 0;
3226 if (filter_child_proc) {
3227 SvREFCNT_dec(filter_child_proc);
3228 filter_child_proc = 0;
3231 SvREFCNT_dec(filter_state);
3235 SvREFCNT_dec(filter_sub);
3240 if (!path_is_absolute(name)
3241 #ifdef MACOS_TRADITIONAL
3242 /* We consider paths of the form :a:b ambiguous and interpret them first
3243 as global then as local
3245 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3249 char *dir = SvPVx(dirsv, n_a);
3250 #ifdef MACOS_TRADITIONAL
3254 MacPerl_CanonDir(name, buf2, 1);
3255 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3259 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3261 sv_setpv(namesv, unixdir);
3262 sv_catpv(namesv, unixname);
3265 if (PL_origfilename[0] &&
3266 PL_origfilename[1] == ':' &&
3267 !(dir[0] && dir[1] == ':'))
3268 Perl_sv_setpvf(aTHX_ namesv,
3273 Perl_sv_setpvf(aTHX_ namesv,
3277 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3281 TAINT_PROPER("require");
3282 tryname = SvPVX(namesv);
3283 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3285 if (tryname[0] == '.' && tryname[1] == '/')
3294 SAVECOPFILE_FREE(&PL_compiling);
3295 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3296 SvREFCNT_dec(namesv);
3298 if (PL_op->op_type == OP_REQUIRE) {
3299 char *msgstr = name;
3300 if (namesv) { /* did we lookup @INC? */
3301 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3302 SV *dirmsgsv = NEWSV(0, 0);
3303 AV *ar = GvAVn(PL_incgv);
3305 sv_catpvn(msg, " in @INC", 8);
3306 if (instr(SvPVX_const(msg), ".h "))
3307 sv_catpv(msg, " (change .h to .ph maybe?)");
3308 if (instr(SvPVX_const(msg), ".ph "))
3309 sv_catpv(msg, " (did you run h2ph?)");
3310 sv_catpv(msg, " (@INC contains:");
3311 for (i = 0; i <= AvFILL(ar); i++) {
3313 const char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3314 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3315 sv_catsv(msg, dirmsgsv);
3317 sv_catpvn(msg, ")", 1);
3318 SvREFCNT_dec(dirmsgsv);
3319 msgstr = SvPV_nolen(msg);
3321 DIE(aTHX_ "Can't locate %s", msgstr);
3327 SETERRNO(0, SS_NORMAL);
3329 /* Assume success here to prevent recursive requirement. */
3331 /* Check whether a hook in @INC has already filled %INC */
3332 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3333 (void)hv_store(GvHVn(PL_incgv), name, len,
3334 (hook_sv ? SvREFCNT_inc(hook_sv)
3335 : newSVpv(CopFILE(&PL_compiling), 0)),
3341 lex_start(sv_2mortal(newSVpvn("",0)));
3342 SAVEGENERICSV(PL_rsfp_filters);
3343 PL_rsfp_filters = Nullav;
3348 SAVESPTR(PL_compiling.cop_warnings);
3349 if (PL_dowarn & G_WARN_ALL_ON)
3350 PL_compiling.cop_warnings = pWARN_ALL ;
3351 else if (PL_dowarn & G_WARN_ALL_OFF)
3352 PL_compiling.cop_warnings = pWARN_NONE ;
3353 else if (PL_taint_warn)
3354 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3356 PL_compiling.cop_warnings = pWARN_STD ;
3357 SAVESPTR(PL_compiling.cop_io);
3358 PL_compiling.cop_io = Nullsv;
3360 if (filter_sub || filter_child_proc) {
3361 SV *datasv = filter_add(run_user_filter, Nullsv);
3362 IoLINES(datasv) = filter_has_file;
3363 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3364 IoTOP_GV(datasv) = (GV *)filter_state;
3365 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3368 /* switch to eval mode */
3369 PUSHBLOCK(cx, CXt_EVAL, SP);
3370 PUSHEVAL(cx, name, Nullgv);
3371 cx->blk_eval.retop = PL_op->op_next;
3373 SAVECOPLINE(&PL_compiling);
3374 CopLINE_set(&PL_compiling, 0);
3378 /* Store and reset encoding. */
3379 encoding = PL_encoding;
3380 PL_encoding = Nullsv;
3382 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3384 /* Restore encoding. */
3385 PL_encoding = encoding;
3392 return pp_require();
3398 register PERL_CONTEXT *cx;
3400 const I32 gimme = GIMME_V, was = PL_sub_generation;
3401 char tbuf[TYPE_DIGITS(long) + 12];
3402 char *tmpbuf = tbuf;
3411 TAINT_PROPER("eval");
3417 /* switch to eval mode */
3419 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3420 SV *sv = sv_newmortal();
3421 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3422 (unsigned long)++PL_evalseq,
3423 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3427 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3428 SAVECOPFILE_FREE(&PL_compiling);
3429 CopFILE_set(&PL_compiling, tmpbuf+2);
3430 SAVECOPLINE(&PL_compiling);
3431 CopLINE_set(&PL_compiling, 1);
3432 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3433 deleting the eval's FILEGV from the stash before gv_check() runs
3434 (i.e. before run-time proper). To work around the coredump that
3435 ensues, we always turn GvMULTI_on for any globals that were
3436 introduced within evals. See force_ident(). GSAR 96-10-12 */
3437 safestr = savepv(tmpbuf);
3438 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3440 PL_hints = PL_op->op_targ;
3441 SAVESPTR(PL_compiling.cop_warnings);
3442 if (specialWARN(PL_curcop->cop_warnings))
3443 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3445 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3446 SAVEFREESV(PL_compiling.cop_warnings);
3448 SAVESPTR(PL_compiling.cop_io);
3449 if (specialCopIO(PL_curcop->cop_io))
3450 PL_compiling.cop_io = PL_curcop->cop_io;
3452 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3453 SAVEFREESV(PL_compiling.cop_io);
3455 /* special case: an eval '' executed within the DB package gets lexically
3456 * placed in the first non-DB CV rather than the current CV - this
3457 * allows the debugger to execute code, find lexicals etc, in the
3458 * scope of the code being debugged. Passing &seq gets find_runcv
3459 * to do the dirty work for us */
3460 runcv = find_runcv(&seq);
3462 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3463 PUSHEVAL(cx, 0, Nullgv);
3464 cx->blk_eval.retop = PL_op->op_next;
3466 /* prepare to compile string */
3468 if (PERLDB_LINE && PL_curstash != PL_debstash)
3469 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3471 ret = doeval(gimme, NULL, runcv, seq);
3472 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3473 && ret != PL_op->op_next) { /* Successive compilation. */
3474 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3476 return DOCATCH(ret);
3486 register PERL_CONTEXT *cx;
3488 const U8 save_flags = PL_op -> op_flags;
3493 retop = cx->blk_eval.retop;
3496 if (gimme == G_VOID)
3498 else if (gimme == G_SCALAR) {
3501 if (SvFLAGS(TOPs) & SVs_TEMP)
3504 *MARK = sv_mortalcopy(TOPs);
3508 *MARK = &PL_sv_undef;
3513 /* in case LEAVE wipes old return values */
3514 for (mark = newsp + 1; mark <= SP; mark++) {
3515 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3516 *mark = sv_mortalcopy(*mark);
3517 TAINT_NOT; /* Each item is independent */
3521 PL_curpm = newpm; /* Don't pop $1 et al till now */
3524 assert(CvDEPTH(PL_compcv) == 1);
3526 CvDEPTH(PL_compcv) = 0;
3529 if (optype == OP_REQUIRE &&
3530 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3532 /* Unassume the success we assumed earlier. */
3533 SV *nsv = cx->blk_eval.old_namesv;
3534 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3535 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3536 /* die_where() did LEAVE, or we won't be here */
3540 if (!(save_flags & OPf_SPECIAL))
3541 sv_setpvn(ERRSV,"",0);
3550 register PERL_CONTEXT *cx;
3551 const I32 gimme = GIMME_V;
3556 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3558 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3560 PL_in_eval = EVAL_INEVAL;
3561 sv_setpvn(ERRSV,"",0);
3563 return DOCATCH(PL_op->op_next);
3573 register PERL_CONTEXT *cx;
3580 if (gimme == G_VOID)
3582 else if (gimme == G_SCALAR) {
3585 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3588 *MARK = sv_mortalcopy(TOPs);
3592 *MARK = &PL_sv_undef;
3597 /* in case LEAVE wipes old return values */
3598 for (mark = newsp + 1; mark <= SP; mark++) {
3599 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3600 *mark = sv_mortalcopy(*mark);
3601 TAINT_NOT; /* Each item is independent */
3605 PL_curpm = newpm; /* Don't pop $1 et al till now */
3608 sv_setpvn(ERRSV,"",0);
3613 S_doparseform(pTHX_ SV *sv)
3616 register char *s = SvPV_force(sv, len);
3617 register char *send = s + len;
3618 register char *base = Nullch;
3619 register I32 skipspaces = 0;
3620 bool noblank = FALSE;
3621 bool repeat = FALSE;
3622 bool postspace = FALSE;
3628 bool unchopnum = FALSE;
3629 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3632 Perl_croak(aTHX_ "Null picture in formline");
3634 /* estimate the buffer size needed */
3635 for (base = s; s <= send; s++) {
3636 if (*s == '\n' || *s == '@' || *s == '^')
3642 New(804, fops, maxops, U32);
3647 *fpc++ = FF_LINEMARK;
3648 noblank = repeat = FALSE;
3666 case ' ': case '\t':
3673 } /* else FALL THROUGH */
3681 *fpc++ = FF_LITERAL;
3689 *fpc++ = (U16)skipspaces;
3693 *fpc++ = FF_NEWLINE;
3697 arg = fpc - linepc + 1;
3704 *fpc++ = FF_LINEMARK;
3705 noblank = repeat = FALSE;
3714 ischop = s[-1] == '^';
3720 arg = (s - base) - 1;
3722 *fpc++ = FF_LITERAL;
3730 *fpc++ = 2; /* skip the @* or ^* */
3732 *fpc++ = FF_LINESNGL;
3735 *fpc++ = FF_LINEGLOB;
3737 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3738 arg = ischop ? 512 : 0;
3743 const char * const f = ++s;
3746 arg |= 256 + (s - f);
3748 *fpc++ = s - base; /* fieldsize for FETCH */
3749 *fpc++ = FF_DECIMAL;
3751 unchopnum |= ! ischop;
3753 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3754 arg = ischop ? 512 : 0;
3756 s++; /* skip the '0' first */
3760 const char * const f = ++s;
3763 arg |= 256 + (s - f);
3765 *fpc++ = s - base; /* fieldsize for FETCH */
3766 *fpc++ = FF_0DECIMAL;
3768 unchopnum |= ! ischop;
3772 bool ismore = FALSE;
3775 while (*++s == '>') ;
3776 prespace = FF_SPACE;
3778 else if (*s == '|') {
3779 while (*++s == '|') ;
3780 prespace = FF_HALFSPACE;
3785 while (*++s == '<') ;
3788 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3792 *fpc++ = s - base; /* fieldsize for FETCH */
3794 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3797 *fpc++ = (U16)prespace;
3811 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3813 { /* need to jump to the next word */
3815 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3816 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3817 s = SvPVX(sv) + SvCUR(sv) + z;
3819 Copy(fops, s, arg, U32);
3821 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3824 if (unchopnum && repeat)
3825 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3831 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3833 /* Can value be printed in fldsize chars, using %*.*f ? */
3837 int intsize = fldsize - (value < 0 ? 1 : 0);
3844 while (intsize--) pwr *= 10.0;
3845 while (frcsize--) eps /= 10.0;
3848 if (value + eps >= pwr)
3851 if (value - eps <= -pwr)
3858 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3861 SV *datasv = FILTER_DATA(idx);
3862 const int filter_has_file = IoLINES(datasv);
3863 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3864 SV *filter_state = (SV *)IoTOP_GV(datasv);
3865 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3868 /* I was having segfault trouble under Linux 2.2.5 after a
3869 parse error occured. (Had to hack around it with a test
3870 for PL_error_count == 0.) Solaris doesn't segfault --
3871 not sure where the trouble is yet. XXX */
3873 if (filter_has_file) {
3874 len = FILTER_READ(idx+1, buf_sv, maxlen);
3877 if (filter_sub && len >= 0) {
3888 PUSHs(sv_2mortal(newSViv(maxlen)));
3890 PUSHs(filter_state);
3893 count = call_sv(filter_sub, G_SCALAR);
3909 IoLINES(datasv) = 0;
3910 if (filter_child_proc) {
3911 SvREFCNT_dec(filter_child_proc);
3912 IoFMT_GV(datasv) = Nullgv;
3915 SvREFCNT_dec(filter_state);
3916 IoTOP_GV(datasv) = Nullgv;
3919 SvREFCNT_dec(filter_sub);
3920 IoBOTTOM_GV(datasv) = Nullgv;
3922 filter_del(run_user_filter);
3928 /* perhaps someone can come up with a better name for
3929 this? it is not really "absolute", per se ... */
3931 S_path_is_absolute(pTHX_ const char *name)
3933 if (PERL_FILE_IS_ABSOLUTE(name)
3934 #ifdef MACOS_TRADITIONAL
3937 || (*name == '.' && (name[1] == '/' ||
3938 (name[1] == '.' && name[2] == '/'))))
3949 * c-indentation-style: bsd
3951 * indent-tabs-mode: t
3954 * ex: set ts=8 sts=4 sw=4 noet: