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 */
1380 Perl_qerror(pTHX_ SV *err)
1383 sv_catsv(ERRSV, err);
1385 sv_catsv(PL_errors, err);
1387 Perl_warn(aTHX_ "%"SVf, err);
1392 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1401 if (PL_in_eval & EVAL_KEEPERR) {
1402 static const char prefix[] = "\t(in cleanup) ";
1404 const char *e = Nullch;
1406 sv_setpvn(err,"",0);
1407 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1409 e = SvPV_const(err, len);
1411 if (*e != *message || strNE(e,message))
1415 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1416 sv_catpvn(err, prefix, sizeof(prefix)-1);
1417 sv_catpvn(err, message, msglen);
1418 if (ckWARN(WARN_MISC)) {
1419 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1420 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1425 sv_setpvn(ERRSV, message, msglen);
1429 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1430 && PL_curstackinfo->si_prev)
1438 register PERL_CONTEXT *cx;
1441 if (cxix < cxstack_ix)
1444 POPBLOCK(cx,PL_curpm);
1445 if (CxTYPE(cx) != CXt_EVAL) {
1447 message = SvPVx_const(ERRSV, msglen);
1448 PerlIO_write(Perl_error_log, "panic: die ", 11);
1449 PerlIO_write(Perl_error_log, message, msglen);
1454 if (gimme == G_SCALAR)
1455 *++newsp = &PL_sv_undef;
1456 PL_stack_sp = newsp;
1460 /* LEAVE could clobber PL_curcop (see save_re_context())
1461 * XXX it might be better to find a way to avoid messing with
1462 * PL_curcop in save_re_context() instead, but this is a more
1463 * minimal fix --GSAR */
1464 PL_curcop = cx->blk_oldcop;
1466 if (optype == OP_REQUIRE) {
1467 const char* msg = SvPVx_nolen_const(ERRSV);
1468 SV * const nsv = cx->blk_eval.old_namesv;
1469 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1471 DIE(aTHX_ "%sCompilation failed in require",
1472 *msg ? msg : "Unknown error\n");
1474 assert(CxTYPE(cx) == CXt_EVAL);
1475 return cx->blk_eval.retop;
1479 message = SvPVx_const(ERRSV, msglen);
1481 write_to_stderr(message, msglen);
1490 if (SvTRUE(left) != SvTRUE(right))
1502 RETURNOP(cLOGOP->op_other);
1511 RETURNOP(cLOGOP->op_other);
1520 if (!sv || !SvANY(sv)) {
1521 RETURNOP(cLOGOP->op_other);
1524 switch (SvTYPE(sv)) {
1526 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1530 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1534 if (CvROOT(sv) || CvXSUB(sv))
1544 RETURNOP(cLOGOP->op_other);
1550 register I32 cxix = dopoptosub(cxstack_ix);
1551 register const PERL_CONTEXT *cx;
1552 register const PERL_CONTEXT *ccstack = cxstack;
1553 const PERL_SI *top_si = PL_curstackinfo;
1555 const char *stashname;
1562 /* we may be in a higher stacklevel, so dig down deeper */
1563 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1564 top_si = top_si->si_prev;
1565 ccstack = top_si->si_cxstack;
1566 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1569 if (GIMME != G_ARRAY) {
1575 /* caller() should not report the automatic calls to &DB::sub */
1576 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1577 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1581 cxix = dopoptosub_at(ccstack, cxix - 1);
1584 cx = &ccstack[cxix];
1585 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1586 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1587 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1588 field below is defined for any cx. */
1589 /* caller() should not report the automatic calls to &DB::sub */
1590 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1591 cx = &ccstack[dbcxix];
1594 stashname = CopSTASHPV(cx->blk_oldcop);
1595 if (GIMME != G_ARRAY) {
1598 PUSHs(&PL_sv_undef);
1601 sv_setpv(TARG, stashname);
1610 PUSHs(&PL_sv_undef);
1612 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1613 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1614 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1617 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1618 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1619 /* So is ccstack[dbcxix]. */
1621 SV * const sv = NEWSV(49, 0);
1622 gv_efullname3(sv, cvgv, Nullch);
1623 PUSHs(sv_2mortal(sv));
1624 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1627 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1628 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1632 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1633 PUSHs(sv_2mortal(newSViv(0)));
1635 gimme = (I32)cx->blk_gimme;
1636 if (gimme == G_VOID)
1637 PUSHs(&PL_sv_undef);
1639 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1640 if (CxTYPE(cx) == CXt_EVAL) {
1642 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1643 PUSHs(cx->blk_eval.cur_text);
1647 else if (cx->blk_eval.old_namesv) {
1648 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1651 /* eval BLOCK (try blocks have old_namesv == 0) */
1653 PUSHs(&PL_sv_undef);
1654 PUSHs(&PL_sv_undef);
1658 PUSHs(&PL_sv_undef);
1659 PUSHs(&PL_sv_undef);
1661 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1662 && CopSTASH_eq(PL_curcop, PL_debstash))
1664 AV * const ary = cx->blk_sub.argarray;
1665 const int off = AvARRAY(ary) - AvALLOC(ary);
1669 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1672 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1675 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1676 av_extend(PL_dbargs, AvFILLp(ary) + off);
1677 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1678 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1680 /* XXX only hints propagated via op_private are currently
1681 * visible (others are not easily accessible, since they
1682 * use the global PL_hints) */
1683 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1684 HINT_PRIVATE_MASK)));
1687 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1689 if (old_warnings == pWARN_NONE ||
1690 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1691 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1692 else if (old_warnings == pWARN_ALL ||
1693 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1694 /* Get the bit mask for $warnings::Bits{all}, because
1695 * it could have been extended by warnings::register */
1697 HV *bits = get_hv("warnings::Bits", FALSE);
1698 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1699 mask = newSVsv(*bits_all);
1702 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1706 mask = newSVsv(old_warnings);
1707 PUSHs(sv_2mortal(mask));
1721 sv_reset(tmps, CopSTASH(PL_curcop));
1731 /* like pp_nextstate, but used instead when the debugger is active */
1736 PL_curcop = (COP*)PL_op;
1737 TAINT_NOT; /* Each statement is presumed innocent */
1738 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1741 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1742 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1746 register PERL_CONTEXT *cx;
1747 const I32 gimme = G_ARRAY;
1754 DIE(aTHX_ "No DB::DB routine defined");
1756 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1757 /* don't do recursive DB::DB call */
1769 PUSHBLOCK(cx, CXt_SUB, SP);
1771 cx->blk_sub.retop = PL_op->op_next;
1773 PAD_SET_CUR(CvPADLIST(cv),1);
1774 RETURNOP(CvSTART(cv));
1788 register PERL_CONTEXT *cx;
1789 const I32 gimme = GIMME_V;
1791 U32 cxtype = CXt_LOOP;
1799 if (PL_op->op_targ) {
1800 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1801 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1802 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1803 SVs_PADSTALE, SVs_PADSTALE);
1805 #ifndef USE_ITHREADS
1806 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1809 SAVEPADSV(PL_op->op_targ);
1810 iterdata = INT2PTR(void*, PL_op->op_targ);
1811 cxtype |= CXp_PADVAR;
1816 svp = &GvSV(gv); /* symbol table variable */
1817 SAVEGENERICSV(*svp);
1820 iterdata = (void*)gv;
1826 PUSHBLOCK(cx, cxtype, SP);
1828 PUSHLOOP(cx, iterdata, MARK);
1830 PUSHLOOP(cx, svp, MARK);
1832 if (PL_op->op_flags & OPf_STACKED) {
1833 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1834 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1836 SV *right = (SV*)cx->blk_loop.iterary;
1837 if (RANGE_IS_NUMERIC(sv,right)) {
1838 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1839 (SvOK(right) && SvNV(right) >= IV_MAX))
1840 DIE(aTHX_ "Range iterator outside integer range");
1841 cx->blk_loop.iterix = SvIV(sv);
1842 cx->blk_loop.itermax = SvIV(right);
1845 cx->blk_loop.iterlval = newSVsv(sv);
1846 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1847 (void) SvPV_nolen_const(right);
1850 else if (PL_op->op_private & OPpITER_REVERSED) {
1851 cx->blk_loop.itermax = -1;
1852 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1857 cx->blk_loop.iterary = PL_curstack;
1858 AvFILLp(PL_curstack) = SP - PL_stack_base;
1859 if (PL_op->op_private & OPpITER_REVERSED) {
1860 cx->blk_loop.itermax = MARK - PL_stack_base;
1861 cx->blk_loop.iterix = cx->blk_oldsp;
1864 cx->blk_loop.iterix = MARK - PL_stack_base;
1874 register PERL_CONTEXT *cx;
1875 const I32 gimme = GIMME_V;
1881 PUSHBLOCK(cx, CXt_LOOP, SP);
1882 PUSHLOOP(cx, 0, SP);
1890 register PERL_CONTEXT *cx;
1897 assert(CxTYPE(cx) == CXt_LOOP);
1899 newsp = PL_stack_base + cx->blk_loop.resetsp;
1902 if (gimme == G_VOID)
1904 else if (gimme == G_SCALAR) {
1906 *++newsp = sv_mortalcopy(*SP);
1908 *++newsp = &PL_sv_undef;
1912 *++newsp = sv_mortalcopy(*++mark);
1913 TAINT_NOT; /* Each item is independent */
1919 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1920 PL_curpm = newpm; /* ... and pop $1 et al */
1932 register PERL_CONTEXT *cx;
1933 bool popsub2 = FALSE;
1934 bool clear_errsv = FALSE;
1942 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1943 if (cxstack_ix == PL_sortcxix
1944 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1946 if (cxstack_ix > PL_sortcxix)
1947 dounwind(PL_sortcxix);
1948 AvARRAY(PL_curstack)[1] = *SP;
1949 PL_stack_sp = PL_stack_base + 1;
1954 cxix = dopoptosub(cxstack_ix);
1956 DIE(aTHX_ "Can't return outside a subroutine");
1957 if (cxix < cxstack_ix)
1961 switch (CxTYPE(cx)) {
1964 retop = cx->blk_sub.retop;
1965 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1968 if (!(PL_in_eval & EVAL_KEEPERR))
1971 retop = cx->blk_eval.retop;
1975 if (optype == OP_REQUIRE &&
1976 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1978 /* Unassume the success we assumed earlier. */
1979 SV * const nsv = cx->blk_eval.old_namesv;
1980 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1981 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1986 retop = cx->blk_sub.retop;
1989 DIE(aTHX_ "panic: return");
1993 if (gimme == G_SCALAR) {
1996 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1998 *++newsp = SvREFCNT_inc(*SP);
2003 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2005 *++newsp = sv_mortalcopy(sv);
2010 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2013 *++newsp = sv_mortalcopy(*SP);
2016 *++newsp = &PL_sv_undef;
2018 else if (gimme == G_ARRAY) {
2019 while (++MARK <= SP) {
2020 *++newsp = (popsub2 && SvTEMP(*MARK))
2021 ? *MARK : sv_mortalcopy(*MARK);
2022 TAINT_NOT; /* Each item is independent */
2025 PL_stack_sp = newsp;
2028 /* Stack values are safe: */
2031 POPSUB(cx,sv); /* release CV and @_ ... */
2035 PL_curpm = newpm; /* ... and pop $1 et al */
2039 sv_setpvn(ERRSV,"",0);
2047 register PERL_CONTEXT *cx;
2057 if (PL_op->op_flags & OPf_SPECIAL) {
2058 cxix = dopoptoloop(cxstack_ix);
2060 DIE(aTHX_ "Can't \"last\" outside a loop block");
2063 cxix = dopoptolabel(cPVOP->op_pv);
2065 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2067 if (cxix < cxstack_ix)
2071 cxstack_ix++; /* temporarily protect top context */
2073 switch (CxTYPE(cx)) {
2076 newsp = PL_stack_base + cx->blk_loop.resetsp;
2077 nextop = cx->blk_loop.last_op->op_next;
2081 nextop = cx->blk_sub.retop;
2085 nextop = cx->blk_eval.retop;
2089 nextop = cx->blk_sub.retop;
2092 DIE(aTHX_ "panic: last");
2096 if (gimme == G_SCALAR) {
2098 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2099 ? *SP : sv_mortalcopy(*SP);
2101 *++newsp = &PL_sv_undef;
2103 else if (gimme == G_ARRAY) {
2104 while (++MARK <= SP) {
2105 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2106 ? *MARK : sv_mortalcopy(*MARK);
2107 TAINT_NOT; /* Each item is independent */
2115 /* Stack values are safe: */
2118 POPLOOP(cx); /* release loop vars ... */
2122 POPSUB(cx,sv); /* release CV and @_ ... */
2125 PL_curpm = newpm; /* ... and pop $1 et al */
2135 register PERL_CONTEXT *cx;
2138 if (PL_op->op_flags & OPf_SPECIAL) {
2139 cxix = dopoptoloop(cxstack_ix);
2141 DIE(aTHX_ "Can't \"next\" outside a loop block");
2144 cxix = dopoptolabel(cPVOP->op_pv);
2146 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2148 if (cxix < cxstack_ix)
2151 /* clear off anything above the scope we're re-entering, but
2152 * save the rest until after a possible continue block */
2153 inner = PL_scopestack_ix;
2155 if (PL_scopestack_ix < inner)
2156 leave_scope(PL_scopestack[PL_scopestack_ix]);
2157 PL_curcop = cx->blk_oldcop;
2158 return cx->blk_loop.next_op;
2165 register PERL_CONTEXT *cx;
2169 if (PL_op->op_flags & OPf_SPECIAL) {
2170 cxix = dopoptoloop(cxstack_ix);
2172 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2175 cxix = dopoptolabel(cPVOP->op_pv);
2177 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2179 if (cxix < cxstack_ix)
2182 redo_op = cxstack[cxix].blk_loop.redo_op;
2183 if (redo_op->op_type == OP_ENTER) {
2184 /* pop one less context to avoid $x being freed in while (my $x..) */
2186 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2187 redo_op = redo_op->op_next;
2191 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2192 LEAVE_SCOPE(oldsave);
2194 PL_curcop = cx->blk_oldcop;
2199 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2203 static const char too_deep[] = "Target of goto is too deeply nested";
2206 Perl_croak(aTHX_ too_deep);
2207 if (o->op_type == OP_LEAVE ||
2208 o->op_type == OP_SCOPE ||
2209 o->op_type == OP_LEAVELOOP ||
2210 o->op_type == OP_LEAVESUB ||
2211 o->op_type == OP_LEAVETRY)
2213 *ops++ = cUNOPo->op_first;
2215 Perl_croak(aTHX_ too_deep);
2218 if (o->op_flags & OPf_KIDS) {
2219 /* First try all the kids at this level, since that's likeliest. */
2220 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2221 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2222 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2225 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2226 if (kid == PL_lastgotoprobe)
2228 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2231 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2232 ops[-1]->op_type == OP_DBSTATE)
2237 if ((o = dofindlabel(kid, label, ops, oplimit)))
2256 register PERL_CONTEXT *cx;
2257 #define GOTO_DEPTH 64
2258 OP *enterops[GOTO_DEPTH];
2259 const char *label = 0;
2260 const bool do_dump = (PL_op->op_type == OP_DUMP);
2261 static const char must_have_label[] = "goto must have label";
2263 if (PL_op->op_flags & OPf_STACKED) {
2266 /* This egregious kludge implements goto &subroutine */
2267 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2269 register PERL_CONTEXT *cx;
2270 CV* cv = (CV*)SvRV(sv);
2277 if (!CvROOT(cv) && !CvXSUB(cv)) {
2278 const GV * const gv = CvGV(cv);
2282 /* autoloaded stub? */
2283 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2285 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2286 GvNAMELEN(gv), FALSE);
2287 if (autogv && (cv = GvCV(autogv)))
2289 tmpstr = sv_newmortal();
2290 gv_efullname3(tmpstr, gv, Nullch);
2291 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2293 DIE(aTHX_ "Goto undefined subroutine");
2296 /* First do some returnish stuff. */
2297 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2299 cxix = dopoptosub(cxstack_ix);
2301 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2302 if (cxix < cxstack_ix)
2306 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2307 if (CxTYPE(cx) == CXt_EVAL) {
2309 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2311 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2313 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2314 /* put @_ back onto stack */
2315 AV* av = cx->blk_sub.argarray;
2317 items = AvFILLp(av) + 1;
2318 EXTEND(SP, items+1); /* @_ could have been extended. */
2319 Copy(AvARRAY(av), SP + 1, items, SV*);
2320 SvREFCNT_dec(GvAV(PL_defgv));
2321 GvAV(PL_defgv) = cx->blk_sub.savearray;
2323 /* abandon @_ if it got reified */
2328 av_extend(av, items-1);
2330 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2333 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2335 av = GvAV(PL_defgv);
2336 items = AvFILLp(av) + 1;
2337 EXTEND(SP, items+1); /* @_ could have been extended. */
2338 Copy(AvARRAY(av), SP + 1, items, SV*);
2342 if (CxTYPE(cx) == CXt_SUB &&
2343 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2344 SvREFCNT_dec(cx->blk_sub.cv);
2345 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2346 LEAVE_SCOPE(oldsave);
2348 /* Now do some callish stuff. */
2350 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2352 OP* retop = cx->blk_sub.retop;
2355 for (index=0; index<items; index++)
2356 sv_2mortal(SP[-index]);
2358 #ifdef PERL_XSUB_OLDSTYLE
2359 if (CvOLDSTYLE(cv)) {
2360 I32 (*fp3)(int,int,int);
2365 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2366 items = (*fp3)(CvXSUBANY(cv).any_i32,
2367 mark - PL_stack_base + 1,
2369 SP = PL_stack_base + items;
2372 #endif /* PERL_XSUB_OLDSTYLE */
2377 /* XS subs don't have a CxSUB, so pop it */
2378 POPBLOCK(cx, PL_curpm);
2379 /* Push a mark for the start of arglist */
2382 (void)(*CvXSUB(cv))(aTHX_ cv);
2388 AV* padlist = CvPADLIST(cv);
2389 if (CxTYPE(cx) == CXt_EVAL) {
2390 PL_in_eval = cx->blk_eval.old_in_eval;
2391 PL_eval_root = cx->blk_eval.old_eval_root;
2392 cx->cx_type = CXt_SUB;
2393 cx->blk_sub.hasargs = 0;
2395 cx->blk_sub.cv = cv;
2396 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2399 if (CvDEPTH(cv) < 2)
2400 (void)SvREFCNT_inc(cv);
2402 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2403 sub_crush_depth(cv);
2404 pad_push(padlist, CvDEPTH(cv));
2406 PAD_SET_CUR(padlist, CvDEPTH(cv));
2407 if (cx->blk_sub.hasargs)
2409 AV* av = (AV*)PAD_SVl(0);
2412 cx->blk_sub.savearray = GvAV(PL_defgv);
2413 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2414 CX_CURPAD_SAVE(cx->blk_sub);
2415 cx->blk_sub.argarray = av;
2417 if (items >= AvMAX(av) + 1) {
2419 if (AvARRAY(av) != ary) {
2420 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2421 SvPV_set(av, (char*)ary);
2423 if (items >= AvMAX(av) + 1) {
2424 AvMAX(av) = items - 1;
2425 Renew(ary,items+1,SV*);
2427 SvPV_set(av, (char*)ary);
2431 Copy(mark,AvARRAY(av),items,SV*);
2432 AvFILLp(av) = items - 1;
2433 assert(!AvREAL(av));
2435 /* transfer 'ownership' of refcnts to new @_ */
2445 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2447 * We do not care about using sv to call CV;
2448 * it's for informational purposes only.
2450 SV *sv = GvSV(PL_DBsub);
2454 if (PERLDB_SUB_NN) {
2455 int type = SvTYPE(sv);
2456 if (type < SVt_PVIV && type != SVt_IV)
2457 sv_upgrade(sv, SVt_PVIV);
2459 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2461 gv_efullname3(sv, CvGV(cv), Nullch);
2464 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2465 PUSHMARK( PL_stack_sp );
2466 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2470 RETURNOP(CvSTART(cv));
2474 label = SvPV_nolen_const(sv);
2475 if (!(do_dump || *label))
2476 DIE(aTHX_ must_have_label);
2479 else if (PL_op->op_flags & OPf_SPECIAL) {
2481 DIE(aTHX_ must_have_label);
2484 label = cPVOP->op_pv;
2486 if (label && *label) {
2488 bool leaving_eval = FALSE;
2489 bool in_block = FALSE;
2490 PERL_CONTEXT *last_eval_cx = 0;
2494 PL_lastgotoprobe = 0;
2496 for (ix = cxstack_ix; ix >= 0; ix--) {
2498 switch (CxTYPE(cx)) {
2500 leaving_eval = TRUE;
2501 if (!CxTRYBLOCK(cx)) {
2502 gotoprobe = (last_eval_cx ?
2503 last_eval_cx->blk_eval.old_eval_root :
2508 /* else fall through */
2510 gotoprobe = cx->blk_oldcop->op_sibling;
2516 gotoprobe = cx->blk_oldcop->op_sibling;
2519 gotoprobe = PL_main_root;
2522 if (CvDEPTH(cx->blk_sub.cv)) {
2523 gotoprobe = CvROOT(cx->blk_sub.cv);
2529 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2532 DIE(aTHX_ "panic: goto");
2533 gotoprobe = PL_main_root;
2537 retop = dofindlabel(gotoprobe, label,
2538 enterops, enterops + GOTO_DEPTH);
2542 PL_lastgotoprobe = gotoprobe;
2545 DIE(aTHX_ "Can't find label %s", label);
2547 /* if we're leaving an eval, check before we pop any frames
2548 that we're not going to punt, otherwise the error
2551 if (leaving_eval && *enterops && enterops[1]) {
2553 for (i = 1; enterops[i]; i++)
2554 if (enterops[i]->op_type == OP_ENTERITER)
2555 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2558 /* pop unwanted frames */
2560 if (ix < cxstack_ix) {
2567 oldsave = PL_scopestack[PL_scopestack_ix];
2568 LEAVE_SCOPE(oldsave);
2571 /* push wanted frames */
2573 if (*enterops && enterops[1]) {
2575 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2576 for (; enterops[ix]; ix++) {
2577 PL_op = enterops[ix];
2578 /* Eventually we may want to stack the needed arguments
2579 * for each op. For now, we punt on the hard ones. */
2580 if (PL_op->op_type == OP_ENTERITER)
2581 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2582 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2590 if (!retop) retop = PL_main_start;
2592 PL_restartop = retop;
2593 PL_do_undump = TRUE;
2597 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2598 PL_do_undump = FALSE;
2614 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2616 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2619 PL_exit_flags |= PERL_EXIT_EXPECTED;
2621 PUSHs(&PL_sv_undef);
2629 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2630 register I32 match = I_32(value);
2633 if (((NV)match) > value)
2634 --match; /* was fractional--truncate other way */
2636 match -= cCOP->uop.scop.scop_offset;
2639 else if (match > cCOP->uop.scop.scop_max)
2640 match = cCOP->uop.scop.scop_max;
2641 PL_op = cCOP->uop.scop.scop_next[match];
2651 PL_op = PL_op->op_next; /* can't assume anything */
2653 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2654 match -= cCOP->uop.scop.scop_offset;
2657 else if (match > cCOP->uop.scop.scop_max)
2658 match = cCOP->uop.scop.scop_max;
2659 PL_op = cCOP->uop.scop.scop_next[match];
2668 S_save_lines(pTHX_ AV *array, SV *sv)
2670 const char *s = SvPVX_const(sv);
2671 const char *send = SvPVX_const(sv) + SvCUR(sv);
2674 while (s && s < send) {
2676 SV *tmpstr = NEWSV(85,0);
2678 sv_upgrade(tmpstr, SVt_PVMG);
2679 t = strchr(s, '\n');
2685 sv_setpvn(tmpstr, s, t - s);
2686 av_store(array, line++, tmpstr);
2692 S_docatch_body(pTHX)
2699 S_docatch(pTHX_ OP *o)
2702 OP * const oldop = PL_op;
2706 assert(CATCH_GET == TRUE);
2713 assert(cxstack_ix >= 0);
2714 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2715 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2720 /* die caught by an inner eval - continue inner loop */
2722 /* NB XXX we rely on the old popped CxEVAL still being at the top
2723 * of the stack; the way die_where() currently works, this
2724 * assumption is valid. In theory The cur_top_env value should be
2725 * returned in another global, the way retop (aka PL_restartop)
2727 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2730 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2732 PL_op = PL_restartop;
2749 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2750 /* sv Text to convert to OP tree. */
2751 /* startop op_free() this to undo. */
2752 /* code Short string id of the caller. */
2754 dVAR; dSP; /* Make POPBLOCK work. */
2757 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2761 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2762 char *tmpbuf = tbuf;
2765 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2770 /* switch to eval mode */
2772 if (IN_PERL_COMPILETIME) {
2773 SAVECOPSTASH_FREE(&PL_compiling);
2774 CopSTASH_set(&PL_compiling, PL_curstash);
2776 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2777 SV *sv = sv_newmortal();
2778 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2779 code, (unsigned long)++PL_evalseq,
2780 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2784 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2785 SAVECOPFILE_FREE(&PL_compiling);
2786 CopFILE_set(&PL_compiling, tmpbuf+2);
2787 SAVECOPLINE(&PL_compiling);
2788 CopLINE_set(&PL_compiling, 1);
2789 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2790 deleting the eval's FILEGV from the stash before gv_check() runs
2791 (i.e. before run-time proper). To work around the coredump that
2792 ensues, we always turn GvMULTI_on for any globals that were
2793 introduced within evals. See force_ident(). GSAR 96-10-12 */
2794 safestr = savepv(tmpbuf);
2795 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2797 #ifdef OP_IN_REGISTER
2803 /* we get here either during compilation, or via pp_regcomp at runtime */
2804 runtime = IN_PERL_RUNTIME;
2806 runcv = find_runcv(NULL);
2809 PL_op->op_type = OP_ENTEREVAL;
2810 PL_op->op_flags = 0; /* Avoid uninit warning. */
2811 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2812 PUSHEVAL(cx, 0, Nullgv);
2815 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2817 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2818 POPBLOCK(cx,PL_curpm);
2821 (*startop)->op_type = OP_NULL;
2822 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2824 /* XXX DAPM do this properly one year */
2825 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2827 if (IN_PERL_COMPILETIME)
2828 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2829 #ifdef OP_IN_REGISTER
2837 =for apidoc find_runcv
2839 Locate the CV corresponding to the currently executing sub or eval.
2840 If db_seqp is non_null, skip CVs that are in the DB package and populate
2841 *db_seqp with the cop sequence number at the point that the DB:: code was
2842 entered. (allows debuggers to eval in the scope of the breakpoint rather
2843 than in in the scope of the debugger itself).
2849 Perl_find_runcv(pTHX_ U32 *db_seqp)
2854 *db_seqp = PL_curcop->cop_seq;
2855 for (si = PL_curstackinfo; si; si = si->si_prev) {
2857 for (ix = si->si_cxix; ix >= 0; ix--) {
2858 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2859 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2860 CV *cv = cx->blk_sub.cv;
2861 /* skip DB:: code */
2862 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2863 *db_seqp = cx->blk_oldcop->cop_seq;
2868 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2876 /* Compile a require/do, an eval '', or a /(?{...})/.
2877 * In the last case, startop is non-null, and contains the address of
2878 * a pointer that should be set to the just-compiled code.
2879 * outside is the lexically enclosing CV (if any) that invoked us.
2882 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2884 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2889 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2890 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2895 SAVESPTR(PL_compcv);
2896 PL_compcv = (CV*)NEWSV(1104,0);
2897 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2898 CvEVAL_on(PL_compcv);
2899 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2900 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2902 CvOUTSIDE_SEQ(PL_compcv) = seq;
2903 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2905 /* set up a scratch pad */
2907 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2910 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2912 /* make sure we compile in the right package */
2914 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2915 SAVESPTR(PL_curstash);
2916 PL_curstash = CopSTASH(PL_curcop);
2918 SAVESPTR(PL_beginav);
2919 PL_beginav = newAV();
2920 SAVEFREESV(PL_beginav);
2921 SAVEI32(PL_error_count);
2923 /* try to compile it */
2925 PL_eval_root = Nullop;
2927 PL_curcop = &PL_compiling;
2928 PL_curcop->cop_arybase = 0;
2929 if (saveop && saveop->op_flags & OPf_SPECIAL)
2930 PL_in_eval |= EVAL_KEEPERR;
2932 sv_setpvn(ERRSV,"",0);
2933 if (yyparse() || PL_error_count || !PL_eval_root) {
2934 SV **newsp; /* Used by POPBLOCK. */
2935 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2936 I32 optype = 0; /* Might be reset by POPEVAL. */
2940 op_free(PL_eval_root);
2941 PL_eval_root = Nullop;
2943 SP = PL_stack_base + POPMARK; /* pop original mark */
2945 POPBLOCK(cx,PL_curpm);
2950 if (optype == OP_REQUIRE) {
2951 const char* const msg = SvPVx_nolen_const(ERRSV);
2952 const SV * const nsv = cx->blk_eval.old_namesv;
2953 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2955 DIE(aTHX_ "%sCompilation failed in require",
2956 *msg ? msg : "Unknown error\n");
2959 const char* msg = SvPVx_nolen_const(ERRSV);
2961 POPBLOCK(cx,PL_curpm);
2963 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2964 (*msg ? msg : "Unknown error\n"));
2967 const char* msg = SvPVx_nolen_const(ERRSV);
2969 sv_setpv(ERRSV, "Compilation error");
2974 CopLINE_set(&PL_compiling, 0);
2976 *startop = PL_eval_root;
2978 SAVEFREEOP(PL_eval_root);
2980 /* Set the context for this new optree.
2981 * If the last op is an OP_REQUIRE, force scalar context.
2982 * Otherwise, propagate the context from the eval(). */
2983 if (PL_eval_root->op_type == OP_LEAVEEVAL
2984 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2985 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2987 scalar(PL_eval_root);
2988 else if (gimme & G_VOID)
2989 scalarvoid(PL_eval_root);
2990 else if (gimme & G_ARRAY)
2993 scalar(PL_eval_root);
2995 DEBUG_x(dump_eval());
2997 /* Register with debugger: */
2998 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2999 CV *cv = get_cv("DB::postponed", FALSE);
3003 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3005 call_sv((SV*)cv, G_DISCARD);
3009 /* compiled okay, so do it */
3011 CvDEPTH(PL_compcv) = 1;
3012 SP = PL_stack_base + POPMARK; /* pop original mark */
3013 PL_op = saveop; /* The caller may need it. */
3014 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3016 RETURNOP(PL_eval_start);
3020 S_doopen_pm(pTHX_ const char *name, const char *mode)
3022 #ifndef PERL_DISABLE_PMC
3023 const STRLEN namelen = strlen(name);
3026 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3027 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3028 const char * const pmc = SvPV_nolen_const(pmcsv);
3031 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3032 fp = PerlIO_open(name, mode);
3035 if (PerlLIO_stat(name, &pmstat) < 0 ||
3036 pmstat.st_mtime < pmcstat.st_mtime)
3038 fp = PerlIO_open(pmc, mode);
3041 fp = PerlIO_open(name, mode);
3044 SvREFCNT_dec(pmcsv);
3047 fp = PerlIO_open(name, mode);
3051 return PerlIO_open(name, mode);
3052 #endif /* !PERL_DISABLE_PMC */
3058 register PERL_CONTEXT *cx;
3062 const char *tryname = Nullch;
3063 SV *namesv = Nullsv;
3065 const I32 gimme = GIMME_V;
3066 PerlIO *tryrsfp = 0;
3067 int filter_has_file = 0;
3068 GV *filter_child_proc = 0;
3069 SV *filter_state = 0;
3076 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3077 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3078 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3079 "v-string in use/require non-portable");
3081 sv = new_version(sv);
3082 if (!sv_derived_from(PL_patchlevel, "version"))
3083 (void *)upg_version(PL_patchlevel);
3084 if ( vcmp(sv,PL_patchlevel) > 0 )
3085 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3086 vnormal(sv), vnormal(PL_patchlevel));
3090 name = SvPV_const(sv, len);
3091 if (!(name && len > 0 && *name))
3092 DIE(aTHX_ "Null filename used");
3093 TAINT_PROPER("require");
3094 if (PL_op->op_type == OP_REQUIRE &&
3095 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3096 if (*svp != &PL_sv_undef)
3099 DIE(aTHX_ "Compilation failed in require");
3102 /* prepare to compile file */
3104 if (path_is_absolute(name)) {
3106 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3108 #ifdef MACOS_TRADITIONAL
3112 MacPerl_CanonDir(name, newname, 1);
3113 if (path_is_absolute(newname)) {
3115 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3120 AV *ar = GvAVn(PL_incgv);
3124 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3127 namesv = NEWSV(806, 0);
3128 for (i = 0; i <= AvFILL(ar); i++) {
3129 SV *dirsv = *av_fetch(ar, i, TRUE);
3135 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3136 && !sv_isobject(loader))
3138 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3141 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3142 PTR2UV(SvRV(dirsv)), name);
3143 tryname = SvPVX_const(namesv);
3154 if (sv_isobject(loader))
3155 count = call_method("INC", G_ARRAY);
3157 count = call_sv(loader, G_ARRAY);
3167 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3171 if (SvTYPE(arg) == SVt_PVGV) {
3172 IO *io = GvIO((GV *)arg);
3177 tryrsfp = IoIFP(io);
3178 if (IoTYPE(io) == IoTYPE_PIPE) {
3179 /* reading from a child process doesn't
3180 nest -- when returning from reading
3181 the inner module, the outer one is
3182 unreadable (closed?) I've tried to
3183 save the gv to manage the lifespan of
3184 the pipe, but this didn't help. XXX */
3185 filter_child_proc = (GV *)arg;
3186 (void)SvREFCNT_inc(filter_child_proc);
3189 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3190 PerlIO_close(IoOFP(io));
3202 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3204 (void)SvREFCNT_inc(filter_sub);
3207 filter_state = SP[i];
3208 (void)SvREFCNT_inc(filter_state);
3212 tryrsfp = PerlIO_open("/dev/null",
3228 filter_has_file = 0;
3229 if (filter_child_proc) {
3230 SvREFCNT_dec(filter_child_proc);
3231 filter_child_proc = 0;
3234 SvREFCNT_dec(filter_state);
3238 SvREFCNT_dec(filter_sub);
3243 if (!path_is_absolute(name)
3244 #ifdef MACOS_TRADITIONAL
3245 /* We consider paths of the form :a:b ambiguous and interpret them first
3246 as global then as local
3248 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3251 const char *dir = SvPVx_nolen_const(dirsv);
3252 #ifdef MACOS_TRADITIONAL
3256 MacPerl_CanonDir(name, buf2, 1);
3257 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3261 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3263 sv_setpv(namesv, unixdir);
3264 sv_catpv(namesv, unixname);
3267 if (PL_origfilename[0] &&
3268 PL_origfilename[1] == ':' &&
3269 !(dir[0] && dir[1] == ':'))
3270 Perl_sv_setpvf(aTHX_ namesv,
3275 Perl_sv_setpvf(aTHX_ namesv,
3279 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3283 TAINT_PROPER("require");
3284 tryname = SvPVX_const(namesv);
3285 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3287 if (tryname[0] == '.' && tryname[1] == '/')
3296 SAVECOPFILE_FREE(&PL_compiling);
3297 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3298 SvREFCNT_dec(namesv);
3300 if (PL_op->op_type == OP_REQUIRE) {
3301 const char *msgstr = name;
3302 if (namesv) { /* did we lookup @INC? */
3303 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3304 SV *dirmsgsv = NEWSV(0, 0);
3305 AV *ar = GvAVn(PL_incgv);
3307 sv_catpvn(msg, " in @INC", 8);
3308 if (instr(SvPVX_const(msg), ".h "))
3309 sv_catpv(msg, " (change .h to .ph maybe?)");
3310 if (instr(SvPVX_const(msg), ".ph "))
3311 sv_catpv(msg, " (did you run h2ph?)");
3312 sv_catpv(msg, " (@INC contains:");
3313 for (i = 0; i <= AvFILL(ar); i++) {
3314 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3315 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3316 sv_catsv(msg, dirmsgsv);
3318 sv_catpvn(msg, ")", 1);
3319 SvREFCNT_dec(dirmsgsv);
3320 msgstr = SvPV_nolen_const(msg);
3322 DIE(aTHX_ "Can't locate %s", msgstr);
3328 SETERRNO(0, SS_NORMAL);
3330 /* Assume success here to prevent recursive requirement. */
3332 /* Check whether a hook in @INC has already filled %INC */
3333 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3334 (void)hv_store(GvHVn(PL_incgv), name, len,
3335 (hook_sv ? SvREFCNT_inc(hook_sv)
3336 : newSVpv(CopFILE(&PL_compiling), 0)),
3342 lex_start(sv_2mortal(newSVpvn("",0)));
3343 SAVEGENERICSV(PL_rsfp_filters);
3344 PL_rsfp_filters = Nullav;
3349 SAVESPTR(PL_compiling.cop_warnings);
3350 if (PL_dowarn & G_WARN_ALL_ON)
3351 PL_compiling.cop_warnings = pWARN_ALL ;
3352 else if (PL_dowarn & G_WARN_ALL_OFF)
3353 PL_compiling.cop_warnings = pWARN_NONE ;
3354 else if (PL_taint_warn)
3355 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3357 PL_compiling.cop_warnings = pWARN_STD ;
3358 SAVESPTR(PL_compiling.cop_io);
3359 PL_compiling.cop_io = Nullsv;
3361 if (filter_sub || filter_child_proc) {
3362 SV *datasv = filter_add(run_user_filter, Nullsv);
3363 IoLINES(datasv) = filter_has_file;
3364 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3365 IoTOP_GV(datasv) = (GV *)filter_state;
3366 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3369 /* switch to eval mode */
3370 PUSHBLOCK(cx, CXt_EVAL, SP);
3371 PUSHEVAL(cx, name, Nullgv);
3372 cx->blk_eval.retop = PL_op->op_next;
3374 SAVECOPLINE(&PL_compiling);
3375 CopLINE_set(&PL_compiling, 0);
3379 /* Store and reset encoding. */
3380 encoding = PL_encoding;
3381 PL_encoding = Nullsv;
3383 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3385 /* Restore encoding. */
3386 PL_encoding = encoding;
3393 return pp_require();
3399 register PERL_CONTEXT *cx;
3401 const I32 gimme = GIMME_V, was = PL_sub_generation;
3402 char tbuf[TYPE_DIGITS(long) + 12];
3403 char *tmpbuf = tbuf;
3410 if (!SvPV_const(sv,len))
3412 TAINT_PROPER("eval");
3418 /* switch to eval mode */
3420 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3421 SV *sv = sv_newmortal();
3422 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3423 (unsigned long)++PL_evalseq,
3424 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3428 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3429 SAVECOPFILE_FREE(&PL_compiling);
3430 CopFILE_set(&PL_compiling, tmpbuf+2);
3431 SAVECOPLINE(&PL_compiling);
3432 CopLINE_set(&PL_compiling, 1);
3433 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3434 deleting the eval's FILEGV from the stash before gv_check() runs
3435 (i.e. before run-time proper). To work around the coredump that
3436 ensues, we always turn GvMULTI_on for any globals that were
3437 introduced within evals. See force_ident(). GSAR 96-10-12 */
3438 safestr = savepv(tmpbuf);
3439 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3441 PL_hints = PL_op->op_targ;
3442 SAVESPTR(PL_compiling.cop_warnings);
3443 if (specialWARN(PL_curcop->cop_warnings))
3444 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3446 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3447 SAVEFREESV(PL_compiling.cop_warnings);
3449 SAVESPTR(PL_compiling.cop_io);
3450 if (specialCopIO(PL_curcop->cop_io))
3451 PL_compiling.cop_io = PL_curcop->cop_io;
3453 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3454 SAVEFREESV(PL_compiling.cop_io);
3456 /* special case: an eval '' executed within the DB package gets lexically
3457 * placed in the first non-DB CV rather than the current CV - this
3458 * allows the debugger to execute code, find lexicals etc, in the
3459 * scope of the code being debugged. Passing &seq gets find_runcv
3460 * to do the dirty work for us */
3461 runcv = find_runcv(&seq);
3463 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3464 PUSHEVAL(cx, 0, Nullgv);
3465 cx->blk_eval.retop = PL_op->op_next;
3467 /* prepare to compile string */
3469 if (PERLDB_LINE && PL_curstash != PL_debstash)
3470 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3472 ret = doeval(gimme, NULL, runcv, seq);
3473 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3474 && ret != PL_op->op_next) { /* Successive compilation. */
3475 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3477 return DOCATCH(ret);
3487 register PERL_CONTEXT *cx;
3489 const U8 save_flags = PL_op -> op_flags;
3494 retop = cx->blk_eval.retop;
3497 if (gimme == G_VOID)
3499 else if (gimme == G_SCALAR) {
3502 if (SvFLAGS(TOPs) & SVs_TEMP)
3505 *MARK = sv_mortalcopy(TOPs);
3509 *MARK = &PL_sv_undef;
3514 /* in case LEAVE wipes old return values */
3515 for (mark = newsp + 1; mark <= SP; mark++) {
3516 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3517 *mark = sv_mortalcopy(*mark);
3518 TAINT_NOT; /* Each item is independent */
3522 PL_curpm = newpm; /* Don't pop $1 et al till now */
3525 assert(CvDEPTH(PL_compcv) == 1);
3527 CvDEPTH(PL_compcv) = 0;
3530 if (optype == OP_REQUIRE &&
3531 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3533 /* Unassume the success we assumed earlier. */
3534 SV * const nsv = cx->blk_eval.old_namesv;
3535 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3536 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3537 /* die_where() did LEAVE, or we won't be here */
3541 if (!(save_flags & OPf_SPECIAL))
3542 sv_setpvn(ERRSV,"",0);
3551 register PERL_CONTEXT *cx;
3552 const I32 gimme = GIMME_V;
3557 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3559 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3561 PL_in_eval = EVAL_INEVAL;
3562 sv_setpvn(ERRSV,"",0);
3564 return DOCATCH(PL_op->op_next);
3574 register PERL_CONTEXT *cx;
3581 if (gimme == G_VOID)
3583 else if (gimme == G_SCALAR) {
3586 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3589 *MARK = sv_mortalcopy(TOPs);
3593 *MARK = &PL_sv_undef;
3598 /* in case LEAVE wipes old return values */
3599 for (mark = newsp + 1; mark <= SP; mark++) {
3600 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3601 *mark = sv_mortalcopy(*mark);
3602 TAINT_NOT; /* Each item is independent */
3606 PL_curpm = newpm; /* Don't pop $1 et al till now */
3609 sv_setpvn(ERRSV,"",0);
3614 S_doparseform(pTHX_ SV *sv)
3617 register char *s = SvPV_force(sv, len);
3618 register char *send = s + len;
3619 register char *base = Nullch;
3620 register I32 skipspaces = 0;
3621 bool noblank = FALSE;
3622 bool repeat = FALSE;
3623 bool postspace = FALSE;
3629 bool unchopnum = FALSE;
3630 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3633 Perl_croak(aTHX_ "Null picture in formline");
3635 /* estimate the buffer size needed */
3636 for (base = s; s <= send; s++) {
3637 if (*s == '\n' || *s == '@' || *s == '^')
3643 New(804, fops, maxops, U32);
3648 *fpc++ = FF_LINEMARK;
3649 noblank = repeat = FALSE;
3667 case ' ': case '\t':
3674 } /* else FALL THROUGH */
3682 *fpc++ = FF_LITERAL;
3690 *fpc++ = (U16)skipspaces;
3694 *fpc++ = FF_NEWLINE;
3698 arg = fpc - linepc + 1;
3705 *fpc++ = FF_LINEMARK;
3706 noblank = repeat = FALSE;
3715 ischop = s[-1] == '^';
3721 arg = (s - base) - 1;
3723 *fpc++ = FF_LITERAL;
3731 *fpc++ = 2; /* skip the @* or ^* */
3733 *fpc++ = FF_LINESNGL;
3736 *fpc++ = FF_LINEGLOB;
3738 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3739 arg = ischop ? 512 : 0;
3744 const char * const f = ++s;
3747 arg |= 256 + (s - f);
3749 *fpc++ = s - base; /* fieldsize for FETCH */
3750 *fpc++ = FF_DECIMAL;
3752 unchopnum |= ! ischop;
3754 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3755 arg = ischop ? 512 : 0;
3757 s++; /* skip the '0' first */
3761 const char * const f = ++s;
3764 arg |= 256 + (s - f);
3766 *fpc++ = s - base; /* fieldsize for FETCH */
3767 *fpc++ = FF_0DECIMAL;
3769 unchopnum |= ! ischop;
3773 bool ismore = FALSE;
3776 while (*++s == '>') ;
3777 prespace = FF_SPACE;
3779 else if (*s == '|') {
3780 while (*++s == '|') ;
3781 prespace = FF_HALFSPACE;
3786 while (*++s == '<') ;
3789 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3793 *fpc++ = s - base; /* fieldsize for FETCH */
3795 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3798 *fpc++ = (U16)prespace;
3812 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3814 { /* need to jump to the next word */
3816 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3817 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3818 s = SvPVX(sv) + SvCUR(sv) + z;
3820 Copy(fops, s, arg, U32);
3822 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3825 if (unchopnum && repeat)
3826 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3832 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3834 /* Can value be printed in fldsize chars, using %*.*f ? */
3838 int intsize = fldsize - (value < 0 ? 1 : 0);
3845 while (intsize--) pwr *= 10.0;
3846 while (frcsize--) eps /= 10.0;
3849 if (value + eps >= pwr)
3852 if (value - eps <= -pwr)
3859 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3862 SV *datasv = FILTER_DATA(idx);
3863 const int filter_has_file = IoLINES(datasv);
3864 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3865 SV *filter_state = (SV *)IoTOP_GV(datasv);
3866 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3869 /* I was having segfault trouble under Linux 2.2.5 after a
3870 parse error occured. (Had to hack around it with a test
3871 for PL_error_count == 0.) Solaris doesn't segfault --
3872 not sure where the trouble is yet. XXX */
3874 if (filter_has_file) {
3875 len = FILTER_READ(idx+1, buf_sv, maxlen);
3878 if (filter_sub && len >= 0) {
3889 PUSHs(sv_2mortal(newSViv(maxlen)));
3891 PUSHs(filter_state);
3894 count = call_sv(filter_sub, G_SCALAR);
3910 IoLINES(datasv) = 0;
3911 if (filter_child_proc) {
3912 SvREFCNT_dec(filter_child_proc);
3913 IoFMT_GV(datasv) = Nullgv;
3916 SvREFCNT_dec(filter_state);
3917 IoTOP_GV(datasv) = Nullgv;
3920 SvREFCNT_dec(filter_sub);
3921 IoBOTTOM_GV(datasv) = Nullgv;
3923 filter_del(run_user_filter);
3929 /* perhaps someone can come up with a better name for
3930 this? it is not really "absolute", per se ... */
3932 S_path_is_absolute(pTHX_ const char *name)
3934 if (PERL_FILE_IS_ABSOLUTE(name)
3935 #ifdef MACOS_TRADITIONAL
3938 || (*name == '.' && (name[1] == '/' ||
3939 (name[1] == '.' && name[2] == '/'))))
3950 * c-indentation-style: bsd
3952 * indent-tabs-mode: t
3955 * ex: set ts=8 sts=4 sw=4 noet: