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;
82 MAGIC *mg = Null(MAGIC*);
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
96 if (PL_op->op_flags & OPf_STACKED) {
97 /* multiple args; concatentate them */
99 tmpstr = PAD_SV(ARGTARG);
100 sv_setpvn(tmpstr, "", 0);
101 while (++MARK <= SP) {
102 if (PL_amagic_generation) {
104 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
107 sv_setsv(tmpstr, sv);
111 sv_catsv(tmpstr, *MARK);
120 SV *sv = SvRV(tmpstr);
122 mg = mg_find(sv, PERL_MAGIC_qr);
125 regexp *re = (regexp *)mg->mg_obj;
126 ReREFCNT_dec(PM_GETRE(pm));
127 PM_SETRE(pm, ReREFCNT_inc(re));
131 const char *t = SvPV_const(tmpstr, len);
133 /* Check against the last compiled regexp. */
134 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
135 PM_GETRE(pm)->prelen != (I32)len ||
136 memNE(PM_GETRE(pm)->precomp, t, len))
139 ReREFCNT_dec(PM_GETRE(pm));
140 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
142 if (PL_op->op_flags & OPf_SPECIAL)
143 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
145 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
147 pm->op_pmdynflags |= PMdf_DYN_UTF8;
149 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
150 if (pm->op_pmdynflags & PMdf_UTF8)
151 t = (char*)bytes_to_utf8((U8*)t, &len);
153 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
154 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
156 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
157 inside tie/overload accessors. */
161 #ifndef INCOMPLETE_TAINTS
164 pm->op_pmdynflags |= PMdf_TAINTED;
166 pm->op_pmdynflags &= ~PMdf_TAINTED;
170 if (!PM_GETRE(pm)->prelen && PL_curpm)
172 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
173 pm->op_pmflags |= PMf_WHITE;
175 pm->op_pmflags &= ~PMf_WHITE;
177 /* XXX runtime compiled output needs to move to the pad */
178 if (pm->op_pmflags & PMf_KEEP) {
179 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
180 #if !defined(USE_ITHREADS)
181 /* XXX can't change the optree at runtime either */
182 cLOGOP->op_first->op_next = PL_op->op_next;
191 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
192 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
193 register SV * const dstr = cx->sb_dstr;
194 register char *s = cx->sb_s;
195 register char *m = cx->sb_m;
196 char *orig = cx->sb_orig;
197 register REGEXP * const rx = cx->sb_rx;
199 REGEXP *old = PM_GETRE(pm);
206 rxres_restore(&cx->sb_rxres, rx);
207 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
209 if (cx->sb_iters++) {
210 const I32 saviters = cx->sb_iters;
211 if (cx->sb_iters > cx->sb_maxiters)
212 DIE(aTHX_ "Substitution loop");
214 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
215 cx->sb_rxtainted |= 2;
216 sv_catsv(dstr, POPs);
219 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
220 s == m, cx->sb_targ, NULL,
221 ((cx->sb_rflags & REXEC_COPY_STR)
222 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
223 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
225 SV *targ = cx->sb_targ;
227 assert(cx->sb_strend >= s);
228 if(cx->sb_strend > s) {
229 if (DO_UTF8(dstr) && !SvUTF8(targ))
230 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
232 sv_catpvn(dstr, s, cx->sb_strend - s);
234 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
236 #ifdef PERL_OLD_COPY_ON_WRITE
238 sv_force_normal_flags(targ, SV_COW_DROP_PV);
244 SvPV_set(targ, SvPVX(dstr));
245 SvCUR_set(targ, SvCUR(dstr));
246 SvLEN_set(targ, SvLEN(dstr));
249 SvPV_set(dstr, (char*)0);
252 TAINT_IF(cx->sb_rxtainted & 1);
253 PUSHs(sv_2mortal(newSViv(saviters - 1)));
255 (void)SvPOK_only_UTF8(targ);
256 TAINT_IF(cx->sb_rxtainted);
260 LEAVE_SCOPE(cx->sb_oldsave);
263 RETURNOP(pm->op_next);
265 cx->sb_iters = saviters;
267 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
270 cx->sb_orig = orig = rx->subbeg;
272 cx->sb_strend = s + (cx->sb_strend - m);
274 cx->sb_m = m = rx->startp[0] + orig;
276 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
277 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
279 sv_catpvn(dstr, s, m-s);
281 cx->sb_s = rx->endp[0] + orig;
282 { /* Update the pos() information. */
283 SV *sv = cx->sb_targ;
286 if (SvTYPE(sv) < SVt_PVMG)
287 SvUPGRADE(sv, SVt_PVMG);
288 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
289 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
290 mg = mg_find(sv, PERL_MAGIC_regex_global);
298 (void)ReREFCNT_inc(rx);
299 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
300 rxres_save(&cx->sb_rxres, rx);
301 RETURNOP(pm->op_pmreplstart);
305 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
310 if (!p || p[1] < rx->nparens) {
311 #ifdef PERL_OLD_COPY_ON_WRITE
312 i = 7 + rx->nparens * 2;
314 i = 6 + rx->nparens * 2;
323 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
324 RX_MATCH_COPIED_off(rx);
326 #ifdef PERL_OLD_COPY_ON_WRITE
327 *p++ = PTR2UV(rx->saved_copy);
328 rx->saved_copy = Nullsv;
333 *p++ = PTR2UV(rx->subbeg);
334 *p++ = (UV)rx->sublen;
335 for (i = 0; i <= rx->nparens; ++i) {
336 *p++ = (UV)rx->startp[i];
337 *p++ = (UV)rx->endp[i];
342 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
347 RX_MATCH_COPY_FREE(rx);
348 RX_MATCH_COPIED_set(rx, *p);
351 #ifdef PERL_OLD_COPY_ON_WRITE
353 SvREFCNT_dec (rx->saved_copy);
354 rx->saved_copy = INT2PTR(SV*,*p);
360 rx->subbeg = INT2PTR(char*,*p++);
361 rx->sublen = (I32)(*p++);
362 for (i = 0; i <= rx->nparens; ++i) {
363 rx->startp[i] = (I32)(*p++);
364 rx->endp[i] = (I32)(*p++);
369 Perl_rxres_free(pTHX_ void **rsp)
374 Safefree(INT2PTR(char*,*p));
375 #ifdef PERL_OLD_COPY_ON_WRITE
377 SvREFCNT_dec (INT2PTR(SV*,p[1]));
387 dSP; dMARK; dORIGMARK;
388 register SV *tmpForm = *++MARK;
393 register SV *sv = Nullsv;
394 const char *item = Nullch;
398 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
399 const char *chophere = Nullch;
400 char *linemark = Nullch;
402 bool gotsome = FALSE;
404 STRLEN fudge = SvPOK(tmpForm)
405 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
406 bool item_is_utf8 = FALSE;
407 bool targ_is_utf8 = FALSE;
413 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
414 if (SvREADONLY(tmpForm)) {
415 SvREADONLY_off(tmpForm);
416 parseres = doparseform(tmpForm);
417 SvREADONLY_on(tmpForm);
420 parseres = doparseform(tmpForm);
424 SvPV_force(PL_formtarget, len);
425 if (DO_UTF8(PL_formtarget))
427 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
429 f = SvPV_const(tmpForm, len);
430 /* need to jump to the next word */
431 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
435 const char *name = "???";
438 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
439 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
440 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
441 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
442 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
444 case FF_CHECKNL: name = "CHECKNL"; break;
445 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
446 case FF_SPACE: name = "SPACE"; break;
447 case FF_HALFSPACE: name = "HALFSPACE"; break;
448 case FF_ITEM: name = "ITEM"; break;
449 case FF_CHOP: name = "CHOP"; break;
450 case FF_LINEGLOB: name = "LINEGLOB"; break;
451 case FF_NEWLINE: name = "NEWLINE"; break;
452 case FF_MORE: name = "MORE"; break;
453 case FF_LINEMARK: name = "LINEMARK"; break;
454 case FF_END: name = "END"; break;
455 case FF_0DECIMAL: name = "0DECIMAL"; break;
456 case FF_LINESNGL: name = "LINESNGL"; break;
459 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
461 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
472 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
473 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
475 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
476 t = SvEND(PL_formtarget);
479 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
480 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
482 sv_utf8_upgrade(PL_formtarget);
483 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
484 t = SvEND(PL_formtarget);
504 if (ckWARN(WARN_SYNTAX))
505 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
512 const char *s = item = SvPV_const(sv, len);
515 itemsize = sv_len_utf8(sv);
516 if (itemsize != (I32)len) {
518 if (itemsize > fieldsize) {
519 itemsize = fieldsize;
520 itembytes = itemsize;
521 sv_pos_u2b(sv, &itembytes, 0);
525 send = chophere = s + itembytes;
535 sv_pos_b2u(sv, &itemsize);
539 item_is_utf8 = FALSE;
540 if (itemsize > fieldsize)
541 itemsize = fieldsize;
542 send = chophere = s + itemsize;
556 const char *s = item = SvPV_const(sv, len);
559 itemsize = sv_len_utf8(sv);
560 if (itemsize != (I32)len) {
562 if (itemsize <= fieldsize) {
563 const char *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 const char *const send = chophere = s + itemsize;
617 itemsize = fieldsize;
618 send = chophere = s + itemsize;
619 while (s < send || (s == send && isSPACE(*s))) {
629 if (strchr(PL_chopset, *s))
634 itemsize = chophere - item;
640 arg = fieldsize - itemsize;
649 arg = fieldsize - itemsize;
660 const char *s = item;
664 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
666 sv_utf8_upgrade(PL_formtarget);
667 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
668 t = SvEND(PL_formtarget);
672 if (UTF8_IS_CONTINUED(*s)) {
673 STRLEN skip = UTF8SKIP(s);
690 if ( !((*t++ = *s++) & ~31) )
696 if (targ_is_utf8 && !item_is_utf8) {
697 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
699 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
700 for (; t < SvEND(PL_formtarget); t++) {
713 const int ch = *t++ = *s++;
716 if ( !((*t++ = *s++) & ~31) )
725 const char *s = chophere;
727 while (*s && isSPACE(*s))
743 const char *s = item = SvPV_const(sv, len);
745 if ((item_is_utf8 = DO_UTF8(sv)))
746 itemsize = sv_len_utf8(sv);
748 bool chopped = FALSE;
749 const char *const send = s + len;
751 chophere = s + itemsize;
767 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
769 SvUTF8_on(PL_formtarget);
771 SvCUR_set(sv, chophere - item);
772 sv_catsv(PL_formtarget, sv);
773 SvCUR_set(sv, itemsize);
775 sv_catsv(PL_formtarget, sv);
777 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
778 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
779 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
788 #if defined(USE_LONG_DOUBLE)
789 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
791 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
796 #if defined(USE_LONG_DOUBLE)
797 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
799 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
802 /* If the field is marked with ^ and the value is undefined,
804 if ((arg & 512) && !SvOK(sv)) {
812 /* overflow evidence */
813 if (num_overflow(value, fieldsize, arg)) {
819 /* Formats aren't yet marked for locales, so assume "yes". */
821 STORE_NUMERIC_STANDARD_SET_LOCAL();
822 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
823 RESTORE_NUMERIC_STANDARD();
830 while (t-- > linemark && *t == ' ') ;
838 if (arg) { /* repeat until fields exhausted? */
840 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
841 lines += FmLINES(PL_formtarget);
844 if (strnEQ(linemark, linemark - arg, arg))
845 DIE(aTHX_ "Runaway format");
848 SvUTF8_on(PL_formtarget);
849 FmLINES(PL_formtarget) = lines;
851 RETURNOP(cLISTOP->op_first);
862 const char *s = chophere;
863 const char *send = item + len;
865 while (*s && isSPACE(*s) && s < send)
870 arg = fieldsize - itemsize;
877 if (strnEQ(s1," ",3)) {
878 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
889 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
891 SvUTF8_on(PL_formtarget);
892 FmLINES(PL_formtarget) += lines;
904 if (PL_stack_base + *PL_markstack_ptr == SP) {
906 if (GIMME_V == G_SCALAR)
907 XPUSHs(sv_2mortal(newSViv(0)));
908 RETURNOP(PL_op->op_next->op_next);
910 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
911 pp_pushmark(); /* push dst */
912 pp_pushmark(); /* push src */
913 ENTER; /* enter outer scope */
916 if (PL_op->op_private & OPpGREP_LEX)
917 SAVESPTR(PAD_SVl(PL_op->op_targ));
920 ENTER; /* enter inner scope */
923 src = PL_stack_base[*PL_markstack_ptr];
925 if (PL_op->op_private & OPpGREP_LEX)
926 PAD_SVl(PL_op->op_targ) = src;
931 if (PL_op->op_type == OP_MAPSTART)
932 pp_pushmark(); /* push top */
933 return ((LOGOP*)PL_op->op_next)->op_other;
938 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
944 const I32 gimme = GIMME_V;
945 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
951 /* first, move source pointer to the next item in the source list */
952 ++PL_markstack_ptr[-1];
954 /* if there are new items, push them into the destination list */
955 if (items && gimme != G_VOID) {
956 /* might need to make room back there first */
957 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
958 /* XXX this implementation is very pessimal because the stack
959 * is repeatedly extended for every set of items. Is possible
960 * to do this without any stack extension or copying at all
961 * by maintaining a separate list over which the map iterates
962 * (like foreach does). --gsar */
964 /* everything in the stack after the destination list moves
965 * towards the end the stack by the amount of room needed */
966 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
968 /* items to shift up (accounting for the moved source pointer) */
969 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
971 /* This optimization is by Ben Tilly and it does
972 * things differently from what Sarathy (gsar)
973 * is describing. The downside of this optimization is
974 * that leaves "holes" (uninitialized and hopefully unused areas)
975 * to the Perl stack, but on the other hand this
976 * shouldn't be a problem. If Sarathy's idea gets
977 * implemented, this optimization should become
978 * irrelevant. --jhi */
980 shift = count; /* Avoid shifting too often --Ben Tilly */
985 PL_markstack_ptr[-1] += shift;
986 *PL_markstack_ptr += shift;
990 /* copy the new items down to the destination list */
991 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
992 if (gimme == G_ARRAY) {
994 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
997 /* scalar context: we don't care about which values map returns
998 * (we use undef here). And so we certainly don't want to do mortal
999 * copies of meaningless values. */
1000 while (items-- > 0) {
1002 *dst-- = &PL_sv_undef;
1006 LEAVE; /* exit inner scope */
1009 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1011 (void)POPMARK; /* pop top */
1012 LEAVE; /* exit outer scope */
1013 (void)POPMARK; /* pop src */
1014 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1015 (void)POPMARK; /* pop dst */
1016 SP = PL_stack_base + POPMARK; /* pop original mark */
1017 if (gimme == G_SCALAR) {
1018 if (PL_op->op_private & OPpGREP_LEX) {
1019 SV* sv = sv_newmortal();
1020 sv_setiv(sv, items);
1028 else if (gimme == G_ARRAY)
1035 ENTER; /* enter inner scope */
1038 /* set $_ to the new source item */
1039 src = PL_stack_base[PL_markstack_ptr[-1]];
1041 if (PL_op->op_private & OPpGREP_LEX)
1042 PAD_SVl(PL_op->op_targ) = src;
1046 RETURNOP(cLOGOP->op_other);
1054 if (GIMME == G_ARRAY)
1056 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1057 return cLOGOP->op_other;
1066 if (GIMME == G_ARRAY) {
1067 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1071 SV *targ = PAD_SV(PL_op->op_targ);
1074 if (PL_op->op_private & OPpFLIP_LINENUM) {
1075 if (GvIO(PL_last_in_gv)) {
1076 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1079 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1080 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1086 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1087 if (PL_op->op_flags & OPf_SPECIAL) {
1095 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1098 sv_setpvn(TARG, "", 0);
1104 /* This code tries to decide if "$left .. $right" should use the
1105 magical string increment, or if the range is numeric (we make
1106 an exception for .."0" [#18165]). AMS 20021031. */
1108 #define RANGE_IS_NUMERIC(left,right) ( \
1109 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1110 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1111 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1112 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1113 && (!SvOK(right) || looks_like_number(right))))
1119 if (GIMME == G_ARRAY) {
1122 if (SvGMAGICAL(left))
1124 if (SvGMAGICAL(right))
1127 if (RANGE_IS_NUMERIC(left,right)) {
1130 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1131 (SvOK(right) && SvNV(right) > IV_MAX))
1132 DIE(aTHX_ "Range iterator outside integer range");
1143 SV * const sv = sv_2mortal(newSViv(i++));
1148 SV *final = sv_mortalcopy(right);
1150 const char *tmps = SvPV_const(final, len);
1152 SV *sv = sv_mortalcopy(left);
1153 SvPV_force_nolen(sv);
1154 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1156 if (strEQ(SvPVX_const(sv),tmps))
1158 sv = sv_2mortal(newSVsv(sv));
1165 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1169 if (PL_op->op_private & OPpFLIP_LINENUM) {
1170 if (GvIO(PL_last_in_gv)) {
1171 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1174 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1175 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1183 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1184 sv_catpvn(targ, "E0", 2);
1194 static const char * const context_name[] = {
1205 S_dopoptolabel(pTHX_ const char *label)
1209 for (i = cxstack_ix; i >= 0; i--) {
1210 register const PERL_CONTEXT * const cx = &cxstack[i];
1211 switch (CxTYPE(cx)) {
1217 if (ckWARN(WARN_EXITING))
1218 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1219 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1220 if (CxTYPE(cx) == CXt_NULL)
1224 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1225 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1226 (long)i, cx->blk_loop.label));
1229 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1237 Perl_dowantarray(pTHX)
1239 const I32 gimme = block_gimme();
1240 return (gimme == G_VOID) ? G_SCALAR : gimme;
1244 Perl_block_gimme(pTHX)
1246 const I32 cxix = dopoptosub(cxstack_ix);
1250 switch (cxstack[cxix].blk_gimme) {
1258 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1265 Perl_is_lvalue_sub(pTHX)
1267 const I32 cxix = dopoptosub(cxstack_ix);
1268 assert(cxix >= 0); /* We should only be called from inside subs */
1270 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1271 return cxstack[cxix].blk_sub.lval;
1277 S_dopoptosub(pTHX_ I32 startingblock)
1279 return dopoptosub_at(cxstack, startingblock);
1283 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1286 for (i = startingblock; i >= 0; i--) {
1287 register const PERL_CONTEXT * const cx = &cxstk[i];
1288 switch (CxTYPE(cx)) {
1294 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1302 S_dopoptoeval(pTHX_ I32 startingblock)
1305 for (i = startingblock; i >= 0; i--) {
1306 register const PERL_CONTEXT *cx = &cxstack[i];
1307 switch (CxTYPE(cx)) {
1311 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1319 S_dopoptoloop(pTHX_ I32 startingblock)
1322 for (i = startingblock; i >= 0; i--) {
1323 register const PERL_CONTEXT * const cx = &cxstack[i];
1324 switch (CxTYPE(cx)) {
1330 if (ckWARN(WARN_EXITING))
1331 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1332 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1333 if ((CxTYPE(cx)) == CXt_NULL)
1337 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1345 Perl_dounwind(pTHX_ I32 cxix)
1349 while (cxstack_ix > cxix) {
1351 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1352 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1353 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1354 /* Note: we don't need to restore the base context info till the end. */
1355 switch (CxTYPE(cx)) {
1358 continue; /* not break */
1377 PERL_UNUSED_VAR(optype);
1381 Perl_qerror(pTHX_ SV *err)
1384 sv_catsv(ERRSV, err);
1386 sv_catsv(PL_errors, err);
1388 Perl_warn(aTHX_ "%"SVf, err);
1393 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1402 if (PL_in_eval & EVAL_KEEPERR) {
1403 static const char prefix[] = "\t(in cleanup) ";
1405 const char *e = Nullch;
1407 sv_setpvn(err,"",0);
1408 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1410 e = SvPV_const(err, len);
1412 if (*e != *message || strNE(e,message))
1416 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1417 sv_catpvn(err, prefix, sizeof(prefix)-1);
1418 sv_catpvn(err, message, msglen);
1419 if (ckWARN(WARN_MISC)) {
1420 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1421 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1426 sv_setpvn(ERRSV, message, msglen);
1430 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1431 && PL_curstackinfo->si_prev)
1439 register PERL_CONTEXT *cx;
1442 if (cxix < cxstack_ix)
1445 POPBLOCK(cx,PL_curpm);
1446 if (CxTYPE(cx) != CXt_EVAL) {
1448 message = SvPVx_const(ERRSV, msglen);
1449 PerlIO_write(Perl_error_log, "panic: die ", 11);
1450 PerlIO_write(Perl_error_log, message, msglen);
1455 if (gimme == G_SCALAR)
1456 *++newsp = &PL_sv_undef;
1457 PL_stack_sp = newsp;
1461 /* LEAVE could clobber PL_curcop (see save_re_context())
1462 * XXX it might be better to find a way to avoid messing with
1463 * PL_curcop in save_re_context() instead, but this is a more
1464 * minimal fix --GSAR */
1465 PL_curcop = cx->blk_oldcop;
1467 if (optype == OP_REQUIRE) {
1468 const char* msg = SvPVx_nolen_const(ERRSV);
1469 SV * const nsv = cx->blk_eval.old_namesv;
1470 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1472 DIE(aTHX_ "%sCompilation failed in require",
1473 *msg ? msg : "Unknown error\n");
1475 assert(CxTYPE(cx) == CXt_EVAL);
1476 return cx->blk_eval.retop;
1480 message = SvPVx_const(ERRSV, msglen);
1482 write_to_stderr(message, msglen);
1491 if (SvTRUE(left) != SvTRUE(right))
1503 RETURNOP(cLOGOP->op_other);
1512 RETURNOP(cLOGOP->op_other);
1521 if (!sv || !SvANY(sv)) {
1522 RETURNOP(cLOGOP->op_other);
1525 switch (SvTYPE(sv)) {
1527 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1531 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1535 if (CvROOT(sv) || CvXSUB(sv))
1545 RETURNOP(cLOGOP->op_other);
1551 register I32 cxix = dopoptosub(cxstack_ix);
1552 register const PERL_CONTEXT *cx;
1553 register const PERL_CONTEXT *ccstack = cxstack;
1554 const PERL_SI *top_si = PL_curstackinfo;
1556 const char *stashname;
1563 /* we may be in a higher stacklevel, so dig down deeper */
1564 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1565 top_si = top_si->si_prev;
1566 ccstack = top_si->si_cxstack;
1567 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1570 if (GIMME != G_ARRAY) {
1576 /* caller() should not report the automatic calls to &DB::sub */
1577 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1578 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1582 cxix = dopoptosub_at(ccstack, cxix - 1);
1585 cx = &ccstack[cxix];
1586 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1587 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1588 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1589 field below is defined for any cx. */
1590 /* caller() should not report the automatic calls to &DB::sub */
1591 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1592 cx = &ccstack[dbcxix];
1595 stashname = CopSTASHPV(cx->blk_oldcop);
1596 if (GIMME != G_ARRAY) {
1599 PUSHs(&PL_sv_undef);
1602 sv_setpv(TARG, stashname);
1611 PUSHs(&PL_sv_undef);
1613 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1614 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1615 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1618 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1619 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1620 /* So is ccstack[dbcxix]. */
1622 SV * const sv = NEWSV(49, 0);
1623 gv_efullname3(sv, cvgv, Nullch);
1624 PUSHs(sv_2mortal(sv));
1625 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1628 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1633 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1634 PUSHs(sv_2mortal(newSViv(0)));
1636 gimme = (I32)cx->blk_gimme;
1637 if (gimme == G_VOID)
1638 PUSHs(&PL_sv_undef);
1640 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1641 if (CxTYPE(cx) == CXt_EVAL) {
1643 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1644 PUSHs(cx->blk_eval.cur_text);
1648 else if (cx->blk_eval.old_namesv) {
1649 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1652 /* eval BLOCK (try blocks have old_namesv == 0) */
1654 PUSHs(&PL_sv_undef);
1655 PUSHs(&PL_sv_undef);
1659 PUSHs(&PL_sv_undef);
1660 PUSHs(&PL_sv_undef);
1662 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1663 && CopSTASH_eq(PL_curcop, PL_debstash))
1665 AV * const ary = cx->blk_sub.argarray;
1666 const int off = AvARRAY(ary) - AvALLOC(ary);
1670 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1673 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1676 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1677 av_extend(PL_dbargs, AvFILLp(ary) + off);
1678 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1679 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1681 /* XXX only hints propagated via op_private are currently
1682 * visible (others are not easily accessible, since they
1683 * use the global PL_hints) */
1684 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1685 HINT_PRIVATE_MASK)));
1688 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1690 if (old_warnings == pWARN_NONE ||
1691 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1692 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1693 else if (old_warnings == pWARN_ALL ||
1694 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1695 /* Get the bit mask for $warnings::Bits{all}, because
1696 * it could have been extended by warnings::register */
1698 HV *bits = get_hv("warnings::Bits", FALSE);
1699 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1700 mask = newSVsv(*bits_all);
1703 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1707 mask = newSVsv(old_warnings);
1708 PUSHs(sv_2mortal(mask));
1722 sv_reset(tmps, CopSTASH(PL_curcop));
1732 /* like pp_nextstate, but used instead when the debugger is active */
1737 PL_curcop = (COP*)PL_op;
1738 TAINT_NOT; /* Each statement is presumed innocent */
1739 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1742 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1743 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1747 register PERL_CONTEXT *cx;
1748 const I32 gimme = G_ARRAY;
1755 DIE(aTHX_ "No DB::DB routine defined");
1757 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1758 /* don't do recursive DB::DB call */
1770 PUSHBLOCK(cx, CXt_SUB, SP);
1772 cx->blk_sub.retop = PL_op->op_next;
1774 PAD_SET_CUR(CvPADLIST(cv),1);
1775 RETURNOP(CvSTART(cv));
1789 register PERL_CONTEXT *cx;
1790 const I32 gimme = GIMME_V;
1792 U32 cxtype = CXt_LOOP;
1800 if (PL_op->op_targ) {
1801 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1802 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1803 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1804 SVs_PADSTALE, SVs_PADSTALE);
1806 #ifndef USE_ITHREADS
1807 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1810 SAVEPADSV(PL_op->op_targ);
1811 iterdata = INT2PTR(void*, PL_op->op_targ);
1812 cxtype |= CXp_PADVAR;
1817 svp = &GvSV(gv); /* symbol table variable */
1818 SAVEGENERICSV(*svp);
1821 iterdata = (void*)gv;
1827 PUSHBLOCK(cx, cxtype, SP);
1829 PUSHLOOP(cx, iterdata, MARK);
1831 PUSHLOOP(cx, svp, MARK);
1833 if (PL_op->op_flags & OPf_STACKED) {
1834 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1835 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1837 SV *right = (SV*)cx->blk_loop.iterary;
1838 if (RANGE_IS_NUMERIC(sv,right)) {
1839 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1840 (SvOK(right) && SvNV(right) >= IV_MAX))
1841 DIE(aTHX_ "Range iterator outside integer range");
1842 cx->blk_loop.iterix = SvIV(sv);
1843 cx->blk_loop.itermax = SvIV(right);
1846 cx->blk_loop.iterlval = newSVsv(sv);
1847 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1848 (void) SvPV_nolen_const(right);
1851 else if (PL_op->op_private & OPpITER_REVERSED) {
1852 cx->blk_loop.itermax = -1;
1853 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1858 cx->blk_loop.iterary = PL_curstack;
1859 AvFILLp(PL_curstack) = SP - PL_stack_base;
1860 if (PL_op->op_private & OPpITER_REVERSED) {
1861 cx->blk_loop.itermax = MARK - PL_stack_base;
1862 cx->blk_loop.iterix = cx->blk_oldsp;
1865 cx->blk_loop.iterix = MARK - PL_stack_base;
1875 register PERL_CONTEXT *cx;
1876 const I32 gimme = GIMME_V;
1882 PUSHBLOCK(cx, CXt_LOOP, SP);
1883 PUSHLOOP(cx, 0, SP);
1891 register PERL_CONTEXT *cx;
1898 assert(CxTYPE(cx) == CXt_LOOP);
1900 newsp = PL_stack_base + cx->blk_loop.resetsp;
1903 if (gimme == G_VOID)
1905 else if (gimme == G_SCALAR) {
1907 *++newsp = sv_mortalcopy(*SP);
1909 *++newsp = &PL_sv_undef;
1913 *++newsp = sv_mortalcopy(*++mark);
1914 TAINT_NOT; /* Each item is independent */
1920 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1921 PL_curpm = newpm; /* ... and pop $1 et al */
1933 register PERL_CONTEXT *cx;
1934 bool popsub2 = FALSE;
1935 bool clear_errsv = FALSE;
1943 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1944 if (cxstack_ix == PL_sortcxix
1945 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1947 if (cxstack_ix > PL_sortcxix)
1948 dounwind(PL_sortcxix);
1949 AvARRAY(PL_curstack)[1] = *SP;
1950 PL_stack_sp = PL_stack_base + 1;
1955 cxix = dopoptosub(cxstack_ix);
1957 DIE(aTHX_ "Can't return outside a subroutine");
1958 if (cxix < cxstack_ix)
1962 switch (CxTYPE(cx)) {
1965 retop = cx->blk_sub.retop;
1966 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1969 if (!(PL_in_eval & EVAL_KEEPERR))
1972 retop = cx->blk_eval.retop;
1976 if (optype == OP_REQUIRE &&
1977 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1979 /* Unassume the success we assumed earlier. */
1980 SV * const nsv = cx->blk_eval.old_namesv;
1981 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1982 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1987 retop = cx->blk_sub.retop;
1990 DIE(aTHX_ "panic: return");
1994 if (gimme == G_SCALAR) {
1997 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1999 *++newsp = SvREFCNT_inc(*SP);
2004 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2006 *++newsp = sv_mortalcopy(sv);
2011 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2014 *++newsp = sv_mortalcopy(*SP);
2017 *++newsp = &PL_sv_undef;
2019 else if (gimme == G_ARRAY) {
2020 while (++MARK <= SP) {
2021 *++newsp = (popsub2 && SvTEMP(*MARK))
2022 ? *MARK : sv_mortalcopy(*MARK);
2023 TAINT_NOT; /* Each item is independent */
2026 PL_stack_sp = newsp;
2029 /* Stack values are safe: */
2032 POPSUB(cx,sv); /* release CV and @_ ... */
2036 PL_curpm = newpm; /* ... and pop $1 et al */
2040 sv_setpvn(ERRSV,"",0);
2048 register PERL_CONTEXT *cx;
2058 if (PL_op->op_flags & OPf_SPECIAL) {
2059 cxix = dopoptoloop(cxstack_ix);
2061 DIE(aTHX_ "Can't \"last\" outside a loop block");
2064 cxix = dopoptolabel(cPVOP->op_pv);
2066 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2068 if (cxix < cxstack_ix)
2072 PERL_UNUSED_VAR(optype);
2073 cxstack_ix++; /* temporarily protect top context */
2075 switch (CxTYPE(cx)) {
2078 newsp = PL_stack_base + cx->blk_loop.resetsp;
2079 nextop = cx->blk_loop.last_op->op_next;
2083 nextop = cx->blk_sub.retop;
2087 nextop = cx->blk_eval.retop;
2091 nextop = cx->blk_sub.retop;
2094 DIE(aTHX_ "panic: last");
2098 if (gimme == G_SCALAR) {
2100 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2101 ? *SP : sv_mortalcopy(*SP);
2103 *++newsp = &PL_sv_undef;
2105 else if (gimme == G_ARRAY) {
2106 while (++MARK <= SP) {
2107 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2108 ? *MARK : sv_mortalcopy(*MARK);
2109 TAINT_NOT; /* Each item is independent */
2117 /* Stack values are safe: */
2120 POPLOOP(cx); /* release loop vars ... */
2124 POPSUB(cx,sv); /* release CV and @_ ... */
2127 PL_curpm = newpm; /* ... and pop $1 et al */
2137 register PERL_CONTEXT *cx;
2140 if (PL_op->op_flags & OPf_SPECIAL) {
2141 cxix = dopoptoloop(cxstack_ix);
2143 DIE(aTHX_ "Can't \"next\" outside a loop block");
2146 cxix = dopoptolabel(cPVOP->op_pv);
2148 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2150 if (cxix < cxstack_ix)
2153 /* clear off anything above the scope we're re-entering, but
2154 * save the rest until after a possible continue block */
2155 inner = PL_scopestack_ix;
2157 if (PL_scopestack_ix < inner)
2158 leave_scope(PL_scopestack[PL_scopestack_ix]);
2159 PL_curcop = cx->blk_oldcop;
2160 return cx->blk_loop.next_op;
2167 register PERL_CONTEXT *cx;
2171 if (PL_op->op_flags & OPf_SPECIAL) {
2172 cxix = dopoptoloop(cxstack_ix);
2174 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2177 cxix = dopoptolabel(cPVOP->op_pv);
2179 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2181 if (cxix < cxstack_ix)
2184 redo_op = cxstack[cxix].blk_loop.redo_op;
2185 if (redo_op->op_type == OP_ENTER) {
2186 /* pop one less context to avoid $x being freed in while (my $x..) */
2188 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2189 redo_op = redo_op->op_next;
2193 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2194 LEAVE_SCOPE(oldsave);
2196 PL_curcop = cx->blk_oldcop;
2201 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2205 static const char too_deep[] = "Target of goto is too deeply nested";
2208 Perl_croak(aTHX_ too_deep);
2209 if (o->op_type == OP_LEAVE ||
2210 o->op_type == OP_SCOPE ||
2211 o->op_type == OP_LEAVELOOP ||
2212 o->op_type == OP_LEAVESUB ||
2213 o->op_type == OP_LEAVETRY)
2215 *ops++ = cUNOPo->op_first;
2217 Perl_croak(aTHX_ too_deep);
2220 if (o->op_flags & OPf_KIDS) {
2221 /* First try all the kids at this level, since that's likeliest. */
2222 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2223 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2224 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2227 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2228 if (kid == PL_lastgotoprobe)
2230 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2233 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2234 ops[-1]->op_type == OP_DBSTATE)
2239 if ((o = dofindlabel(kid, label, ops, oplimit)))
2258 register PERL_CONTEXT *cx;
2259 #define GOTO_DEPTH 64
2260 OP *enterops[GOTO_DEPTH];
2261 const char *label = 0;
2262 const bool do_dump = (PL_op->op_type == OP_DUMP);
2263 static const char must_have_label[] = "goto must have label";
2265 if (PL_op->op_flags & OPf_STACKED) {
2268 /* This egregious kludge implements goto &subroutine */
2269 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2271 register PERL_CONTEXT *cx;
2272 CV* cv = (CV*)SvRV(sv);
2279 if (!CvROOT(cv) && !CvXSUB(cv)) {
2280 const GV * const gv = CvGV(cv);
2284 /* autoloaded stub? */
2285 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2287 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2288 GvNAMELEN(gv), FALSE);
2289 if (autogv && (cv = GvCV(autogv)))
2291 tmpstr = sv_newmortal();
2292 gv_efullname3(tmpstr, gv, Nullch);
2293 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2295 DIE(aTHX_ "Goto undefined subroutine");
2298 /* First do some returnish stuff. */
2299 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2301 cxix = dopoptosub(cxstack_ix);
2303 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2304 if (cxix < cxstack_ix)
2308 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2309 if (CxTYPE(cx) == CXt_EVAL) {
2311 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2313 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2315 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2316 /* put @_ back onto stack */
2317 AV* av = cx->blk_sub.argarray;
2319 items = AvFILLp(av) + 1;
2320 EXTEND(SP, items+1); /* @_ could have been extended. */
2321 Copy(AvARRAY(av), SP + 1, items, SV*);
2322 SvREFCNT_dec(GvAV(PL_defgv));
2323 GvAV(PL_defgv) = cx->blk_sub.savearray;
2325 /* abandon @_ if it got reified */
2330 av_extend(av, items-1);
2332 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2335 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2337 av = GvAV(PL_defgv);
2338 items = AvFILLp(av) + 1;
2339 EXTEND(SP, items+1); /* @_ could have been extended. */
2340 Copy(AvARRAY(av), SP + 1, items, SV*);
2344 if (CxTYPE(cx) == CXt_SUB &&
2345 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2346 SvREFCNT_dec(cx->blk_sub.cv);
2347 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2348 LEAVE_SCOPE(oldsave);
2350 /* Now do some callish stuff. */
2352 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2354 OP* retop = cx->blk_sub.retop;
2357 for (index=0; index<items; index++)
2358 sv_2mortal(SP[-index]);
2360 #ifdef PERL_XSUB_OLDSTYLE
2361 if (CvOLDSTYLE(cv)) {
2362 I32 (*fp3)(int,int,int);
2367 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2368 items = (*fp3)(CvXSUBANY(cv).any_i32,
2369 mark - PL_stack_base + 1,
2371 SP = PL_stack_base + items;
2374 #endif /* PERL_XSUB_OLDSTYLE */
2379 /* XS subs don't have a CxSUB, so pop it */
2380 POPBLOCK(cx, PL_curpm);
2381 /* Push a mark for the start of arglist */
2384 (void)(*CvXSUB(cv))(aTHX_ cv);
2385 /* Put these at the bottom since the vars are set but not used */
2386 PERL_UNUSED_VAR(newsp);
2387 PERL_UNUSED_VAR(gimme);
2393 AV* padlist = CvPADLIST(cv);
2394 if (CxTYPE(cx) == CXt_EVAL) {
2395 PL_in_eval = cx->blk_eval.old_in_eval;
2396 PL_eval_root = cx->blk_eval.old_eval_root;
2397 cx->cx_type = CXt_SUB;
2398 cx->blk_sub.hasargs = 0;
2400 cx->blk_sub.cv = cv;
2401 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2404 if (CvDEPTH(cv) < 2)
2405 (void)SvREFCNT_inc(cv);
2407 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2408 sub_crush_depth(cv);
2409 pad_push(padlist, CvDEPTH(cv));
2411 PAD_SET_CUR(padlist, CvDEPTH(cv));
2412 if (cx->blk_sub.hasargs)
2414 AV* av = (AV*)PAD_SVl(0);
2417 cx->blk_sub.savearray = GvAV(PL_defgv);
2418 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2419 CX_CURPAD_SAVE(cx->blk_sub);
2420 cx->blk_sub.argarray = av;
2422 if (items >= AvMAX(av) + 1) {
2424 if (AvARRAY(av) != ary) {
2425 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2426 SvPV_set(av, (char*)ary);
2428 if (items >= AvMAX(av) + 1) {
2429 AvMAX(av) = items - 1;
2430 Renew(ary,items+1,SV*);
2432 SvPV_set(av, (char*)ary);
2436 Copy(mark,AvARRAY(av),items,SV*);
2437 AvFILLp(av) = items - 1;
2438 assert(!AvREAL(av));
2440 /* transfer 'ownership' of refcnts to new @_ */
2450 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2452 * We do not care about using sv to call CV;
2453 * it's for informational purposes only.
2455 SV *sv = GvSV(PL_DBsub);
2459 if (PERLDB_SUB_NN) {
2460 int type = SvTYPE(sv);
2461 if (type < SVt_PVIV && type != SVt_IV)
2462 sv_upgrade(sv, SVt_PVIV);
2464 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2466 gv_efullname3(sv, CvGV(cv), Nullch);
2469 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2470 PUSHMARK( PL_stack_sp );
2471 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2475 RETURNOP(CvSTART(cv));
2479 label = SvPV_nolen_const(sv);
2480 if (!(do_dump || *label))
2481 DIE(aTHX_ must_have_label);
2484 else if (PL_op->op_flags & OPf_SPECIAL) {
2486 DIE(aTHX_ must_have_label);
2489 label = cPVOP->op_pv;
2491 if (label && *label) {
2493 bool leaving_eval = FALSE;
2494 bool in_block = FALSE;
2495 PERL_CONTEXT *last_eval_cx = 0;
2499 PL_lastgotoprobe = 0;
2501 for (ix = cxstack_ix; ix >= 0; ix--) {
2503 switch (CxTYPE(cx)) {
2505 leaving_eval = TRUE;
2506 if (!CxTRYBLOCK(cx)) {
2507 gotoprobe = (last_eval_cx ?
2508 last_eval_cx->blk_eval.old_eval_root :
2513 /* else fall through */
2515 gotoprobe = cx->blk_oldcop->op_sibling;
2521 gotoprobe = cx->blk_oldcop->op_sibling;
2524 gotoprobe = PL_main_root;
2527 if (CvDEPTH(cx->blk_sub.cv)) {
2528 gotoprobe = CvROOT(cx->blk_sub.cv);
2534 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2537 DIE(aTHX_ "panic: goto");
2538 gotoprobe = PL_main_root;
2542 retop = dofindlabel(gotoprobe, label,
2543 enterops, enterops + GOTO_DEPTH);
2547 PL_lastgotoprobe = gotoprobe;
2550 DIE(aTHX_ "Can't find label %s", label);
2552 /* if we're leaving an eval, check before we pop any frames
2553 that we're not going to punt, otherwise the error
2556 if (leaving_eval && *enterops && enterops[1]) {
2558 for (i = 1; enterops[i]; i++)
2559 if (enterops[i]->op_type == OP_ENTERITER)
2560 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2563 /* pop unwanted frames */
2565 if (ix < cxstack_ix) {
2572 oldsave = PL_scopestack[PL_scopestack_ix];
2573 LEAVE_SCOPE(oldsave);
2576 /* push wanted frames */
2578 if (*enterops && enterops[1]) {
2580 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2581 for (; enterops[ix]; ix++) {
2582 PL_op = enterops[ix];
2583 /* Eventually we may want to stack the needed arguments
2584 * for each op. For now, we punt on the hard ones. */
2585 if (PL_op->op_type == OP_ENTERITER)
2586 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2587 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2595 if (!retop) retop = PL_main_start;
2597 PL_restartop = retop;
2598 PL_do_undump = TRUE;
2602 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2603 PL_do_undump = FALSE;
2619 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2621 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2624 PL_exit_flags |= PERL_EXIT_EXPECTED;
2626 PUSHs(&PL_sv_undef);
2634 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2635 register I32 match = I_32(value);
2638 if (((NV)match) > value)
2639 --match; /* was fractional--truncate other way */
2641 match -= cCOP->uop.scop.scop_offset;
2644 else if (match > cCOP->uop.scop.scop_max)
2645 match = cCOP->uop.scop.scop_max;
2646 PL_op = cCOP->uop.scop.scop_next[match];
2656 PL_op = PL_op->op_next; /* can't assume anything */
2658 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2659 match -= cCOP->uop.scop.scop_offset;
2662 else if (match > cCOP->uop.scop.scop_max)
2663 match = cCOP->uop.scop.scop_max;
2664 PL_op = cCOP->uop.scop.scop_next[match];
2673 S_save_lines(pTHX_ AV *array, SV *sv)
2675 const char *s = SvPVX_const(sv);
2676 const char *send = SvPVX_const(sv) + SvCUR(sv);
2679 while (s && s < send) {
2681 SV *tmpstr = NEWSV(85,0);
2683 sv_upgrade(tmpstr, SVt_PVMG);
2684 t = strchr(s, '\n');
2690 sv_setpvn(tmpstr, s, t - s);
2691 av_store(array, line++, tmpstr);
2697 S_docatch_body(pTHX)
2704 S_docatch(pTHX_ OP *o)
2707 OP * const oldop = PL_op;
2711 assert(CATCH_GET == TRUE);
2718 assert(cxstack_ix >= 0);
2719 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2720 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2725 /* die caught by an inner eval - continue inner loop */
2727 /* NB XXX we rely on the old popped CxEVAL still being at the top
2728 * of the stack; the way die_where() currently works, this
2729 * assumption is valid. In theory The cur_top_env value should be
2730 * returned in another global, the way retop (aka PL_restartop)
2732 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2735 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2737 PL_op = PL_restartop;
2754 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2755 /* sv Text to convert to OP tree. */
2756 /* startop op_free() this to undo. */
2757 /* code Short string id of the caller. */
2759 dVAR; dSP; /* Make POPBLOCK work. */
2762 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2766 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2767 char *tmpbuf = tbuf;
2770 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2775 /* switch to eval mode */
2777 if (IN_PERL_COMPILETIME) {
2778 SAVECOPSTASH_FREE(&PL_compiling);
2779 CopSTASH_set(&PL_compiling, PL_curstash);
2781 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2782 SV *sv = sv_newmortal();
2783 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2784 code, (unsigned long)++PL_evalseq,
2785 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2789 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2790 SAVECOPFILE_FREE(&PL_compiling);
2791 CopFILE_set(&PL_compiling, tmpbuf+2);
2792 SAVECOPLINE(&PL_compiling);
2793 CopLINE_set(&PL_compiling, 1);
2794 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2795 deleting the eval's FILEGV from the stash before gv_check() runs
2796 (i.e. before run-time proper). To work around the coredump that
2797 ensues, we always turn GvMULTI_on for any globals that were
2798 introduced within evals. See force_ident(). GSAR 96-10-12 */
2799 safestr = savepv(tmpbuf);
2800 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2802 #ifdef OP_IN_REGISTER
2808 /* we get here either during compilation, or via pp_regcomp at runtime */
2809 runtime = IN_PERL_RUNTIME;
2811 runcv = find_runcv(NULL);
2814 PL_op->op_type = OP_ENTEREVAL;
2815 PL_op->op_flags = 0; /* Avoid uninit warning. */
2816 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2817 PUSHEVAL(cx, 0, Nullgv);
2820 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2822 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2823 POPBLOCK(cx,PL_curpm);
2826 (*startop)->op_type = OP_NULL;
2827 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2829 /* XXX DAPM do this properly one year */
2830 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2832 if (IN_PERL_COMPILETIME)
2833 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2834 #ifdef OP_IN_REGISTER
2842 =for apidoc find_runcv
2844 Locate the CV corresponding to the currently executing sub or eval.
2845 If db_seqp is non_null, skip CVs that are in the DB package and populate
2846 *db_seqp with the cop sequence number at the point that the DB:: code was
2847 entered. (allows debuggers to eval in the scope of the breakpoint rather
2848 than in in the scope of the debugger itself).
2854 Perl_find_runcv(pTHX_ U32 *db_seqp)
2859 *db_seqp = PL_curcop->cop_seq;
2860 for (si = PL_curstackinfo; si; si = si->si_prev) {
2862 for (ix = si->si_cxix; ix >= 0; ix--) {
2863 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2864 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2865 CV * const cv = cx->blk_sub.cv;
2866 /* skip DB:: code */
2867 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2868 *db_seqp = cx->blk_oldcop->cop_seq;
2873 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2881 /* Compile a require/do, an eval '', or a /(?{...})/.
2882 * In the last case, startop is non-null, and contains the address of
2883 * a pointer that should be set to the just-compiled code.
2884 * outside is the lexically enclosing CV (if any) that invoked us.
2887 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2889 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2894 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2895 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2900 SAVESPTR(PL_compcv);
2901 PL_compcv = (CV*)NEWSV(1104,0);
2902 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2903 CvEVAL_on(PL_compcv);
2904 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2905 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2907 CvOUTSIDE_SEQ(PL_compcv) = seq;
2908 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2910 /* set up a scratch pad */
2912 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2915 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2917 /* make sure we compile in the right package */
2919 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2920 SAVESPTR(PL_curstash);
2921 PL_curstash = CopSTASH(PL_curcop);
2923 SAVESPTR(PL_beginav);
2924 PL_beginav = newAV();
2925 SAVEFREESV(PL_beginav);
2926 SAVEI32(PL_error_count);
2928 /* try to compile it */
2930 PL_eval_root = Nullop;
2932 PL_curcop = &PL_compiling;
2933 PL_curcop->cop_arybase = 0;
2934 if (saveop && saveop->op_flags & OPf_SPECIAL)
2935 PL_in_eval |= EVAL_KEEPERR;
2937 sv_setpvn(ERRSV,"",0);
2938 if (yyparse() || PL_error_count || !PL_eval_root) {
2939 SV **newsp; /* Used by POPBLOCK. */
2940 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2941 I32 optype = 0; /* Might be reset by POPEVAL. */
2945 op_free(PL_eval_root);
2946 PL_eval_root = Nullop;
2948 SP = PL_stack_base + POPMARK; /* pop original mark */
2950 POPBLOCK(cx,PL_curpm);
2955 if (optype == OP_REQUIRE) {
2956 const char* const msg = SvPVx_nolen_const(ERRSV);
2957 const SV * const nsv = cx->blk_eval.old_namesv;
2958 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2960 DIE(aTHX_ "%sCompilation failed in require",
2961 *msg ? msg : "Unknown error\n");
2964 const char* msg = SvPVx_nolen_const(ERRSV);
2966 POPBLOCK(cx,PL_curpm);
2968 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2969 (*msg ? msg : "Unknown error\n"));
2972 const char* msg = SvPVx_nolen_const(ERRSV);
2974 sv_setpv(ERRSV, "Compilation error");
2979 CopLINE_set(&PL_compiling, 0);
2981 *startop = PL_eval_root;
2983 SAVEFREEOP(PL_eval_root);
2985 /* Set the context for this new optree.
2986 * If the last op is an OP_REQUIRE, force scalar context.
2987 * Otherwise, propagate the context from the eval(). */
2988 if (PL_eval_root->op_type == OP_LEAVEEVAL
2989 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2990 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2992 scalar(PL_eval_root);
2993 else if (gimme & G_VOID)
2994 scalarvoid(PL_eval_root);
2995 else if (gimme & G_ARRAY)
2998 scalar(PL_eval_root);
3000 DEBUG_x(dump_eval());
3002 /* Register with debugger: */
3003 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3004 CV *cv = get_cv("DB::postponed", FALSE);
3008 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3010 call_sv((SV*)cv, G_DISCARD);
3014 /* compiled okay, so do it */
3016 CvDEPTH(PL_compcv) = 1;
3017 SP = PL_stack_base + POPMARK; /* pop original mark */
3018 PL_op = saveop; /* The caller may need it. */
3019 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3021 RETURNOP(PL_eval_start);
3025 S_doopen_pm(pTHX_ const char *name, const char *mode)
3027 #ifndef PERL_DISABLE_PMC
3028 const STRLEN namelen = strlen(name);
3031 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3032 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3033 const char * const pmc = SvPV_nolen_const(pmcsv);
3036 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037 fp = PerlIO_open(name, mode);
3040 if (PerlLIO_stat(name, &pmstat) < 0 ||
3041 pmstat.st_mtime < pmcstat.st_mtime)
3043 fp = PerlIO_open(pmc, mode);
3046 fp = PerlIO_open(name, mode);
3049 SvREFCNT_dec(pmcsv);
3052 fp = PerlIO_open(name, mode);
3056 return PerlIO_open(name, mode);
3057 #endif /* !PERL_DISABLE_PMC */
3063 register PERL_CONTEXT *cx;
3067 const char *tryname = Nullch;
3068 SV *namesv = Nullsv;
3070 const I32 gimme = GIMME_V;
3071 PerlIO *tryrsfp = 0;
3072 int filter_has_file = 0;
3073 GV *filter_child_proc = 0;
3074 SV *filter_state = 0;
3081 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3082 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3083 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3084 "v-string in use/require non-portable");
3086 sv = new_version(sv);
3087 if (!sv_derived_from(PL_patchlevel, "version"))
3088 (void *)upg_version(PL_patchlevel);
3089 if ( vcmp(sv,PL_patchlevel) > 0 )
3090 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3091 vnormal(sv), vnormal(PL_patchlevel));
3095 name = SvPV_const(sv, len);
3096 if (!(name && len > 0 && *name))
3097 DIE(aTHX_ "Null filename used");
3098 TAINT_PROPER("require");
3099 if (PL_op->op_type == OP_REQUIRE &&
3100 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3101 if (*svp != &PL_sv_undef)
3104 DIE(aTHX_ "Compilation failed in require");
3107 /* prepare to compile file */
3109 if (path_is_absolute(name)) {
3111 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3113 #ifdef MACOS_TRADITIONAL
3117 MacPerl_CanonDir(name, newname, 1);
3118 if (path_is_absolute(newname)) {
3120 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3125 AV *ar = GvAVn(PL_incgv);
3129 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3132 namesv = NEWSV(806, 0);
3133 for (i = 0; i <= AvFILL(ar); i++) {
3134 SV *dirsv = *av_fetch(ar, i, TRUE);
3140 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3141 && !sv_isobject(loader))
3143 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3146 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3147 PTR2UV(SvRV(dirsv)), name);
3148 tryname = SvPVX_const(namesv);
3159 if (sv_isobject(loader))
3160 count = call_method("INC", G_ARRAY);
3162 count = call_sv(loader, G_ARRAY);
3172 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3176 if (SvTYPE(arg) == SVt_PVGV) {
3177 IO *io = GvIO((GV *)arg);
3182 tryrsfp = IoIFP(io);
3183 if (IoTYPE(io) == IoTYPE_PIPE) {
3184 /* reading from a child process doesn't
3185 nest -- when returning from reading
3186 the inner module, the outer one is
3187 unreadable (closed?) I've tried to
3188 save the gv to manage the lifespan of
3189 the pipe, but this didn't help. XXX */
3190 filter_child_proc = (GV *)arg;
3191 (void)SvREFCNT_inc(filter_child_proc);
3194 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3195 PerlIO_close(IoOFP(io));
3207 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3209 (void)SvREFCNT_inc(filter_sub);
3212 filter_state = SP[i];
3213 (void)SvREFCNT_inc(filter_state);
3217 tryrsfp = PerlIO_open("/dev/null",
3233 filter_has_file = 0;
3234 if (filter_child_proc) {
3235 SvREFCNT_dec(filter_child_proc);
3236 filter_child_proc = 0;
3239 SvREFCNT_dec(filter_state);
3243 SvREFCNT_dec(filter_sub);
3248 if (!path_is_absolute(name)
3249 #ifdef MACOS_TRADITIONAL
3250 /* We consider paths of the form :a:b ambiguous and interpret them first
3251 as global then as local
3253 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3256 const char *dir = SvPVx_nolen_const(dirsv);
3257 #ifdef MACOS_TRADITIONAL
3261 MacPerl_CanonDir(name, buf2, 1);
3262 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3266 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3268 sv_setpv(namesv, unixdir);
3269 sv_catpv(namesv, unixname);
3272 if (PL_origfilename[0] &&
3273 PL_origfilename[1] == ':' &&
3274 !(dir[0] && dir[1] == ':'))
3275 Perl_sv_setpvf(aTHX_ namesv,
3280 Perl_sv_setpvf(aTHX_ namesv,
3284 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3288 TAINT_PROPER("require");
3289 tryname = SvPVX_const(namesv);
3290 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3292 if (tryname[0] == '.' && tryname[1] == '/')
3301 SAVECOPFILE_FREE(&PL_compiling);
3302 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3303 SvREFCNT_dec(namesv);
3305 if (PL_op->op_type == OP_REQUIRE) {
3306 const char *msgstr = name;
3307 if (namesv) { /* did we lookup @INC? */
3308 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3309 SV *dirmsgsv = NEWSV(0, 0);
3310 AV *ar = GvAVn(PL_incgv);
3312 sv_catpvn(msg, " in @INC", 8);
3313 if (instr(SvPVX_const(msg), ".h "))
3314 sv_catpv(msg, " (change .h to .ph maybe?)");
3315 if (instr(SvPVX_const(msg), ".ph "))
3316 sv_catpv(msg, " (did you run h2ph?)");
3317 sv_catpv(msg, " (@INC contains:");
3318 for (i = 0; i <= AvFILL(ar); i++) {
3319 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3320 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3321 sv_catsv(msg, dirmsgsv);
3323 sv_catpvn(msg, ")", 1);
3324 SvREFCNT_dec(dirmsgsv);
3325 msgstr = SvPV_nolen_const(msg);
3327 DIE(aTHX_ "Can't locate %s", msgstr);
3333 SETERRNO(0, SS_NORMAL);
3335 /* Assume success here to prevent recursive requirement. */
3337 /* Check whether a hook in @INC has already filled %INC */
3338 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3339 (void)hv_store(GvHVn(PL_incgv), name, len,
3340 (hook_sv ? SvREFCNT_inc(hook_sv)
3341 : newSVpv(CopFILE(&PL_compiling), 0)),
3347 lex_start(sv_2mortal(newSVpvn("",0)));
3348 SAVEGENERICSV(PL_rsfp_filters);
3349 PL_rsfp_filters = Nullav;
3354 SAVESPTR(PL_compiling.cop_warnings);
3355 if (PL_dowarn & G_WARN_ALL_ON)
3356 PL_compiling.cop_warnings = pWARN_ALL ;
3357 else if (PL_dowarn & G_WARN_ALL_OFF)
3358 PL_compiling.cop_warnings = pWARN_NONE ;
3359 else if (PL_taint_warn)
3360 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3362 PL_compiling.cop_warnings = pWARN_STD ;
3363 SAVESPTR(PL_compiling.cop_io);
3364 PL_compiling.cop_io = Nullsv;
3366 if (filter_sub || filter_child_proc) {
3367 SV *datasv = filter_add(run_user_filter, Nullsv);
3368 IoLINES(datasv) = filter_has_file;
3369 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3370 IoTOP_GV(datasv) = (GV *)filter_state;
3371 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3374 /* switch to eval mode */
3375 PUSHBLOCK(cx, CXt_EVAL, SP);
3376 PUSHEVAL(cx, name, Nullgv);
3377 cx->blk_eval.retop = PL_op->op_next;
3379 SAVECOPLINE(&PL_compiling);
3380 CopLINE_set(&PL_compiling, 0);
3384 /* Store and reset encoding. */
3385 encoding = PL_encoding;
3386 PL_encoding = Nullsv;
3388 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3390 /* Restore encoding. */
3391 PL_encoding = encoding;
3398 return pp_require();
3404 register PERL_CONTEXT *cx;
3406 const I32 gimme = GIMME_V, was = PL_sub_generation;
3407 char tbuf[TYPE_DIGITS(long) + 12];
3408 char *tmpbuf = tbuf;
3415 if (!SvPV_const(sv,len))
3417 TAINT_PROPER("eval");
3423 /* switch to eval mode */
3425 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3426 SV *sv = sv_newmortal();
3427 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3428 (unsigned long)++PL_evalseq,
3429 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3433 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3434 SAVECOPFILE_FREE(&PL_compiling);
3435 CopFILE_set(&PL_compiling, tmpbuf+2);
3436 SAVECOPLINE(&PL_compiling);
3437 CopLINE_set(&PL_compiling, 1);
3438 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3439 deleting the eval's FILEGV from the stash before gv_check() runs
3440 (i.e. before run-time proper). To work around the coredump that
3441 ensues, we always turn GvMULTI_on for any globals that were
3442 introduced within evals. See force_ident(). GSAR 96-10-12 */
3443 safestr = savepv(tmpbuf);
3444 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3446 PL_hints = PL_op->op_targ;
3447 SAVESPTR(PL_compiling.cop_warnings);
3448 if (specialWARN(PL_curcop->cop_warnings))
3449 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3451 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3452 SAVEFREESV(PL_compiling.cop_warnings);
3454 SAVESPTR(PL_compiling.cop_io);
3455 if (specialCopIO(PL_curcop->cop_io))
3456 PL_compiling.cop_io = PL_curcop->cop_io;
3458 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3459 SAVEFREESV(PL_compiling.cop_io);
3461 /* special case: an eval '' executed within the DB package gets lexically
3462 * placed in the first non-DB CV rather than the current CV - this
3463 * allows the debugger to execute code, find lexicals etc, in the
3464 * scope of the code being debugged. Passing &seq gets find_runcv
3465 * to do the dirty work for us */
3466 runcv = find_runcv(&seq);
3468 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3469 PUSHEVAL(cx, 0, Nullgv);
3470 cx->blk_eval.retop = PL_op->op_next;
3472 /* prepare to compile string */
3474 if (PERLDB_LINE && PL_curstash != PL_debstash)
3475 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3477 ret = doeval(gimme, NULL, runcv, seq);
3478 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3479 && ret != PL_op->op_next) { /* Successive compilation. */
3480 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3482 return DOCATCH(ret);
3492 register PERL_CONTEXT *cx;
3494 const U8 save_flags = PL_op -> op_flags;
3499 retop = cx->blk_eval.retop;
3502 if (gimme == G_VOID)
3504 else if (gimme == G_SCALAR) {
3507 if (SvFLAGS(TOPs) & SVs_TEMP)
3510 *MARK = sv_mortalcopy(TOPs);
3514 *MARK = &PL_sv_undef;
3519 /* in case LEAVE wipes old return values */
3520 for (mark = newsp + 1; mark <= SP; mark++) {
3521 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3522 *mark = sv_mortalcopy(*mark);
3523 TAINT_NOT; /* Each item is independent */
3527 PL_curpm = newpm; /* Don't pop $1 et al till now */
3530 assert(CvDEPTH(PL_compcv) == 1);
3532 CvDEPTH(PL_compcv) = 0;
3535 if (optype == OP_REQUIRE &&
3536 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3538 /* Unassume the success we assumed earlier. */
3539 SV * const nsv = cx->blk_eval.old_namesv;
3540 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3541 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3542 /* die_where() did LEAVE, or we won't be here */
3546 if (!(save_flags & OPf_SPECIAL))
3547 sv_setpvn(ERRSV,"",0);
3556 register PERL_CONTEXT *cx;
3557 const I32 gimme = GIMME_V;
3562 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3564 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3566 PL_in_eval = EVAL_INEVAL;
3567 sv_setpvn(ERRSV,"",0);
3569 return DOCATCH(PL_op->op_next);
3579 register PERL_CONTEXT *cx;
3586 if (gimme == G_VOID)
3588 else if (gimme == G_SCALAR) {
3591 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3594 *MARK = sv_mortalcopy(TOPs);
3598 *MARK = &PL_sv_undef;
3603 /* in case LEAVE wipes old return values */
3604 for (mark = newsp + 1; mark <= SP; mark++) {
3605 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3606 *mark = sv_mortalcopy(*mark);
3607 TAINT_NOT; /* Each item is independent */
3611 PL_curpm = newpm; /* Don't pop $1 et al till now */
3614 sv_setpvn(ERRSV,"",0);
3619 S_doparseform(pTHX_ SV *sv)
3622 register char *s = SvPV_force(sv, len);
3623 register char *send = s + len;
3624 register char *base = Nullch;
3625 register I32 skipspaces = 0;
3626 bool noblank = FALSE;
3627 bool repeat = FALSE;
3628 bool postspace = FALSE;
3634 bool unchopnum = FALSE;
3635 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3638 Perl_croak(aTHX_ "Null picture in formline");
3640 /* estimate the buffer size needed */
3641 for (base = s; s <= send; s++) {
3642 if (*s == '\n' || *s == '@' || *s == '^')
3648 New(804, fops, maxops, U32);
3653 *fpc++ = FF_LINEMARK;
3654 noblank = repeat = FALSE;
3672 case ' ': case '\t':
3679 } /* else FALL THROUGH */
3687 *fpc++ = FF_LITERAL;
3695 *fpc++ = (U16)skipspaces;
3699 *fpc++ = FF_NEWLINE;
3703 arg = fpc - linepc + 1;
3710 *fpc++ = FF_LINEMARK;
3711 noblank = repeat = FALSE;
3720 ischop = s[-1] == '^';
3726 arg = (s - base) - 1;
3728 *fpc++ = FF_LITERAL;
3736 *fpc++ = 2; /* skip the @* or ^* */
3738 *fpc++ = FF_LINESNGL;
3741 *fpc++ = FF_LINEGLOB;
3743 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3744 arg = ischop ? 512 : 0;
3749 const char * const f = ++s;
3752 arg |= 256 + (s - f);
3754 *fpc++ = s - base; /* fieldsize for FETCH */
3755 *fpc++ = FF_DECIMAL;
3757 unchopnum |= ! ischop;
3759 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3760 arg = ischop ? 512 : 0;
3762 s++; /* skip the '0' first */
3766 const char * const f = ++s;
3769 arg |= 256 + (s - f);
3771 *fpc++ = s - base; /* fieldsize for FETCH */
3772 *fpc++ = FF_0DECIMAL;
3774 unchopnum |= ! ischop;
3778 bool ismore = FALSE;
3781 while (*++s == '>') ;
3782 prespace = FF_SPACE;
3784 else if (*s == '|') {
3785 while (*++s == '|') ;
3786 prespace = FF_HALFSPACE;
3791 while (*++s == '<') ;
3794 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3798 *fpc++ = s - base; /* fieldsize for FETCH */
3800 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3803 *fpc++ = (U16)prespace;
3817 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3819 { /* need to jump to the next word */
3821 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3822 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3823 s = SvPVX(sv) + SvCUR(sv) + z;
3825 Copy(fops, s, arg, U32);
3827 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3830 if (unchopnum && repeat)
3831 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3837 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3839 /* Can value be printed in fldsize chars, using %*.*f ? */
3843 int intsize = fldsize - (value < 0 ? 1 : 0);
3850 while (intsize--) pwr *= 10.0;
3851 while (frcsize--) eps /= 10.0;
3854 if (value + eps >= pwr)
3857 if (value - eps <= -pwr)
3864 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3867 SV *datasv = FILTER_DATA(idx);
3868 const int filter_has_file = IoLINES(datasv);
3869 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3870 SV *filter_state = (SV *)IoTOP_GV(datasv);
3871 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3874 /* I was having segfault trouble under Linux 2.2.5 after a
3875 parse error occured. (Had to hack around it with a test
3876 for PL_error_count == 0.) Solaris doesn't segfault --
3877 not sure where the trouble is yet. XXX */
3879 if (filter_has_file) {
3880 len = FILTER_READ(idx+1, buf_sv, maxlen);
3883 if (filter_sub && len >= 0) {
3894 PUSHs(sv_2mortal(newSViv(maxlen)));
3896 PUSHs(filter_state);
3899 count = call_sv(filter_sub, G_SCALAR);
3915 IoLINES(datasv) = 0;
3916 if (filter_child_proc) {
3917 SvREFCNT_dec(filter_child_proc);
3918 IoFMT_GV(datasv) = Nullgv;
3921 SvREFCNT_dec(filter_state);
3922 IoTOP_GV(datasv) = Nullgv;
3925 SvREFCNT_dec(filter_sub);
3926 IoBOTTOM_GV(datasv) = Nullgv;
3928 filter_del(run_user_filter);
3934 /* perhaps someone can come up with a better name for
3935 this? it is not really "absolute", per se ... */
3937 S_path_is_absolute(pTHX_ const char *name)
3939 if (PERL_FILE_IS_ABSOLUTE(name)
3940 #ifdef MACOS_TRADITIONAL
3943 || (*name == '.' && (name[1] == '/' ||
3944 (name[1] == '.' && name[2] == '/'))))
3955 * c-indentation-style: bsd
3957 * indent-tabs-mode: t
3960 * ex: set ts=8 sts=4 sw=4 noet: