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 if (CxTYPE(cx) == CXt_EVAL) {
2303 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2305 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2307 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2308 /* put @_ back onto stack */
2309 AV* av = cx->blk_sub.argarray;
2311 items = AvFILLp(av) + 1;
2312 EXTEND(SP, items+1); /* @_ could have been extended. */
2313 Copy(AvARRAY(av), SP + 1, items, SV*);
2314 SvREFCNT_dec(GvAV(PL_defgv));
2315 GvAV(PL_defgv) = cx->blk_sub.savearray;
2317 /* abandon @_ if it got reified */
2322 av_extend(av, items-1);
2324 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2327 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2329 av = GvAV(PL_defgv);
2330 items = AvFILLp(av) + 1;
2331 EXTEND(SP, items+1); /* @_ could have been extended. */
2332 Copy(AvARRAY(av), SP + 1, items, SV*);
2336 if (CxTYPE(cx) == CXt_SUB &&
2337 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2338 SvREFCNT_dec(cx->blk_sub.cv);
2339 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2340 LEAVE_SCOPE(oldsave);
2342 /* Now do some callish stuff. */
2344 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2346 OP* retop = cx->blk_sub.retop;
2349 for (index=0; index<items; index++)
2350 sv_2mortal(SP[-index]);
2352 #ifdef PERL_XSUB_OLDSTYLE
2353 if (CvOLDSTYLE(cv)) {
2354 I32 (*fp3)(int,int,int);
2359 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2360 items = (*fp3)(CvXSUBANY(cv).any_i32,
2361 mark - PL_stack_base + 1,
2363 SP = PL_stack_base + items;
2366 #endif /* PERL_XSUB_OLDSTYLE */
2371 /* XS subs don't have a CxSUB, so pop it */
2372 POPBLOCK(cx, PL_curpm);
2373 /* Push a mark for the start of arglist */
2376 (void)(*CvXSUB(cv))(aTHX_ cv);
2382 AV* padlist = CvPADLIST(cv);
2383 if (CxTYPE(cx) == CXt_EVAL) {
2384 PL_in_eval = cx->blk_eval.old_in_eval;
2385 PL_eval_root = cx->blk_eval.old_eval_root;
2386 cx->cx_type = CXt_SUB;
2387 cx->blk_sub.hasargs = 0;
2389 cx->blk_sub.cv = cv;
2390 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2393 if (CvDEPTH(cv) < 2)
2394 (void)SvREFCNT_inc(cv);
2396 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2397 sub_crush_depth(cv);
2398 pad_push(padlist, CvDEPTH(cv));
2400 PAD_SET_CUR(padlist, CvDEPTH(cv));
2401 if (cx->blk_sub.hasargs)
2403 AV* av = (AV*)PAD_SVl(0);
2406 cx->blk_sub.savearray = GvAV(PL_defgv);
2407 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2408 CX_CURPAD_SAVE(cx->blk_sub);
2409 cx->blk_sub.argarray = av;
2411 if (items >= AvMAX(av) + 1) {
2413 if (AvARRAY(av) != ary) {
2414 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2415 SvPV_set(av, (char*)ary);
2417 if (items >= AvMAX(av) + 1) {
2418 AvMAX(av) = items - 1;
2419 Renew(ary,items+1,SV*);
2421 SvPV_set(av, (char*)ary);
2425 Copy(mark,AvARRAY(av),items,SV*);
2426 AvFILLp(av) = items - 1;
2427 assert(!AvREAL(av));
2429 /* transfer 'ownership' of refcnts to new @_ */
2439 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2441 * We do not care about using sv to call CV;
2442 * it's for informational purposes only.
2444 SV *sv = GvSV(PL_DBsub);
2448 if (PERLDB_SUB_NN) {
2449 int type = SvTYPE(sv);
2450 if (type < SVt_PVIV && type != SVt_IV)
2451 sv_upgrade(sv, SVt_PVIV);
2453 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2455 gv_efullname3(sv, CvGV(cv), Nullch);
2458 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2459 PUSHMARK( PL_stack_sp );
2460 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2464 RETURNOP(CvSTART(cv));
2468 label = SvPV(sv,n_a);
2469 if (!(do_dump || *label))
2470 DIE(aTHX_ must_have_label);
2473 else if (PL_op->op_flags & OPf_SPECIAL) {
2475 DIE(aTHX_ must_have_label);
2478 label = cPVOP->op_pv;
2480 if (label && *label) {
2482 bool leaving_eval = FALSE;
2483 bool in_block = FALSE;
2484 PERL_CONTEXT *last_eval_cx = 0;
2488 PL_lastgotoprobe = 0;
2490 for (ix = cxstack_ix; ix >= 0; ix--) {
2492 switch (CxTYPE(cx)) {
2494 leaving_eval = TRUE;
2495 if (!CxTRYBLOCK(cx)) {
2496 gotoprobe = (last_eval_cx ?
2497 last_eval_cx->blk_eval.old_eval_root :
2502 /* else fall through */
2504 gotoprobe = cx->blk_oldcop->op_sibling;
2510 gotoprobe = cx->blk_oldcop->op_sibling;
2513 gotoprobe = PL_main_root;
2516 if (CvDEPTH(cx->blk_sub.cv)) {
2517 gotoprobe = CvROOT(cx->blk_sub.cv);
2523 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2526 DIE(aTHX_ "panic: goto");
2527 gotoprobe = PL_main_root;
2531 retop = dofindlabel(gotoprobe, label,
2532 enterops, enterops + GOTO_DEPTH);
2536 PL_lastgotoprobe = gotoprobe;
2539 DIE(aTHX_ "Can't find label %s", label);
2541 /* if we're leaving an eval, check before we pop any frames
2542 that we're not going to punt, otherwise the error
2545 if (leaving_eval && *enterops && enterops[1]) {
2547 for (i = 1; enterops[i]; i++)
2548 if (enterops[i]->op_type == OP_ENTERITER)
2549 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2552 /* pop unwanted frames */
2554 if (ix < cxstack_ix) {
2561 oldsave = PL_scopestack[PL_scopestack_ix];
2562 LEAVE_SCOPE(oldsave);
2565 /* push wanted frames */
2567 if (*enterops && enterops[1]) {
2569 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2570 for (; enterops[ix]; ix++) {
2571 PL_op = enterops[ix];
2572 /* Eventually we may want to stack the needed arguments
2573 * for each op. For now, we punt on the hard ones. */
2574 if (PL_op->op_type == OP_ENTERITER)
2575 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2576 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2584 if (!retop) retop = PL_main_start;
2586 PL_restartop = retop;
2587 PL_do_undump = TRUE;
2591 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2592 PL_do_undump = FALSE;
2608 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2610 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2613 PL_exit_flags |= PERL_EXIT_EXPECTED;
2615 PUSHs(&PL_sv_undef);
2623 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2624 register I32 match = I_32(value);
2627 if (((NV)match) > value)
2628 --match; /* was fractional--truncate other way */
2630 match -= cCOP->uop.scop.scop_offset;
2633 else if (match > cCOP->uop.scop.scop_max)
2634 match = cCOP->uop.scop.scop_max;
2635 PL_op = cCOP->uop.scop.scop_next[match];
2645 PL_op = PL_op->op_next; /* can't assume anything */
2648 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2649 match -= cCOP->uop.scop.scop_offset;
2652 else if (match > cCOP->uop.scop.scop_max)
2653 match = cCOP->uop.scop.scop_max;
2654 PL_op = cCOP->uop.scop.scop_next[match];
2663 S_save_lines(pTHX_ AV *array, SV *sv)
2665 const char *s = SvPVX_const(sv);
2666 const char *send = SvPVX_const(sv) + SvCUR(sv);
2669 while (s && s < send) {
2671 SV *tmpstr = NEWSV(85,0);
2673 sv_upgrade(tmpstr, SVt_PVMG);
2674 t = strchr(s, '\n');
2680 sv_setpvn(tmpstr, s, t - s);
2681 av_store(array, line++, tmpstr);
2687 S_docatch_body(pTHX)
2694 S_docatch(pTHX_ OP *o)
2697 OP * const oldop = PL_op;
2701 assert(CATCH_GET == TRUE);
2708 assert(cxstack_ix >= 0);
2709 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2710 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2715 /* die caught by an inner eval - continue inner loop */
2717 /* NB XXX we rely on the old popped CxEVAL still being at the top
2718 * of the stack; the way die_where() currently works, this
2719 * assumption is valid. In theory The cur_top_env value should be
2720 * returned in another global, the way retop (aka PL_restartop)
2722 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2725 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2727 PL_op = PL_restartop;
2744 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2745 /* sv Text to convert to OP tree. */
2746 /* startop op_free() this to undo. */
2747 /* code Short string id of the caller. */
2749 dVAR; dSP; /* Make POPBLOCK work. */
2752 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2756 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2757 char *tmpbuf = tbuf;
2760 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2765 /* switch to eval mode */
2767 if (IN_PERL_COMPILETIME) {
2768 SAVECOPSTASH_FREE(&PL_compiling);
2769 CopSTASH_set(&PL_compiling, PL_curstash);
2771 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2772 SV *sv = sv_newmortal();
2773 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2774 code, (unsigned long)++PL_evalseq,
2775 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2779 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2780 SAVECOPFILE_FREE(&PL_compiling);
2781 CopFILE_set(&PL_compiling, tmpbuf+2);
2782 SAVECOPLINE(&PL_compiling);
2783 CopLINE_set(&PL_compiling, 1);
2784 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2785 deleting the eval's FILEGV from the stash before gv_check() runs
2786 (i.e. before run-time proper). To work around the coredump that
2787 ensues, we always turn GvMULTI_on for any globals that were
2788 introduced within evals. See force_ident(). GSAR 96-10-12 */
2789 safestr = savepv(tmpbuf);
2790 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2792 #ifdef OP_IN_REGISTER
2798 /* we get here either during compilation, or via pp_regcomp at runtime */
2799 runtime = IN_PERL_RUNTIME;
2801 runcv = find_runcv(NULL);
2804 PL_op->op_type = OP_ENTEREVAL;
2805 PL_op->op_flags = 0; /* Avoid uninit warning. */
2806 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2807 PUSHEVAL(cx, 0, Nullgv);
2810 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2812 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2813 POPBLOCK(cx,PL_curpm);
2816 (*startop)->op_type = OP_NULL;
2817 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2819 /* XXX DAPM do this properly one year */
2820 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2822 if (IN_PERL_COMPILETIME)
2823 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2824 #ifdef OP_IN_REGISTER
2832 =for apidoc find_runcv
2834 Locate the CV corresponding to the currently executing sub or eval.
2835 If db_seqp is non_null, skip CVs that are in the DB package and populate
2836 *db_seqp with the cop sequence number at the point that the DB:: code was
2837 entered. (allows debuggers to eval in the scope of the breakpoint rather
2838 than in in the scope of the debugger itself).
2844 Perl_find_runcv(pTHX_ U32 *db_seqp)
2849 *db_seqp = PL_curcop->cop_seq;
2850 for (si = PL_curstackinfo; si; si = si->si_prev) {
2852 for (ix = si->si_cxix; ix >= 0; ix--) {
2853 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2854 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2855 CV *cv = cx->blk_sub.cv;
2856 /* skip DB:: code */
2857 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2858 *db_seqp = cx->blk_oldcop->cop_seq;
2863 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2871 /* Compile a require/do, an eval '', or a /(?{...})/.
2872 * In the last case, startop is non-null, and contains the address of
2873 * a pointer that should be set to the just-compiled code.
2874 * outside is the lexically enclosing CV (if any) that invoked us.
2877 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2879 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2884 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2885 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2890 SAVESPTR(PL_compcv);
2891 PL_compcv = (CV*)NEWSV(1104,0);
2892 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2893 CvEVAL_on(PL_compcv);
2894 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2895 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2897 CvOUTSIDE_SEQ(PL_compcv) = seq;
2898 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2900 /* set up a scratch pad */
2902 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2905 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2907 /* make sure we compile in the right package */
2909 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2910 SAVESPTR(PL_curstash);
2911 PL_curstash = CopSTASH(PL_curcop);
2913 SAVESPTR(PL_beginav);
2914 PL_beginav = newAV();
2915 SAVEFREESV(PL_beginav);
2916 SAVEI32(PL_error_count);
2918 /* try to compile it */
2920 PL_eval_root = Nullop;
2922 PL_curcop = &PL_compiling;
2923 PL_curcop->cop_arybase = 0;
2924 if (saveop && saveop->op_flags & OPf_SPECIAL)
2925 PL_in_eval |= EVAL_KEEPERR;
2927 sv_setpvn(ERRSV,"",0);
2928 if (yyparse() || PL_error_count || !PL_eval_root) {
2929 SV **newsp; /* Used by POPBLOCK. */
2930 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2931 I32 optype = 0; /* Might be reset by POPEVAL. */
2936 op_free(PL_eval_root);
2937 PL_eval_root = Nullop;
2939 SP = PL_stack_base + POPMARK; /* pop original mark */
2941 POPBLOCK(cx,PL_curpm);
2946 if (optype == OP_REQUIRE) {
2947 const char* msg = SvPVx(ERRSV, n_a);
2948 SV *nsv = cx->blk_eval.old_namesv;
2949 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2951 DIE(aTHX_ "%sCompilation failed in require",
2952 *msg ? msg : "Unknown error\n");
2955 const char* msg = SvPVx(ERRSV, n_a);
2957 POPBLOCK(cx,PL_curpm);
2959 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2960 (*msg ? msg : "Unknown error\n"));
2963 const char* msg = SvPVx(ERRSV, n_a);
2965 sv_setpv(ERRSV, "Compilation error");
2970 CopLINE_set(&PL_compiling, 0);
2972 *startop = PL_eval_root;
2974 SAVEFREEOP(PL_eval_root);
2976 /* Set the context for this new optree.
2977 * If the last op is an OP_REQUIRE, force scalar context.
2978 * Otherwise, propagate the context from the eval(). */
2979 if (PL_eval_root->op_type == OP_LEAVEEVAL
2980 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2981 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2983 scalar(PL_eval_root);
2984 else if (gimme & G_VOID)
2985 scalarvoid(PL_eval_root);
2986 else if (gimme & G_ARRAY)
2989 scalar(PL_eval_root);
2991 DEBUG_x(dump_eval());
2993 /* Register with debugger: */
2994 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2995 CV *cv = get_cv("DB::postponed", FALSE);
2999 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3001 call_sv((SV*)cv, G_DISCARD);
3005 /* compiled okay, so do it */
3007 CvDEPTH(PL_compcv) = 1;
3008 SP = PL_stack_base + POPMARK; /* pop original mark */
3009 PL_op = saveop; /* The caller may need it. */
3010 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3012 RETURNOP(PL_eval_start);
3016 S_doopen_pm(pTHX_ const char *name, const char *mode)
3018 #ifndef PERL_DISABLE_PMC
3019 const STRLEN namelen = strlen(name);
3022 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3023 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3024 const char * const pmc = SvPV_nolen(pmcsv);
3027 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3028 fp = PerlIO_open(name, mode);
3031 if (PerlLIO_stat(name, &pmstat) < 0 ||
3032 pmstat.st_mtime < pmcstat.st_mtime)
3034 fp = PerlIO_open(pmc, mode);
3037 fp = PerlIO_open(name, mode);
3040 SvREFCNT_dec(pmcsv);
3043 fp = PerlIO_open(name, mode);
3047 return PerlIO_open(name, mode);
3048 #endif /* !PERL_DISABLE_PMC */
3054 register PERL_CONTEXT *cx;
3058 char *tryname = Nullch;
3059 SV *namesv = Nullsv;
3061 const I32 gimme = GIMME_V;
3062 PerlIO *tryrsfp = 0;
3063 int filter_has_file = 0;
3064 GV *filter_child_proc = 0;
3065 SV *filter_state = 0;
3072 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3073 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3074 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3075 "v-string in use/require non-portable");
3077 sv = new_version(sv);
3078 if (!sv_derived_from(PL_patchlevel, "version"))
3079 (void *)upg_version(PL_patchlevel);
3080 if ( vcmp(sv,PL_patchlevel) > 0 )
3081 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3082 vstringify(sv), vstringify(PL_patchlevel));
3086 name = SvPV(sv, len);
3087 if (!(name && len > 0 && *name))
3088 DIE(aTHX_ "Null filename used");
3089 TAINT_PROPER("require");
3090 if (PL_op->op_type == OP_REQUIRE &&
3091 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3092 if (*svp != &PL_sv_undef)
3095 DIE(aTHX_ "Compilation failed in require");
3098 /* prepare to compile file */
3100 if (path_is_absolute(name)) {
3102 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3104 #ifdef MACOS_TRADITIONAL
3108 MacPerl_CanonDir(name, newname, 1);
3109 if (path_is_absolute(newname)) {
3111 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3116 AV *ar = GvAVn(PL_incgv);
3120 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3123 namesv = NEWSV(806, 0);
3124 for (i = 0; i <= AvFILL(ar); i++) {
3125 SV *dirsv = *av_fetch(ar, i, TRUE);
3131 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3132 && !sv_isobject(loader))
3134 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3137 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3138 PTR2UV(SvRV(dirsv)), name);
3139 tryname = SvPVX(namesv);
3150 if (sv_isobject(loader))
3151 count = call_method("INC", G_ARRAY);
3153 count = call_sv(loader, G_ARRAY);
3163 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3167 if (SvTYPE(arg) == SVt_PVGV) {
3168 IO *io = GvIO((GV *)arg);
3173 tryrsfp = IoIFP(io);
3174 if (IoTYPE(io) == IoTYPE_PIPE) {
3175 /* reading from a child process doesn't
3176 nest -- when returning from reading
3177 the inner module, the outer one is
3178 unreadable (closed?) I've tried to
3179 save the gv to manage the lifespan of
3180 the pipe, but this didn't help. XXX */
3181 filter_child_proc = (GV *)arg;
3182 (void)SvREFCNT_inc(filter_child_proc);
3185 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3186 PerlIO_close(IoOFP(io));
3198 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3200 (void)SvREFCNT_inc(filter_sub);
3203 filter_state = SP[i];
3204 (void)SvREFCNT_inc(filter_state);
3208 tryrsfp = PerlIO_open("/dev/null",
3224 filter_has_file = 0;
3225 if (filter_child_proc) {
3226 SvREFCNT_dec(filter_child_proc);
3227 filter_child_proc = 0;
3230 SvREFCNT_dec(filter_state);
3234 SvREFCNT_dec(filter_sub);
3239 if (!path_is_absolute(name)
3240 #ifdef MACOS_TRADITIONAL
3241 /* We consider paths of the form :a:b ambiguous and interpret them first
3242 as global then as local
3244 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3248 char *dir = SvPVx(dirsv, n_a);
3249 #ifdef MACOS_TRADITIONAL
3253 MacPerl_CanonDir(name, buf2, 1);
3254 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3258 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3260 sv_setpv(namesv, unixdir);
3261 sv_catpv(namesv, unixname);
3264 if (PL_origfilename[0] &&
3265 PL_origfilename[1] == ':' &&
3266 !(dir[0] && dir[1] == ':'))
3267 Perl_sv_setpvf(aTHX_ namesv,
3272 Perl_sv_setpvf(aTHX_ namesv,
3276 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3280 TAINT_PROPER("require");
3281 tryname = SvPVX(namesv);
3282 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3284 if (tryname[0] == '.' && tryname[1] == '/')
3293 SAVECOPFILE_FREE(&PL_compiling);
3294 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3295 SvREFCNT_dec(namesv);
3297 if (PL_op->op_type == OP_REQUIRE) {
3298 char *msgstr = name;
3299 if (namesv) { /* did we lookup @INC? */
3300 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3301 SV *dirmsgsv = NEWSV(0, 0);
3302 AV *ar = GvAVn(PL_incgv);
3304 sv_catpvn(msg, " in @INC", 8);
3305 if (instr(SvPVX_const(msg), ".h "))
3306 sv_catpv(msg, " (change .h to .ph maybe?)");
3307 if (instr(SvPVX_const(msg), ".ph "))
3308 sv_catpv(msg, " (did you run h2ph?)");
3309 sv_catpv(msg, " (@INC contains:");
3310 for (i = 0; i <= AvFILL(ar); i++) {
3312 const char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3313 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3314 sv_catsv(msg, dirmsgsv);
3316 sv_catpvn(msg, ")", 1);
3317 SvREFCNT_dec(dirmsgsv);
3318 msgstr = SvPV_nolen(msg);
3320 DIE(aTHX_ "Can't locate %s", msgstr);
3326 SETERRNO(0, SS_NORMAL);
3328 /* Assume success here to prevent recursive requirement. */
3330 /* Check whether a hook in @INC has already filled %INC */
3331 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3332 (void)hv_store(GvHVn(PL_incgv), name, len,
3333 (hook_sv ? SvREFCNT_inc(hook_sv)
3334 : newSVpv(CopFILE(&PL_compiling), 0)),
3340 lex_start(sv_2mortal(newSVpvn("",0)));
3341 SAVEGENERICSV(PL_rsfp_filters);
3342 PL_rsfp_filters = Nullav;
3347 SAVESPTR(PL_compiling.cop_warnings);
3348 if (PL_dowarn & G_WARN_ALL_ON)
3349 PL_compiling.cop_warnings = pWARN_ALL ;
3350 else if (PL_dowarn & G_WARN_ALL_OFF)
3351 PL_compiling.cop_warnings = pWARN_NONE ;
3352 else if (PL_taint_warn)
3353 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3355 PL_compiling.cop_warnings = pWARN_STD ;
3356 SAVESPTR(PL_compiling.cop_io);
3357 PL_compiling.cop_io = Nullsv;
3359 if (filter_sub || filter_child_proc) {
3360 SV *datasv = filter_add(run_user_filter, Nullsv);
3361 IoLINES(datasv) = filter_has_file;
3362 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3363 IoTOP_GV(datasv) = (GV *)filter_state;
3364 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3367 /* switch to eval mode */
3368 PUSHBLOCK(cx, CXt_EVAL, SP);
3369 PUSHEVAL(cx, name, Nullgv);
3370 cx->blk_eval.retop = PL_op->op_next;
3372 SAVECOPLINE(&PL_compiling);
3373 CopLINE_set(&PL_compiling, 0);
3377 /* Store and reset encoding. */
3378 encoding = PL_encoding;
3379 PL_encoding = Nullsv;
3381 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3383 /* Restore encoding. */
3384 PL_encoding = encoding;
3391 return pp_require();
3397 register PERL_CONTEXT *cx;
3399 const I32 gimme = GIMME_V, was = PL_sub_generation;
3400 char tbuf[TYPE_DIGITS(long) + 12];
3401 char *tmpbuf = tbuf;
3410 TAINT_PROPER("eval");
3416 /* switch to eval mode */
3418 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3419 SV *sv = sv_newmortal();
3420 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3421 (unsigned long)++PL_evalseq,
3422 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3426 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3427 SAVECOPFILE_FREE(&PL_compiling);
3428 CopFILE_set(&PL_compiling, tmpbuf+2);
3429 SAVECOPLINE(&PL_compiling);
3430 CopLINE_set(&PL_compiling, 1);
3431 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3432 deleting the eval's FILEGV from the stash before gv_check() runs
3433 (i.e. before run-time proper). To work around the coredump that
3434 ensues, we always turn GvMULTI_on for any globals that were
3435 introduced within evals. See force_ident(). GSAR 96-10-12 */
3436 safestr = savepv(tmpbuf);
3437 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3439 PL_hints = PL_op->op_targ;
3440 SAVESPTR(PL_compiling.cop_warnings);
3441 if (specialWARN(PL_curcop->cop_warnings))
3442 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3444 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3445 SAVEFREESV(PL_compiling.cop_warnings);
3447 SAVESPTR(PL_compiling.cop_io);
3448 if (specialCopIO(PL_curcop->cop_io))
3449 PL_compiling.cop_io = PL_curcop->cop_io;
3451 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3452 SAVEFREESV(PL_compiling.cop_io);
3454 /* special case: an eval '' executed within the DB package gets lexically
3455 * placed in the first non-DB CV rather than the current CV - this
3456 * allows the debugger to execute code, find lexicals etc, in the
3457 * scope of the code being debugged. Passing &seq gets find_runcv
3458 * to do the dirty work for us */
3459 runcv = find_runcv(&seq);
3461 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3462 PUSHEVAL(cx, 0, Nullgv);
3463 cx->blk_eval.retop = PL_op->op_next;
3465 /* prepare to compile string */
3467 if (PERLDB_LINE && PL_curstash != PL_debstash)
3468 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3470 ret = doeval(gimme, NULL, runcv, seq);
3471 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3472 && ret != PL_op->op_next) { /* Successive compilation. */
3473 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3475 return DOCATCH(ret);
3485 register PERL_CONTEXT *cx;
3487 const U8 save_flags = PL_op -> op_flags;
3492 retop = cx->blk_eval.retop;
3495 if (gimme == G_VOID)
3497 else if (gimme == G_SCALAR) {
3500 if (SvFLAGS(TOPs) & SVs_TEMP)
3503 *MARK = sv_mortalcopy(TOPs);
3507 *MARK = &PL_sv_undef;
3512 /* in case LEAVE wipes old return values */
3513 for (mark = newsp + 1; mark <= SP; mark++) {
3514 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3515 *mark = sv_mortalcopy(*mark);
3516 TAINT_NOT; /* Each item is independent */
3520 PL_curpm = newpm; /* Don't pop $1 et al till now */
3523 assert(CvDEPTH(PL_compcv) == 1);
3525 CvDEPTH(PL_compcv) = 0;
3528 if (optype == OP_REQUIRE &&
3529 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3531 /* Unassume the success we assumed earlier. */
3532 SV *nsv = cx->blk_eval.old_namesv;
3533 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3534 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3535 /* die_where() did LEAVE, or we won't be here */
3539 if (!(save_flags & OPf_SPECIAL))
3540 sv_setpvn(ERRSV,"",0);
3549 register PERL_CONTEXT *cx;
3550 const I32 gimme = GIMME_V;
3555 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3557 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3559 PL_in_eval = EVAL_INEVAL;
3560 sv_setpvn(ERRSV,"",0);
3562 return DOCATCH(PL_op->op_next);
3572 register PERL_CONTEXT *cx;
3579 if (gimme == G_VOID)
3581 else if (gimme == G_SCALAR) {
3584 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3587 *MARK = sv_mortalcopy(TOPs);
3591 *MARK = &PL_sv_undef;
3596 /* in case LEAVE wipes old return values */
3597 for (mark = newsp + 1; mark <= SP; mark++) {
3598 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3599 *mark = sv_mortalcopy(*mark);
3600 TAINT_NOT; /* Each item is independent */
3604 PL_curpm = newpm; /* Don't pop $1 et al till now */
3607 sv_setpvn(ERRSV,"",0);
3612 S_doparseform(pTHX_ SV *sv)
3615 register char *s = SvPV_force(sv, len);
3616 register char *send = s + len;
3617 register char *base = Nullch;
3618 register I32 skipspaces = 0;
3619 bool noblank = FALSE;
3620 bool repeat = FALSE;
3621 bool postspace = FALSE;
3627 bool unchopnum = FALSE;
3628 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3631 Perl_croak(aTHX_ "Null picture in formline");
3633 /* estimate the buffer size needed */
3634 for (base = s; s <= send; s++) {
3635 if (*s == '\n' || *s == '@' || *s == '^')
3641 New(804, fops, maxops, U32);
3646 *fpc++ = FF_LINEMARK;
3647 noblank = repeat = FALSE;
3665 case ' ': case '\t':
3672 } /* else FALL THROUGH */
3680 *fpc++ = FF_LITERAL;
3688 *fpc++ = (U16)skipspaces;
3692 *fpc++ = FF_NEWLINE;
3696 arg = fpc - linepc + 1;
3703 *fpc++ = FF_LINEMARK;
3704 noblank = repeat = FALSE;
3713 ischop = s[-1] == '^';
3719 arg = (s - base) - 1;
3721 *fpc++ = FF_LITERAL;
3729 *fpc++ = 2; /* skip the @* or ^* */
3731 *fpc++ = FF_LINESNGL;
3734 *fpc++ = FF_LINEGLOB;
3736 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3737 arg = ischop ? 512 : 0;
3742 const char * const f = ++s;
3745 arg |= 256 + (s - f);
3747 *fpc++ = s - base; /* fieldsize for FETCH */
3748 *fpc++ = FF_DECIMAL;
3750 unchopnum |= ! ischop;
3752 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3753 arg = ischop ? 512 : 0;
3755 s++; /* skip the '0' first */
3759 const char * const f = ++s;
3762 arg |= 256 + (s - f);
3764 *fpc++ = s - base; /* fieldsize for FETCH */
3765 *fpc++ = FF_0DECIMAL;
3767 unchopnum |= ! ischop;
3771 bool ismore = FALSE;
3774 while (*++s == '>') ;
3775 prespace = FF_SPACE;
3777 else if (*s == '|') {
3778 while (*++s == '|') ;
3779 prespace = FF_HALFSPACE;
3784 while (*++s == '<') ;
3787 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3791 *fpc++ = s - base; /* fieldsize for FETCH */
3793 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3796 *fpc++ = (U16)prespace;
3810 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3812 { /* need to jump to the next word */
3814 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3815 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3816 s = SvPVX(sv) + SvCUR(sv) + z;
3818 Copy(fops, s, arg, U32);
3820 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3823 if (unchopnum && repeat)
3824 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3830 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3832 /* Can value be printed in fldsize chars, using %*.*f ? */
3836 int intsize = fldsize - (value < 0 ? 1 : 0);
3843 while (intsize--) pwr *= 10.0;
3844 while (frcsize--) eps /= 10.0;
3847 if (value + eps >= pwr)
3850 if (value - eps <= -pwr)
3857 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3860 SV *datasv = FILTER_DATA(idx);
3861 const int filter_has_file = IoLINES(datasv);
3862 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3863 SV *filter_state = (SV *)IoTOP_GV(datasv);
3864 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3867 /* I was having segfault trouble under Linux 2.2.5 after a
3868 parse error occured. (Had to hack around it with a test
3869 for PL_error_count == 0.) Solaris doesn't segfault --
3870 not sure where the trouble is yet. XXX */
3872 if (filter_has_file) {
3873 len = FILTER_READ(idx+1, buf_sv, maxlen);
3876 if (filter_sub && len >= 0) {
3887 PUSHs(sv_2mortal(newSViv(maxlen)));
3889 PUSHs(filter_state);
3892 count = call_sv(filter_sub, G_SCALAR);
3908 IoLINES(datasv) = 0;
3909 if (filter_child_proc) {
3910 SvREFCNT_dec(filter_child_proc);
3911 IoFMT_GV(datasv) = Nullgv;
3914 SvREFCNT_dec(filter_state);
3915 IoTOP_GV(datasv) = Nullgv;
3918 SvREFCNT_dec(filter_sub);
3919 IoBOTTOM_GV(datasv) = Nullgv;
3921 filter_del(run_user_filter);
3927 /* perhaps someone can come up with a better name for
3928 this? it is not really "absolute", per se ... */
3930 S_path_is_absolute(pTHX_ const char *name)
3932 if (PERL_FILE_IS_ABSOLUTE(name)
3933 #ifdef MACOS_TRADITIONAL
3936 || (*name == '.' && (name[1] == '/' ||
3937 (name[1] == '.' && name[2] == '/'))))
3948 * c-indentation-style: bsd
3950 * indent-tabs-mode: t
3953 * ex: set ts=8 sts=4 sw=4 noet: