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) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
75 register PMOP *pm = (PMOP*)cLOGOP->op_other;
77 MAGIC *mg = Null(MAGIC*);
79 /* prevent recompiling under /o and ithreads. */
80 #if defined(USE_ITHREADS)
81 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
82 if (PL_op->op_flags & OPf_STACKED) {
91 if (PL_op->op_flags & OPf_STACKED) {
92 /* multiple args; concatentate them */
94 tmpstr = PAD_SV(ARGTARG);
95 sv_setpvn(tmpstr, "", 0);
96 while (++MARK <= SP) {
97 if (PL_amagic_generation) {
99 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
100 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
102 sv_setsv(tmpstr, sv);
106 sv_catsv(tmpstr, *MARK);
115 SV *sv = SvRV(tmpstr);
117 mg = mg_find(sv, PERL_MAGIC_qr);
120 regexp * const re = (regexp *)mg->mg_obj;
121 ReREFCNT_dec(PM_GETRE(pm));
122 PM_SETRE(pm, ReREFCNT_inc(re));
126 const char *t = SvPV_const(tmpstr, len);
128 /* Check against the last compiled regexp. */
129 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
130 PM_GETRE(pm)->prelen != (I32)len ||
131 memNE(PM_GETRE(pm)->precomp, t, len))
134 ReREFCNT_dec(PM_GETRE(pm));
135 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
137 if (PL_op->op_flags & OPf_SPECIAL)
138 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
140 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
142 pm->op_pmdynflags |= PMdf_DYN_UTF8;
144 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
145 if (pm->op_pmdynflags & PMdf_UTF8)
146 t = (char*)bytes_to_utf8((U8*)t, &len);
148 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
149 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
151 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
152 inside tie/overload accessors. */
156 #ifndef INCOMPLETE_TAINTS
159 pm->op_pmdynflags |= PMdf_TAINTED;
161 pm->op_pmdynflags &= ~PMdf_TAINTED;
165 if (!PM_GETRE(pm)->prelen && PL_curpm)
167 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
168 pm->op_pmflags |= PMf_WHITE;
170 pm->op_pmflags &= ~PMf_WHITE;
172 /* XXX runtime compiled output needs to move to the pad */
173 if (pm->op_pmflags & PMf_KEEP) {
174 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
175 #if !defined(USE_ITHREADS)
176 /* XXX can't change the optree at runtime either */
177 cLOGOP->op_first->op_next = PL_op->op_next;
186 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
187 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
188 register SV * const dstr = cx->sb_dstr;
189 register char *s = cx->sb_s;
190 register char *m = cx->sb_m;
191 char *orig = cx->sb_orig;
192 register REGEXP * const rx = cx->sb_rx;
194 REGEXP *old = PM_GETRE(pm);
201 rxres_restore(&cx->sb_rxres, rx);
202 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
204 if (cx->sb_iters++) {
205 const I32 saviters = cx->sb_iters;
206 if (cx->sb_iters > cx->sb_maxiters)
207 DIE(aTHX_ "Substitution loop");
209 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
210 cx->sb_rxtainted |= 2;
211 sv_catsv(dstr, POPs);
214 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
215 s == m, cx->sb_targ, NULL,
216 ((cx->sb_rflags & REXEC_COPY_STR)
217 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
218 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
220 SV * const targ = cx->sb_targ;
222 assert(cx->sb_strend >= s);
223 if(cx->sb_strend > s) {
224 if (DO_UTF8(dstr) && !SvUTF8(targ))
225 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
227 sv_catpvn(dstr, s, cx->sb_strend - s);
229 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
231 #ifdef PERL_OLD_COPY_ON_WRITE
233 sv_force_normal_flags(targ, SV_COW_DROP_PV);
239 SvPV_set(targ, SvPVX(dstr));
240 SvCUR_set(targ, SvCUR(dstr));
241 SvLEN_set(targ, SvLEN(dstr));
244 SvPV_set(dstr, (char*)0);
247 TAINT_IF(cx->sb_rxtainted & 1);
248 PUSHs(sv_2mortal(newSViv(saviters - 1)));
250 (void)SvPOK_only_UTF8(targ);
251 TAINT_IF(cx->sb_rxtainted);
255 LEAVE_SCOPE(cx->sb_oldsave);
258 RETURNOP(pm->op_next);
260 cx->sb_iters = saviters;
262 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
265 cx->sb_orig = orig = rx->subbeg;
267 cx->sb_strend = s + (cx->sb_strend - m);
269 cx->sb_m = m = rx->startp[0] + orig;
271 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
272 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
274 sv_catpvn(dstr, s, m-s);
276 cx->sb_s = rx->endp[0] + orig;
277 { /* Update the pos() information. */
278 SV * const sv = cx->sb_targ;
281 if (SvTYPE(sv) < SVt_PVMG)
282 SvUPGRADE(sv, SVt_PVMG);
283 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
284 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
285 mg = mg_find(sv, PERL_MAGIC_regex_global);
293 (void)ReREFCNT_inc(rx);
294 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
295 rxres_save(&cx->sb_rxres, rx);
296 RETURNOP(pm->op_pmreplstart);
300 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
305 if (!p || p[1] < rx->nparens) {
306 #ifdef PERL_OLD_COPY_ON_WRITE
307 i = 7 + rx->nparens * 2;
309 i = 6 + rx->nparens * 2;
318 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
319 RX_MATCH_COPIED_off(rx);
321 #ifdef PERL_OLD_COPY_ON_WRITE
322 *p++ = PTR2UV(rx->saved_copy);
323 rx->saved_copy = Nullsv;
328 *p++ = PTR2UV(rx->subbeg);
329 *p++ = (UV)rx->sublen;
330 for (i = 0; i <= rx->nparens; ++i) {
331 *p++ = (UV)rx->startp[i];
332 *p++ = (UV)rx->endp[i];
337 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
342 RX_MATCH_COPY_FREE(rx);
343 RX_MATCH_COPIED_set(rx, *p);
346 #ifdef PERL_OLD_COPY_ON_WRITE
348 SvREFCNT_dec (rx->saved_copy);
349 rx->saved_copy = INT2PTR(SV*,*p);
355 rx->subbeg = INT2PTR(char*,*p++);
356 rx->sublen = (I32)(*p++);
357 for (i = 0; i <= rx->nparens; ++i) {
358 rx->startp[i] = (I32)(*p++);
359 rx->endp[i] = (I32)(*p++);
364 Perl_rxres_free(pTHX_ void **rsp)
366 UV * const p = (UV*)*rsp;
370 void *tmp = INT2PTR(char*,*p);
373 Poison(*p, 1, sizeof(*p));
375 Safefree(INT2PTR(char*,*p));
377 #ifdef PERL_OLD_COPY_ON_WRITE
379 SvREFCNT_dec (INT2PTR(SV*,p[1]));
389 dSP; dMARK; dORIGMARK;
390 register SV * const tmpForm = *++MARK;
395 register SV *sv = Nullsv;
396 const char *item = Nullch;
400 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
401 const char *chophere = Nullch;
402 char *linemark = Nullch;
404 bool gotsome = FALSE;
406 const STRLEN fudge = SvPOK(tmpForm)
407 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
408 bool item_is_utf8 = FALSE;
409 bool targ_is_utf8 = FALSE;
415 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
416 if (SvREADONLY(tmpForm)) {
417 SvREADONLY_off(tmpForm);
418 parseres = doparseform(tmpForm);
419 SvREADONLY_on(tmpForm);
422 parseres = doparseform(tmpForm);
426 SvPV_force(PL_formtarget, len);
427 if (DO_UTF8(PL_formtarget))
429 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
431 f = SvPV_const(tmpForm, len);
432 /* need to jump to the next word */
433 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
437 const char *name = "???";
440 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
441 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
442 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
443 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
444 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
446 case FF_CHECKNL: name = "CHECKNL"; break;
447 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
448 case FF_SPACE: name = "SPACE"; break;
449 case FF_HALFSPACE: name = "HALFSPACE"; break;
450 case FF_ITEM: name = "ITEM"; break;
451 case FF_CHOP: name = "CHOP"; break;
452 case FF_LINEGLOB: name = "LINEGLOB"; break;
453 case FF_NEWLINE: name = "NEWLINE"; break;
454 case FF_MORE: name = "MORE"; break;
455 case FF_LINEMARK: name = "LINEMARK"; break;
456 case FF_END: name = "END"; break;
457 case FF_0DECIMAL: name = "0DECIMAL"; break;
458 case FF_LINESNGL: name = "LINESNGL"; break;
461 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
463 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
474 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
475 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
477 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
478 t = SvEND(PL_formtarget);
481 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
482 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
484 sv_utf8_upgrade(PL_formtarget);
485 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
486 t = SvEND(PL_formtarget);
506 if (ckWARN(WARN_SYNTAX))
507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
514 const char *s = item = SvPV_const(sv, len);
517 itemsize = sv_len_utf8(sv);
518 if (itemsize != (I32)len) {
520 if (itemsize > fieldsize) {
521 itemsize = fieldsize;
522 itembytes = itemsize;
523 sv_pos_u2b(sv, &itembytes, 0);
527 send = chophere = s + itembytes;
537 sv_pos_b2u(sv, &itemsize);
541 item_is_utf8 = FALSE;
542 if (itemsize > fieldsize)
543 itemsize = fieldsize;
544 send = chophere = s + itemsize;
558 const char *s = item = SvPV_const(sv, len);
561 itemsize = sv_len_utf8(sv);
562 if (itemsize != (I32)len) {
564 if (itemsize <= fieldsize) {
565 const char *send = chophere = s + itemsize;
578 itemsize = fieldsize;
579 itembytes = itemsize;
580 sv_pos_u2b(sv, &itembytes, 0);
581 send = chophere = s + itembytes;
582 while (s < send || (s == send && isSPACE(*s))) {
592 if (strchr(PL_chopset, *s))
597 itemsize = chophere - item;
598 sv_pos_b2u(sv, &itemsize);
604 item_is_utf8 = FALSE;
605 if (itemsize <= fieldsize) {
606 const char *const send = chophere = s + itemsize;
619 itemsize = fieldsize;
620 send = chophere = s + itemsize;
621 while (s < send || (s == send && isSPACE(*s))) {
631 if (strchr(PL_chopset, *s))
636 itemsize = chophere - item;
642 arg = fieldsize - itemsize;
651 arg = fieldsize - itemsize;
662 const char *s = item;
666 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
668 sv_utf8_upgrade(PL_formtarget);
669 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
670 t = SvEND(PL_formtarget);
674 if (UTF8_IS_CONTINUED(*s)) {
675 STRLEN skip = UTF8SKIP(s);
692 if ( !((*t++ = *s++) & ~31) )
698 if (targ_is_utf8 && !item_is_utf8) {
699 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
701 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
702 for (; t < SvEND(PL_formtarget); t++) {
715 const int ch = *t++ = *s++;
718 if ( !((*t++ = *s++) & ~31) )
727 const char *s = chophere;
729 while (*s && isSPACE(*s))
745 const char *s = item = SvPV_const(sv, len);
747 if ((item_is_utf8 = DO_UTF8(sv)))
748 itemsize = sv_len_utf8(sv);
750 bool chopped = FALSE;
751 const char *const send = s + len;
753 chophere = s + itemsize;
769 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
771 SvUTF8_on(PL_formtarget);
773 SvCUR_set(sv, chophere - item);
774 sv_catsv(PL_formtarget, sv);
775 SvCUR_set(sv, itemsize);
777 sv_catsv(PL_formtarget, sv);
779 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
780 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
781 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
790 #if defined(USE_LONG_DOUBLE)
791 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
793 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
798 #if defined(USE_LONG_DOUBLE)
799 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
801 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
804 /* If the field is marked with ^ and the value is undefined,
806 if ((arg & 512) && !SvOK(sv)) {
814 /* overflow evidence */
815 if (num_overflow(value, fieldsize, arg)) {
821 /* Formats aren't yet marked for locales, so assume "yes". */
823 STORE_NUMERIC_STANDARD_SET_LOCAL();
824 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
825 RESTORE_NUMERIC_STANDARD();
832 while (t-- > linemark && *t == ' ') ;
840 if (arg) { /* repeat until fields exhausted? */
842 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
843 lines += FmLINES(PL_formtarget);
846 if (strnEQ(linemark, linemark - arg, arg))
847 DIE(aTHX_ "Runaway format");
850 SvUTF8_on(PL_formtarget);
851 FmLINES(PL_formtarget) = lines;
853 RETURNOP(cLISTOP->op_first);
864 const char *s = chophere;
865 const char *send = item + len;
867 while (*s && isSPACE(*s) && s < send)
872 arg = fieldsize - itemsize;
879 if (strnEQ(s1," ",3)) {
880 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
891 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
893 SvUTF8_on(PL_formtarget);
894 FmLINES(PL_formtarget) += lines;
906 if (PL_stack_base + *PL_markstack_ptr == SP) {
908 if (GIMME_V == G_SCALAR)
909 XPUSHs(sv_2mortal(newSViv(0)));
910 RETURNOP(PL_op->op_next->op_next);
912 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
913 pp_pushmark(); /* push dst */
914 pp_pushmark(); /* push src */
915 ENTER; /* enter outer scope */
918 if (PL_op->op_private & OPpGREP_LEX)
919 SAVESPTR(PAD_SVl(PL_op->op_targ));
922 ENTER; /* enter inner scope */
925 src = PL_stack_base[*PL_markstack_ptr];
927 if (PL_op->op_private & OPpGREP_LEX)
928 PAD_SVl(PL_op->op_targ) = src;
933 if (PL_op->op_type == OP_MAPSTART)
934 pp_pushmark(); /* push top */
935 return ((LOGOP*)PL_op->op_next)->op_other;
941 const I32 gimme = GIMME_V;
942 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
948 /* first, move source pointer to the next item in the source list */
949 ++PL_markstack_ptr[-1];
951 /* if there are new items, push them into the destination list */
952 if (items && gimme != G_VOID) {
953 /* might need to make room back there first */
954 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
955 /* XXX this implementation is very pessimal because the stack
956 * is repeatedly extended for every set of items. Is possible
957 * to do this without any stack extension or copying at all
958 * by maintaining a separate list over which the map iterates
959 * (like foreach does). --gsar */
961 /* everything in the stack after the destination list moves
962 * towards the end the stack by the amount of room needed */
963 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
965 /* items to shift up (accounting for the moved source pointer) */
966 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
968 /* This optimization is by Ben Tilly and it does
969 * things differently from what Sarathy (gsar)
970 * is describing. The downside of this optimization is
971 * that leaves "holes" (uninitialized and hopefully unused areas)
972 * to the Perl stack, but on the other hand this
973 * shouldn't be a problem. If Sarathy's idea gets
974 * implemented, this optimization should become
975 * irrelevant. --jhi */
977 shift = count; /* Avoid shifting too often --Ben Tilly */
982 PL_markstack_ptr[-1] += shift;
983 *PL_markstack_ptr += shift;
987 /* copy the new items down to the destination list */
988 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
989 if (gimme == G_ARRAY) {
991 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
994 /* scalar context: we don't care about which values map returns
995 * (we use undef here). And so we certainly don't want to do mortal
996 * copies of meaningless values. */
997 while (items-- > 0) {
999 *dst-- = &PL_sv_undef;
1003 LEAVE; /* exit inner scope */
1006 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1008 (void)POPMARK; /* pop top */
1009 LEAVE; /* exit outer scope */
1010 (void)POPMARK; /* pop src */
1011 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1012 (void)POPMARK; /* pop dst */
1013 SP = PL_stack_base + POPMARK; /* pop original mark */
1014 if (gimme == G_SCALAR) {
1015 if (PL_op->op_private & OPpGREP_LEX) {
1016 SV* sv = sv_newmortal();
1017 sv_setiv(sv, items);
1025 else if (gimme == G_ARRAY)
1032 ENTER; /* enter inner scope */
1035 /* set $_ to the new source item */
1036 src = PL_stack_base[PL_markstack_ptr[-1]];
1038 if (PL_op->op_private & OPpGREP_LEX)
1039 PAD_SVl(PL_op->op_targ) = src;
1043 RETURNOP(cLOGOP->op_other);
1051 if (GIMME == G_ARRAY)
1053 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1054 return cLOGOP->op_other;
1063 if (GIMME == G_ARRAY) {
1064 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1068 SV * const targ = PAD_SV(PL_op->op_targ);
1071 if (PL_op->op_private & OPpFLIP_LINENUM) {
1072 if (GvIO(PL_last_in_gv)) {
1073 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1076 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1078 flip = SvIV(sv) == SvIV(GvSV(gv));
1084 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1085 if (PL_op->op_flags & OPf_SPECIAL) {
1093 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1096 sv_setpvn(TARG, "", 0);
1102 /* This code tries to decide if "$left .. $right" should use the
1103 magical string increment, or if the range is numeric (we make
1104 an exception for .."0" [#18165]). AMS 20021031. */
1106 #define RANGE_IS_NUMERIC(left,right) ( \
1107 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1108 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1109 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1110 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1111 && (!SvOK(right) || looks_like_number(right))))
1117 if (GIMME == G_ARRAY) {
1123 if (RANGE_IS_NUMERIC(left,right)) {
1126 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1127 (SvOK(right) && SvNV(right) > IV_MAX))
1128 DIE(aTHX_ "Range iterator outside integer range");
1139 SV * const sv = sv_2mortal(newSViv(i++));
1144 SV * const final = sv_mortalcopy(right);
1146 const char * const tmps = SvPV_const(final, len);
1148 SV *sv = sv_mortalcopy(left);
1149 SvPV_force_nolen(sv);
1150 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1152 if (strEQ(SvPVX_const(sv),tmps))
1154 sv = sv_2mortal(newSVsv(sv));
1161 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1165 if (PL_op->op_private & OPpFLIP_LINENUM) {
1166 if (GvIO(PL_last_in_gv)) {
1167 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1170 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1171 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1179 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1180 sv_catpvn(targ, "E0", 2);
1190 static const char * const context_name[] = {
1201 S_dopoptolabel(pTHX_ const char *label)
1205 for (i = cxstack_ix; i >= 0; i--) {
1206 register const PERL_CONTEXT * const cx = &cxstack[i];
1207 switch (CxTYPE(cx)) {
1213 if (ckWARN(WARN_EXITING))
1214 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1215 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1216 if (CxTYPE(cx) == CXt_NULL)
1220 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1221 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1222 (long)i, cx->blk_loop.label));
1225 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1233 Perl_dowantarray(pTHX)
1235 const I32 gimme = block_gimme();
1236 return (gimme == G_VOID) ? G_SCALAR : gimme;
1240 Perl_block_gimme(pTHX)
1242 const I32 cxix = dopoptosub(cxstack_ix);
1246 switch (cxstack[cxix].blk_gimme) {
1254 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1261 Perl_is_lvalue_sub(pTHX)
1263 const I32 cxix = dopoptosub(cxstack_ix);
1264 assert(cxix >= 0); /* We should only be called from inside subs */
1266 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1267 return cxstack[cxix].blk_sub.lval;
1273 S_dopoptosub(pTHX_ I32 startingblock)
1275 return dopoptosub_at(cxstack, startingblock);
1279 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1282 for (i = startingblock; i >= 0; i--) {
1283 register const PERL_CONTEXT * const cx = &cxstk[i];
1284 switch (CxTYPE(cx)) {
1290 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1298 S_dopoptoeval(pTHX_ I32 startingblock)
1301 for (i = startingblock; i >= 0; i--) {
1302 register const PERL_CONTEXT *cx = &cxstack[i];
1303 switch (CxTYPE(cx)) {
1307 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1315 S_dopoptoloop(pTHX_ I32 startingblock)
1318 for (i = startingblock; i >= 0; i--) {
1319 register const PERL_CONTEXT * const cx = &cxstack[i];
1320 switch (CxTYPE(cx)) {
1326 if (ckWARN(WARN_EXITING))
1327 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1328 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1329 if ((CxTYPE(cx)) == CXt_NULL)
1333 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1341 Perl_dounwind(pTHX_ I32 cxix)
1345 while (cxstack_ix > cxix) {
1347 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1348 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1349 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1350 /* Note: we don't need to restore the base context info till the end. */
1351 switch (CxTYPE(cx)) {
1354 continue; /* not break */
1373 PERL_UNUSED_VAR(optype);
1377 Perl_qerror(pTHX_ SV *err)
1380 sv_catsv(ERRSV, err);
1382 sv_catsv(PL_errors, err);
1384 Perl_warn(aTHX_ "%"SVf, err);
1389 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1398 if (PL_in_eval & EVAL_KEEPERR) {
1399 static const char prefix[] = "\t(in cleanup) ";
1400 SV * const err = ERRSV;
1401 const char *e = Nullch;
1403 sv_setpvn(err,"",0);
1404 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1406 e = SvPV_const(err, len);
1408 if (*e != *message || strNE(e,message))
1412 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1413 sv_catpvn(err, prefix, sizeof(prefix)-1);
1414 sv_catpvn(err, message, msglen);
1415 if (ckWARN(WARN_MISC)) {
1416 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1417 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1422 sv_setpvn(ERRSV, message, msglen);
1426 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1427 && PL_curstackinfo->si_prev)
1435 register PERL_CONTEXT *cx;
1438 if (cxix < cxstack_ix)
1441 POPBLOCK(cx,PL_curpm);
1442 if (CxTYPE(cx) != CXt_EVAL) {
1444 message = SvPVx_const(ERRSV, msglen);
1445 PerlIO_write(Perl_error_log, "panic: die ", 11);
1446 PerlIO_write(Perl_error_log, message, msglen);
1451 if (gimme == G_SCALAR)
1452 *++newsp = &PL_sv_undef;
1453 PL_stack_sp = newsp;
1457 /* LEAVE could clobber PL_curcop (see save_re_context())
1458 * XXX it might be better to find a way to avoid messing with
1459 * PL_curcop in save_re_context() instead, but this is a more
1460 * minimal fix --GSAR */
1461 PL_curcop = cx->blk_oldcop;
1463 if (optype == OP_REQUIRE) {
1464 const char* const msg = SvPVx_nolen_const(ERRSV);
1465 SV * const nsv = cx->blk_eval.old_namesv;
1466 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1468 DIE(aTHX_ "%sCompilation failed in require",
1469 *msg ? msg : "Unknown error\n");
1471 assert(CxTYPE(cx) == CXt_EVAL);
1472 return cx->blk_eval.retop;
1476 message = SvPVx_const(ERRSV, msglen);
1478 write_to_stderr(message, msglen);
1487 if (SvTRUE(left) != SvTRUE(right))
1496 register I32 cxix = dopoptosub(cxstack_ix);
1497 register const PERL_CONTEXT *cx;
1498 register const PERL_CONTEXT *ccstack = cxstack;
1499 const PERL_SI *top_si = PL_curstackinfo;
1501 const char *stashname;
1508 /* we may be in a higher stacklevel, so dig down deeper */
1509 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1510 top_si = top_si->si_prev;
1511 ccstack = top_si->si_cxstack;
1512 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1515 if (GIMME != G_ARRAY) {
1521 /* caller() should not report the automatic calls to &DB::sub */
1522 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1523 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1527 cxix = dopoptosub_at(ccstack, cxix - 1);
1530 cx = &ccstack[cxix];
1531 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1532 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1533 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1534 field below is defined for any cx. */
1535 /* caller() should not report the automatic calls to &DB::sub */
1536 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1537 cx = &ccstack[dbcxix];
1540 stashname = CopSTASHPV(cx->blk_oldcop);
1541 if (GIMME != G_ARRAY) {
1544 PUSHs(&PL_sv_undef);
1547 sv_setpv(TARG, stashname);
1556 PUSHs(&PL_sv_undef);
1558 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1559 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1560 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1563 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1565 /* So is ccstack[dbcxix]. */
1567 SV * const sv = NEWSV(49, 0);
1568 gv_efullname3(sv, cvgv, Nullch);
1569 PUSHs(sv_2mortal(sv));
1570 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1573 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1574 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1578 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1579 PUSHs(sv_2mortal(newSViv(0)));
1581 gimme = (I32)cx->blk_gimme;
1582 if (gimme == G_VOID)
1583 PUSHs(&PL_sv_undef);
1585 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1586 if (CxTYPE(cx) == CXt_EVAL) {
1588 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1589 PUSHs(cx->blk_eval.cur_text);
1593 else if (cx->blk_eval.old_namesv) {
1594 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1597 /* eval BLOCK (try blocks have old_namesv == 0) */
1599 PUSHs(&PL_sv_undef);
1600 PUSHs(&PL_sv_undef);
1604 PUSHs(&PL_sv_undef);
1605 PUSHs(&PL_sv_undef);
1607 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1608 && CopSTASH_eq(PL_curcop, PL_debstash))
1610 AV * const ary = cx->blk_sub.argarray;
1611 const int off = AvARRAY(ary) - AvALLOC(ary);
1615 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1618 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1621 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1622 av_extend(PL_dbargs, AvFILLp(ary) + off);
1623 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1624 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1626 /* XXX only hints propagated via op_private are currently
1627 * visible (others are not easily accessible, since they
1628 * use the global PL_hints) */
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1630 HINT_PRIVATE_MASK)));
1633 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1635 if (old_warnings == pWARN_NONE ||
1636 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1637 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1638 else if (old_warnings == pWARN_ALL ||
1639 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1640 /* Get the bit mask for $warnings::Bits{all}, because
1641 * it could have been extended by warnings::register */
1643 HV *bits = get_hv("warnings::Bits", FALSE);
1644 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1645 mask = newSVsv(*bits_all);
1648 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1652 mask = newSVsv(old_warnings);
1653 PUSHs(sv_2mortal(mask));
1667 sv_reset(tmps, CopSTASH(PL_curcop));
1672 /* like pp_nextstate, but used instead when the debugger is active */
1677 PL_curcop = (COP*)PL_op;
1678 TAINT_NOT; /* Each statement is presumed innocent */
1679 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1682 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1683 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1687 register PERL_CONTEXT *cx;
1688 const I32 gimme = G_ARRAY;
1695 DIE(aTHX_ "No DB::DB routine defined");
1697 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1698 /* don't do recursive DB::DB call */
1713 (void)(*CvXSUB(cv))(aTHX_ cv);
1720 PUSHBLOCK(cx, CXt_SUB, SP);
1722 cx->blk_sub.retop = PL_op->op_next;
1725 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1726 RETURNOP(CvSTART(cv));
1736 register PERL_CONTEXT *cx;
1737 const I32 gimme = GIMME_V;
1739 U32 cxtype = CXt_LOOP;
1747 if (PL_op->op_targ) {
1748 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1749 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1750 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1751 SVs_PADSTALE, SVs_PADSTALE);
1753 #ifndef USE_ITHREADS
1754 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1757 SAVEPADSV(PL_op->op_targ);
1758 iterdata = INT2PTR(void*, PL_op->op_targ);
1759 cxtype |= CXp_PADVAR;
1764 svp = &GvSV(gv); /* symbol table variable */
1765 SAVEGENERICSV(*svp);
1768 iterdata = (void*)gv;
1774 PUSHBLOCK(cx, cxtype, SP);
1776 PUSHLOOP(cx, iterdata, MARK);
1778 PUSHLOOP(cx, svp, MARK);
1780 if (PL_op->op_flags & OPf_STACKED) {
1781 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1782 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1784 SV *right = (SV*)cx->blk_loop.iterary;
1787 if (RANGE_IS_NUMERIC(sv,right)) {
1788 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1789 (SvOK(right) && SvNV(right) >= IV_MAX))
1790 DIE(aTHX_ "Range iterator outside integer range");
1791 cx->blk_loop.iterix = SvIV(sv);
1792 cx->blk_loop.itermax = SvIV(right);
1794 /* for correct -Dstv display */
1795 cx->blk_oldsp = sp - PL_stack_base;
1799 cx->blk_loop.iterlval = newSVsv(sv);
1800 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1801 (void) SvPV_nolen_const(right);
1804 else if (PL_op->op_private & OPpITER_REVERSED) {
1805 cx->blk_loop.itermax = -1;
1806 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1811 cx->blk_loop.iterary = PL_curstack;
1812 AvFILLp(PL_curstack) = SP - PL_stack_base;
1813 if (PL_op->op_private & OPpITER_REVERSED) {
1814 cx->blk_loop.itermax = MARK - PL_stack_base;
1815 cx->blk_loop.iterix = cx->blk_oldsp;
1818 cx->blk_loop.iterix = MARK - PL_stack_base;
1828 register PERL_CONTEXT *cx;
1829 const I32 gimme = GIMME_V;
1835 PUSHBLOCK(cx, CXt_LOOP, SP);
1836 PUSHLOOP(cx, 0, SP);
1844 register PERL_CONTEXT *cx;
1851 assert(CxTYPE(cx) == CXt_LOOP);
1853 newsp = PL_stack_base + cx->blk_loop.resetsp;
1856 if (gimme == G_VOID)
1858 else if (gimme == G_SCALAR) {
1860 *++newsp = sv_mortalcopy(*SP);
1862 *++newsp = &PL_sv_undef;
1866 *++newsp = sv_mortalcopy(*++mark);
1867 TAINT_NOT; /* Each item is independent */
1873 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1874 PL_curpm = newpm; /* ... and pop $1 et al */
1886 register PERL_CONTEXT *cx;
1887 bool popsub2 = FALSE;
1888 bool clear_errsv = FALSE;
1896 cxix = dopoptosub(cxstack_ix);
1898 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1899 * sort block, which is a CXt_NULL
1902 PL_stack_base[1] = *PL_stack_sp;
1903 PL_stack_sp = PL_stack_base + 1;
1907 DIE(aTHX_ "Can't return outside a subroutine");
1909 if (cxix < cxstack_ix)
1912 if (CxMULTICALL(&cxstack[cxix])) {
1913 gimme = cxstack[cxix].blk_gimme;
1914 if (gimme == G_VOID)
1915 PL_stack_sp = PL_stack_base;
1916 else if (gimme == G_SCALAR) {
1917 PL_stack_base[1] = *PL_stack_sp;
1918 PL_stack_sp = PL_stack_base + 1;
1924 switch (CxTYPE(cx)) {
1927 retop = cx->blk_sub.retop;
1928 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1931 if (!(PL_in_eval & EVAL_KEEPERR))
1934 retop = cx->blk_eval.retop;
1938 if (optype == OP_REQUIRE &&
1939 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1941 /* Unassume the success we assumed earlier. */
1942 SV * const nsv = cx->blk_eval.old_namesv;
1943 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1944 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1949 retop = cx->blk_sub.retop;
1952 DIE(aTHX_ "panic: return");
1956 if (gimme == G_SCALAR) {
1959 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1961 *++newsp = SvREFCNT_inc(*SP);
1966 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1968 *++newsp = sv_mortalcopy(sv);
1973 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1976 *++newsp = sv_mortalcopy(*SP);
1979 *++newsp = &PL_sv_undef;
1981 else if (gimme == G_ARRAY) {
1982 while (++MARK <= SP) {
1983 *++newsp = (popsub2 && SvTEMP(*MARK))
1984 ? *MARK : sv_mortalcopy(*MARK);
1985 TAINT_NOT; /* Each item is independent */
1988 PL_stack_sp = newsp;
1991 /* Stack values are safe: */
1994 POPSUB(cx,sv); /* release CV and @_ ... */
1998 PL_curpm = newpm; /* ... and pop $1 et al */
2002 sv_setpvn(ERRSV,"",0);
2010 register PERL_CONTEXT *cx;
2021 if (PL_op->op_flags & OPf_SPECIAL) {
2022 cxix = dopoptoloop(cxstack_ix);
2024 DIE(aTHX_ "Can't \"last\" outside a loop block");
2027 cxix = dopoptolabel(cPVOP->op_pv);
2029 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2031 if (cxix < cxstack_ix)
2035 cxstack_ix++; /* temporarily protect top context */
2037 switch (CxTYPE(cx)) {
2040 newsp = PL_stack_base + cx->blk_loop.resetsp;
2041 nextop = cx->blk_loop.last_op->op_next;
2045 nextop = cx->blk_sub.retop;
2049 nextop = cx->blk_eval.retop;
2053 nextop = cx->blk_sub.retop;
2056 DIE(aTHX_ "panic: last");
2060 if (gimme == G_SCALAR) {
2062 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2063 ? *SP : sv_mortalcopy(*SP);
2065 *++newsp = &PL_sv_undef;
2067 else if (gimme == G_ARRAY) {
2068 while (++MARK <= SP) {
2069 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2070 ? *MARK : sv_mortalcopy(*MARK);
2071 TAINT_NOT; /* Each item is independent */
2079 /* Stack values are safe: */
2082 POPLOOP(cx); /* release loop vars ... */
2086 POPSUB(cx,sv); /* release CV and @_ ... */
2089 PL_curpm = newpm; /* ... and pop $1 et al */
2092 PERL_UNUSED_VAR(optype);
2093 PERL_UNUSED_VAR(gimme);
2101 register PERL_CONTEXT *cx;
2104 if (PL_op->op_flags & OPf_SPECIAL) {
2105 cxix = dopoptoloop(cxstack_ix);
2107 DIE(aTHX_ "Can't \"next\" outside a loop block");
2110 cxix = dopoptolabel(cPVOP->op_pv);
2112 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2114 if (cxix < cxstack_ix)
2117 /* clear off anything above the scope we're re-entering, but
2118 * save the rest until after a possible continue block */
2119 inner = PL_scopestack_ix;
2121 if (PL_scopestack_ix < inner)
2122 leave_scope(PL_scopestack[PL_scopestack_ix]);
2123 PL_curcop = cx->blk_oldcop;
2124 return cx->blk_loop.next_op;
2131 register PERL_CONTEXT *cx;
2135 if (PL_op->op_flags & OPf_SPECIAL) {
2136 cxix = dopoptoloop(cxstack_ix);
2138 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2141 cxix = dopoptolabel(cPVOP->op_pv);
2143 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2145 if (cxix < cxstack_ix)
2148 redo_op = cxstack[cxix].blk_loop.redo_op;
2149 if (redo_op->op_type == OP_ENTER) {
2150 /* pop one less context to avoid $x being freed in while (my $x..) */
2152 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2153 redo_op = redo_op->op_next;
2157 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2158 LEAVE_SCOPE(oldsave);
2160 PL_curcop = cx->blk_oldcop;
2165 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2168 static const char too_deep[] = "Target of goto is too deeply nested";
2171 Perl_croak(aTHX_ too_deep);
2172 if (o->op_type == OP_LEAVE ||
2173 o->op_type == OP_SCOPE ||
2174 o->op_type == OP_LEAVELOOP ||
2175 o->op_type == OP_LEAVESUB ||
2176 o->op_type == OP_LEAVETRY)
2178 *ops++ = cUNOPo->op_first;
2180 Perl_croak(aTHX_ too_deep);
2183 if (o->op_flags & OPf_KIDS) {
2185 /* First try all the kids at this level, since that's likeliest. */
2186 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2187 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2188 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2191 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2192 if (kid == PL_lastgotoprobe)
2194 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2197 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2198 ops[-1]->op_type == OP_DBSTATE)
2203 if ((o = dofindlabel(kid, label, ops, oplimit)))
2216 register PERL_CONTEXT *cx;
2217 #define GOTO_DEPTH 64
2218 OP *enterops[GOTO_DEPTH];
2219 const char *label = 0;
2220 const bool do_dump = (PL_op->op_type == OP_DUMP);
2221 static const char must_have_label[] = "goto must have label";
2223 if (PL_op->op_flags & OPf_STACKED) {
2224 SV * const sv = POPs;
2226 /* This egregious kludge implements goto &subroutine */
2227 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2229 register PERL_CONTEXT *cx;
2230 CV* cv = (CV*)SvRV(sv);
2237 if (!CvROOT(cv) && !CvXSUB(cv)) {
2238 const GV * const gv = CvGV(cv);
2242 /* autoloaded stub? */
2243 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2245 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2246 GvNAMELEN(gv), FALSE);
2247 if (autogv && (cv = GvCV(autogv)))
2249 tmpstr = sv_newmortal();
2250 gv_efullname3(tmpstr, gv, Nullch);
2251 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2253 DIE(aTHX_ "Goto undefined subroutine");
2256 /* First do some returnish stuff. */
2257 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2259 cxix = dopoptosub(cxstack_ix);
2261 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2262 if (cxix < cxstack_ix)
2266 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2267 if (CxTYPE(cx) == CXt_EVAL) {
2269 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2271 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2273 else if (CxMULTICALL(cx))
2274 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2275 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2276 /* put @_ back onto stack */
2277 AV* av = cx->blk_sub.argarray;
2279 items = AvFILLp(av) + 1;
2280 EXTEND(SP, items+1); /* @_ could have been extended. */
2281 Copy(AvARRAY(av), SP + 1, items, SV*);
2282 SvREFCNT_dec(GvAV(PL_defgv));
2283 GvAV(PL_defgv) = cx->blk_sub.savearray;
2285 /* abandon @_ if it got reified */
2290 av_extend(av, items-1);
2292 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2295 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2296 AV* const av = GvAV(PL_defgv);
2297 items = AvFILLp(av) + 1;
2298 EXTEND(SP, items+1); /* @_ could have been extended. */
2299 Copy(AvARRAY(av), SP + 1, items, SV*);
2303 if (CxTYPE(cx) == CXt_SUB &&
2304 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2305 SvREFCNT_dec(cx->blk_sub.cv);
2306 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2307 LEAVE_SCOPE(oldsave);
2309 /* Now do some callish stuff. */
2311 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2313 OP* retop = cx->blk_sub.retop;
2316 for (index=0; index<items; index++)
2317 sv_2mortal(SP[-index]);
2319 #ifdef PERL_XSUB_OLDSTYLE
2320 if (CvOLDSTYLE(cv)) {
2321 I32 (*fp3)(int,int,int);
2326 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2327 items = (*fp3)(CvXSUBANY(cv).any_i32,
2328 mark - PL_stack_base + 1,
2330 SP = PL_stack_base + items;
2333 #endif /* PERL_XSUB_OLDSTYLE */
2338 /* XS subs don't have a CxSUB, so pop it */
2339 POPBLOCK(cx, PL_curpm);
2340 /* Push a mark for the start of arglist */
2343 (void)(*CvXSUB(cv))(aTHX_ cv);
2344 /* Put these at the bottom since the vars are set but not used */
2345 PERL_UNUSED_VAR(newsp);
2346 PERL_UNUSED_VAR(gimme);
2352 AV* padlist = CvPADLIST(cv);
2353 if (CxTYPE(cx) == CXt_EVAL) {
2354 PL_in_eval = cx->blk_eval.old_in_eval;
2355 PL_eval_root = cx->blk_eval.old_eval_root;
2356 cx->cx_type = CXt_SUB;
2357 cx->blk_sub.hasargs = 0;
2359 cx->blk_sub.cv = cv;
2360 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2363 if (CvDEPTH(cv) < 2)
2364 (void)SvREFCNT_inc(cv);
2366 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2367 sub_crush_depth(cv);
2368 pad_push(padlist, CvDEPTH(cv));
2371 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2372 if (cx->blk_sub.hasargs)
2374 AV* av = (AV*)PAD_SVl(0);
2377 cx->blk_sub.savearray = GvAV(PL_defgv);
2378 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2379 CX_CURPAD_SAVE(cx->blk_sub);
2380 cx->blk_sub.argarray = av;
2382 if (items >= AvMAX(av) + 1) {
2384 if (AvARRAY(av) != ary) {
2385 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2386 SvPV_set(av, (char*)ary);
2388 if (items >= AvMAX(av) + 1) {
2389 AvMAX(av) = items - 1;
2390 Renew(ary,items+1,SV*);
2392 SvPV_set(av, (char*)ary);
2396 Copy(mark,AvARRAY(av),items,SV*);
2397 AvFILLp(av) = items - 1;
2398 assert(!AvREAL(av));
2400 /* transfer 'ownership' of refcnts to new @_ */
2410 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2412 * We do not care about using sv to call CV;
2413 * it's for informational purposes only.
2415 SV * const sv = GvSV(PL_DBsub);
2419 if (PERLDB_SUB_NN) {
2420 const int type = SvTYPE(sv);
2421 if (type < SVt_PVIV && type != SVt_IV)
2422 sv_upgrade(sv, SVt_PVIV);
2424 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2426 gv_efullname3(sv, CvGV(cv), Nullch);
2429 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2430 PUSHMARK( PL_stack_sp );
2431 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2435 RETURNOP(CvSTART(cv));
2439 label = SvPV_nolen_const(sv);
2440 if (!(do_dump || *label))
2441 DIE(aTHX_ must_have_label);
2444 else if (PL_op->op_flags & OPf_SPECIAL) {
2446 DIE(aTHX_ must_have_label);
2449 label = cPVOP->op_pv;
2451 if (label && *label) {
2453 bool leaving_eval = FALSE;
2454 bool in_block = FALSE;
2455 PERL_CONTEXT *last_eval_cx = 0;
2459 PL_lastgotoprobe = 0;
2461 for (ix = cxstack_ix; ix >= 0; ix--) {
2463 switch (CxTYPE(cx)) {
2465 leaving_eval = TRUE;
2466 if (!CxTRYBLOCK(cx)) {
2467 gotoprobe = (last_eval_cx ?
2468 last_eval_cx->blk_eval.old_eval_root :
2473 /* else fall through */
2475 gotoprobe = cx->blk_oldcop->op_sibling;
2481 gotoprobe = cx->blk_oldcop->op_sibling;
2484 gotoprobe = PL_main_root;
2487 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2488 gotoprobe = CvROOT(cx->blk_sub.cv);
2494 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2497 DIE(aTHX_ "panic: goto");
2498 gotoprobe = PL_main_root;
2502 retop = dofindlabel(gotoprobe, label,
2503 enterops, enterops + GOTO_DEPTH);
2507 PL_lastgotoprobe = gotoprobe;
2510 DIE(aTHX_ "Can't find label %s", label);
2512 /* if we're leaving an eval, check before we pop any frames
2513 that we're not going to punt, otherwise the error
2516 if (leaving_eval && *enterops && enterops[1]) {
2518 for (i = 1; enterops[i]; i++)
2519 if (enterops[i]->op_type == OP_ENTERITER)
2520 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2523 /* pop unwanted frames */
2525 if (ix < cxstack_ix) {
2532 oldsave = PL_scopestack[PL_scopestack_ix];
2533 LEAVE_SCOPE(oldsave);
2536 /* push wanted frames */
2538 if (*enterops && enterops[1]) {
2540 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2541 for (; enterops[ix]; ix++) {
2542 PL_op = enterops[ix];
2543 /* Eventually we may want to stack the needed arguments
2544 * for each op. For now, we punt on the hard ones. */
2545 if (PL_op->op_type == OP_ENTERITER)
2546 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2547 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2555 if (!retop) retop = PL_main_start;
2557 PL_restartop = retop;
2558 PL_do_undump = TRUE;
2562 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2563 PL_do_undump = FALSE;
2579 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2581 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2584 PL_exit_flags |= PERL_EXIT_EXPECTED;
2586 PUSHs(&PL_sv_undef);
2594 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2595 register I32 match = I_32(value);
2598 if (((NV)match) > value)
2599 --match; /* was fractional--truncate other way */
2601 match -= cCOP->uop.scop.scop_offset;
2604 else if (match > cCOP->uop.scop.scop_max)
2605 match = cCOP->uop.scop.scop_max;
2606 PL_op = cCOP->uop.scop.scop_next[match];
2616 PL_op = PL_op->op_next; /* can't assume anything */
2618 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2619 match -= cCOP->uop.scop.scop_offset;
2622 else if (match > cCOP->uop.scop.scop_max)
2623 match = cCOP->uop.scop.scop_max;
2624 PL_op = cCOP->uop.scop.scop_next[match];
2633 S_save_lines(pTHX_ AV *array, SV *sv)
2635 const char *s = SvPVX_const(sv);
2636 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2639 while (s && s < send) {
2641 SV * const tmpstr = NEWSV(85,0);
2643 sv_upgrade(tmpstr, SVt_PVMG);
2644 t = strchr(s, '\n');
2650 sv_setpvn(tmpstr, s, t - s);
2651 av_store(array, line++, tmpstr);
2657 S_docatch_body(pTHX)
2664 S_docatch(pTHX_ OP *o)
2667 OP * const oldop = PL_op;
2671 assert(CATCH_GET == TRUE);
2678 assert(cxstack_ix >= 0);
2679 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2680 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2685 /* die caught by an inner eval - continue inner loop */
2687 /* NB XXX we rely on the old popped CxEVAL still being at the top
2688 * of the stack; the way die_where() currently works, this
2689 * assumption is valid. In theory The cur_top_env value should be
2690 * returned in another global, the way retop (aka PL_restartop)
2692 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2695 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2697 PL_op = PL_restartop;
2714 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2715 /* sv Text to convert to OP tree. */
2716 /* startop op_free() this to undo. */
2717 /* code Short string id of the caller. */
2719 /* FIXME - how much of this code is common with pp_entereval? */
2720 dVAR; dSP; /* Make POPBLOCK work. */
2727 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2728 char *tmpbuf = tbuf;
2731 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2737 /* switch to eval mode */
2739 if (IN_PERL_COMPILETIME) {
2740 SAVECOPSTASH_FREE(&PL_compiling);
2741 CopSTASH_set(&PL_compiling, PL_curstash);
2743 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2744 SV * const sv = sv_newmortal();
2745 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2746 code, (unsigned long)++PL_evalseq,
2747 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2751 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2752 SAVECOPFILE_FREE(&PL_compiling);
2753 CopFILE_set(&PL_compiling, tmpbuf+2);
2754 SAVECOPLINE(&PL_compiling);
2755 CopLINE_set(&PL_compiling, 1);
2756 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2757 deleting the eval's FILEGV from the stash before gv_check() runs
2758 (i.e. before run-time proper). To work around the coredump that
2759 ensues, we always turn GvMULTI_on for any globals that were
2760 introduced within evals. See force_ident(). GSAR 96-10-12 */
2761 len = strlen(tmpbuf);
2762 safestr = savepvn(tmpbuf, len);
2763 SAVEDELETE(PL_defstash, safestr, len);
2765 #ifdef OP_IN_REGISTER
2771 /* we get here either during compilation, or via pp_regcomp at runtime */
2772 runtime = IN_PERL_RUNTIME;
2774 runcv = find_runcv(NULL);
2777 PL_op->op_type = OP_ENTEREVAL;
2778 PL_op->op_flags = 0; /* Avoid uninit warning. */
2779 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2780 PUSHEVAL(cx, 0, Nullgv);
2783 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2785 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2786 POPBLOCK(cx,PL_curpm);
2789 (*startop)->op_type = OP_NULL;
2790 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2792 /* XXX DAPM do this properly one year */
2793 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2795 if (IN_PERL_COMPILETIME)
2796 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2797 #ifdef OP_IN_REGISTER
2800 PERL_UNUSED_VAR(newsp);
2801 PERL_UNUSED_VAR(optype);
2808 =for apidoc find_runcv
2810 Locate the CV corresponding to the currently executing sub or eval.
2811 If db_seqp is non_null, skip CVs that are in the DB package and populate
2812 *db_seqp with the cop sequence number at the point that the DB:: code was
2813 entered. (allows debuggers to eval in the scope of the breakpoint rather
2814 than in the scope of the debugger itself).
2820 Perl_find_runcv(pTHX_ U32 *db_seqp)
2825 *db_seqp = PL_curcop->cop_seq;
2826 for (si = PL_curstackinfo; si; si = si->si_prev) {
2828 for (ix = si->si_cxix; ix >= 0; ix--) {
2829 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2830 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2831 CV * const cv = cx->blk_sub.cv;
2832 /* skip DB:: code */
2833 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2834 *db_seqp = cx->blk_oldcop->cop_seq;
2839 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2847 /* Compile a require/do, an eval '', or a /(?{...})/.
2848 * In the last case, startop is non-null, and contains the address of
2849 * a pointer that should be set to the just-compiled code.
2850 * outside is the lexically enclosing CV (if any) that invoked us.
2853 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2855 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2858 OP * const saveop = PL_op;
2860 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2861 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2866 SAVESPTR(PL_compcv);
2867 PL_compcv = (CV*)NEWSV(1104,0);
2868 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2869 CvEVAL_on(PL_compcv);
2870 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2871 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2873 CvOUTSIDE_SEQ(PL_compcv) = seq;
2874 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2876 /* set up a scratch pad */
2878 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2881 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2883 /* make sure we compile in the right package */
2885 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2886 SAVESPTR(PL_curstash);
2887 PL_curstash = CopSTASH(PL_curcop);
2889 SAVESPTR(PL_beginav);
2890 PL_beginav = newAV();
2891 SAVEFREESV(PL_beginav);
2892 SAVEI32(PL_error_count);
2894 /* try to compile it */
2896 PL_eval_root = Nullop;
2898 PL_curcop = &PL_compiling;
2899 PL_curcop->cop_arybase = 0;
2900 if (saveop && saveop->op_flags & OPf_SPECIAL)
2901 PL_in_eval |= EVAL_KEEPERR;
2903 sv_setpvn(ERRSV,"",0);
2904 if (yyparse() || PL_error_count || !PL_eval_root) {
2905 SV **newsp; /* Used by POPBLOCK. */
2906 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2907 I32 optype = 0; /* Might be reset by POPEVAL. */
2912 op_free(PL_eval_root);
2913 PL_eval_root = Nullop;
2915 SP = PL_stack_base + POPMARK; /* pop original mark */
2917 POPBLOCK(cx,PL_curpm);
2923 msg = SvPVx_nolen_const(ERRSV);
2924 if (optype == OP_REQUIRE) {
2925 const SV * const nsv = cx->blk_eval.old_namesv;
2926 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2928 DIE(aTHX_ "%sCompilation failed in require",
2929 *msg ? msg : "Unknown error\n");
2932 POPBLOCK(cx,PL_curpm);
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
2939 sv_setpv(ERRSV, "Compilation error");
2942 PERL_UNUSED_VAR(newsp);
2945 CopLINE_set(&PL_compiling, 0);
2947 *startop = PL_eval_root;
2949 SAVEFREEOP(PL_eval_root);
2951 /* Set the context for this new optree.
2952 * If the last op is an OP_REQUIRE, force scalar context.
2953 * Otherwise, propagate the context from the eval(). */
2954 if (PL_eval_root->op_type == OP_LEAVEEVAL
2955 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2956 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2958 scalar(PL_eval_root);
2959 else if (gimme & G_VOID)
2960 scalarvoid(PL_eval_root);
2961 else if (gimme & G_ARRAY)
2964 scalar(PL_eval_root);
2966 DEBUG_x(dump_eval());
2968 /* Register with debugger: */
2969 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2970 CV * const cv = get_cv("DB::postponed", FALSE);
2974 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2976 call_sv((SV*)cv, G_DISCARD);
2980 /* compiled okay, so do it */
2982 CvDEPTH(PL_compcv) = 1;
2983 SP = PL_stack_base + POPMARK; /* pop original mark */
2984 PL_op = saveop; /* The caller may need it. */
2985 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2987 RETURNOP(PL_eval_start);
2991 S_doopen_pm(pTHX_ const char *name, const char *mode)
2993 #ifndef PERL_DISABLE_PMC
2994 const STRLEN namelen = strlen(name);
2997 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2998 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2999 const char * const pmc = SvPV_nolen_const(pmcsv);
3001 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3002 fp = PerlIO_open(name, mode);
3006 if (PerlLIO_stat(name, &pmstat) < 0 ||
3007 pmstat.st_mtime < pmcstat.st_mtime)
3009 fp = PerlIO_open(pmc, mode);
3012 fp = PerlIO_open(name, mode);
3015 SvREFCNT_dec(pmcsv);
3018 fp = PerlIO_open(name, mode);
3022 return PerlIO_open(name, mode);
3023 #endif /* !PERL_DISABLE_PMC */
3029 register PERL_CONTEXT *cx;
3033 const char *tryname = Nullch;
3034 SV *namesv = Nullsv;
3035 const I32 gimme = GIMME_V;
3036 PerlIO *tryrsfp = 0;
3037 int filter_has_file = 0;
3038 GV *filter_child_proc = 0;
3039 SV *filter_state = 0;
3046 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3047 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3048 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3049 "v-string in use/require non-portable");
3051 sv = new_version(sv);
3052 if (!sv_derived_from(PL_patchlevel, "version"))
3053 (void *)upg_version(PL_patchlevel);
3054 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3055 if ( vcmp(sv,PL_patchlevel) < 0 )
3056 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3057 vnormal(sv), vnormal(PL_patchlevel));
3060 if ( vcmp(sv,PL_patchlevel) > 0 )
3061 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3062 vnormal(sv), vnormal(PL_patchlevel));
3067 name = SvPV_const(sv, len);
3068 if (!(name && len > 0 && *name))
3069 DIE(aTHX_ "Null filename used");
3070 TAINT_PROPER("require");
3071 if (PL_op->op_type == OP_REQUIRE) {
3072 SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3074 if (*svp != &PL_sv_undef)
3077 DIE(aTHX_ "Compilation failed in require");
3081 /* prepare to compile file */
3083 if (path_is_absolute(name)) {
3085 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3087 #ifdef MACOS_TRADITIONAL
3091 MacPerl_CanonDir(name, newname, 1);
3092 if (path_is_absolute(newname)) {
3094 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3099 AV * const ar = GvAVn(PL_incgv);
3103 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3106 namesv = NEWSV(806, 0);
3107 for (i = 0; i <= AvFILL(ar); i++) {
3108 SV *dirsv = *av_fetch(ar, i, TRUE);
3114 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3115 && !sv_isobject(loader))
3117 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3120 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3121 PTR2UV(SvRV(dirsv)), name);
3122 tryname = SvPVX_const(namesv);
3133 if (sv_isobject(loader))
3134 count = call_method("INC", G_ARRAY);
3136 count = call_sv(loader, G_ARRAY);
3146 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3150 if (SvTYPE(arg) == SVt_PVGV) {
3151 IO *io = GvIO((GV *)arg);
3156 tryrsfp = IoIFP(io);
3157 if (IoTYPE(io) == IoTYPE_PIPE) {
3158 /* reading from a child process doesn't
3159 nest -- when returning from reading
3160 the inner module, the outer one is
3161 unreadable (closed?) I've tried to
3162 save the gv to manage the lifespan of
3163 the pipe, but this didn't help. XXX */
3164 filter_child_proc = (GV *)arg;
3165 (void)SvREFCNT_inc(filter_child_proc);
3168 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3169 PerlIO_close(IoOFP(io));
3181 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3183 (void)SvREFCNT_inc(filter_sub);
3186 filter_state = SP[i];
3187 (void)SvREFCNT_inc(filter_state);
3191 tryrsfp = PerlIO_open("/dev/null",
3207 filter_has_file = 0;
3208 if (filter_child_proc) {
3209 SvREFCNT_dec(filter_child_proc);
3210 filter_child_proc = 0;
3213 SvREFCNT_dec(filter_state);
3217 SvREFCNT_dec(filter_sub);
3222 if (!path_is_absolute(name)
3223 #ifdef MACOS_TRADITIONAL
3224 /* We consider paths of the form :a:b ambiguous and interpret them first
3225 as global then as local
3227 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3230 const char *dir = SvPVx_nolen_const(dirsv);
3231 #ifdef MACOS_TRADITIONAL
3235 MacPerl_CanonDir(name, buf2, 1);
3236 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3240 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3242 sv_setpv(namesv, unixdir);
3243 sv_catpv(namesv, unixname);
3245 # ifdef __SYMBIAN32__
3246 if (PL_origfilename[0] &&
3247 PL_origfilename[1] == ':' &&
3248 !(dir[0] && dir[1] == ':'))
3249 Perl_sv_setpvf(aTHX_ namesv,
3254 Perl_sv_setpvf(aTHX_ namesv,
3258 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3262 TAINT_PROPER("require");
3263 tryname = SvPVX_const(namesv);
3264 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3266 if (tryname[0] == '.' && tryname[1] == '/')
3275 SAVECOPFILE_FREE(&PL_compiling);
3276 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3277 SvREFCNT_dec(namesv);
3279 if (PL_op->op_type == OP_REQUIRE) {
3280 const char *msgstr = name;
3281 if(errno == EMFILE) {
3282 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3283 sv_catpv(msg, ": ");
3284 sv_catpv(msg, Strerror(errno));
3285 msgstr = SvPV_nolen_const(msg);
3287 if (namesv) { /* did we lookup @INC? */
3288 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3289 SV * const dirmsgsv = NEWSV(0, 0);
3290 AV * const ar = GvAVn(PL_incgv);
3292 sv_catpvn(msg, " in @INC", 8);
3293 if (instr(SvPVX_const(msg), ".h "))
3294 sv_catpv(msg, " (change .h to .ph maybe?)");
3295 if (instr(SvPVX_const(msg), ".ph "))
3296 sv_catpv(msg, " (did you run h2ph?)");
3297 sv_catpv(msg, " (@INC contains:");
3298 for (i = 0; i <= AvFILL(ar); i++) {
3299 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3300 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3301 sv_catsv(msg, dirmsgsv);
3303 sv_catpvn(msg, ")", 1);
3304 SvREFCNT_dec(dirmsgsv);
3305 msgstr = SvPV_nolen_const(msg);
3308 DIE(aTHX_ "Can't locate %s", msgstr);
3314 SETERRNO(0, SS_NORMAL);
3316 /* Assume success here to prevent recursive requirement. */
3317 /* name is never assigned to again, so len is still strlen(name) */
3318 /* Check whether a hook in @INC has already filled %INC */
3320 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3322 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3324 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3329 lex_start(sv_2mortal(newSVpvn("",0)));
3330 SAVEGENERICSV(PL_rsfp_filters);
3331 PL_rsfp_filters = Nullav;
3336 SAVESPTR(PL_compiling.cop_warnings);
3337 if (PL_dowarn & G_WARN_ALL_ON)
3338 PL_compiling.cop_warnings = pWARN_ALL ;
3339 else if (PL_dowarn & G_WARN_ALL_OFF)
3340 PL_compiling.cop_warnings = pWARN_NONE ;
3341 else if (PL_taint_warn)
3342 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3344 PL_compiling.cop_warnings = pWARN_STD ;
3345 SAVESPTR(PL_compiling.cop_io);
3346 PL_compiling.cop_io = Nullsv;
3348 if (filter_sub || filter_child_proc) {
3349 SV * const datasv = filter_add(run_user_filter, Nullsv);
3350 IoLINES(datasv) = filter_has_file;
3351 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3352 IoTOP_GV(datasv) = (GV *)filter_state;
3353 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3356 /* switch to eval mode */
3357 PUSHBLOCK(cx, CXt_EVAL, SP);
3358 PUSHEVAL(cx, name, Nullgv);
3359 cx->blk_eval.retop = PL_op->op_next;
3361 SAVECOPLINE(&PL_compiling);
3362 CopLINE_set(&PL_compiling, 0);
3366 /* Store and reset encoding. */
3367 encoding = PL_encoding;
3368 PL_encoding = Nullsv;
3370 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3372 /* Restore encoding. */
3373 PL_encoding = encoding;
3381 register PERL_CONTEXT *cx;
3383 const I32 gimme = GIMME_V;
3384 const I32 was = PL_sub_generation;
3385 char tbuf[TYPE_DIGITS(long) + 12];
3386 char *tmpbuf = tbuf;
3393 if (!SvPV_nolen_const(sv))
3395 TAINT_PROPER("eval");
3401 /* switch to eval mode */
3403 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3404 SV * const sv = sv_newmortal();
3405 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3406 (unsigned long)++PL_evalseq,
3407 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3411 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3412 SAVECOPFILE_FREE(&PL_compiling);
3413 CopFILE_set(&PL_compiling, tmpbuf+2);
3414 SAVECOPLINE(&PL_compiling);
3415 CopLINE_set(&PL_compiling, 1);
3416 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3417 deleting the eval's FILEGV from the stash before gv_check() runs
3418 (i.e. before run-time proper). To work around the coredump that
3419 ensues, we always turn GvMULTI_on for any globals that were
3420 introduced within evals. See force_ident(). GSAR 96-10-12 */
3421 len = strlen(tmpbuf);
3422 safestr = savepvn(tmpbuf, len);
3423 SAVEDELETE(PL_defstash, safestr, len);
3425 PL_hints = PL_op->op_targ;
3426 SAVESPTR(PL_compiling.cop_warnings);
3427 if (specialWARN(PL_curcop->cop_warnings))
3428 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3430 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3431 SAVEFREESV(PL_compiling.cop_warnings);
3433 SAVESPTR(PL_compiling.cop_io);
3434 if (specialCopIO(PL_curcop->cop_io))
3435 PL_compiling.cop_io = PL_curcop->cop_io;
3437 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3438 SAVEFREESV(PL_compiling.cop_io);
3440 /* special case: an eval '' executed within the DB package gets lexically
3441 * placed in the first non-DB CV rather than the current CV - this
3442 * allows the debugger to execute code, find lexicals etc, in the
3443 * scope of the code being debugged. Passing &seq gets find_runcv
3444 * to do the dirty work for us */
3445 runcv = find_runcv(&seq);
3447 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3448 PUSHEVAL(cx, 0, Nullgv);
3449 cx->blk_eval.retop = PL_op->op_next;
3451 /* prepare to compile string */
3453 if (PERLDB_LINE && PL_curstash != PL_debstash)
3454 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3456 ret = doeval(gimme, NULL, runcv, seq);
3457 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3458 && ret != PL_op->op_next) { /* Successive compilation. */
3459 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3461 return DOCATCH(ret);
3471 register PERL_CONTEXT *cx;
3473 const U8 save_flags = PL_op -> op_flags;
3478 retop = cx->blk_eval.retop;
3481 if (gimme == G_VOID)
3483 else if (gimme == G_SCALAR) {
3486 if (SvFLAGS(TOPs) & SVs_TEMP)
3489 *MARK = sv_mortalcopy(TOPs);
3493 *MARK = &PL_sv_undef;
3498 /* in case LEAVE wipes old return values */
3499 for (mark = newsp + 1; mark <= SP; mark++) {
3500 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3501 *mark = sv_mortalcopy(*mark);
3502 TAINT_NOT; /* Each item is independent */
3506 PL_curpm = newpm; /* Don't pop $1 et al till now */
3509 assert(CvDEPTH(PL_compcv) == 1);
3511 CvDEPTH(PL_compcv) = 0;
3514 if (optype == OP_REQUIRE &&
3515 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3517 /* Unassume the success we assumed earlier. */
3518 SV * const nsv = cx->blk_eval.old_namesv;
3519 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3520 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3521 /* die_where() did LEAVE, or we won't be here */
3525 if (!(save_flags & OPf_SPECIAL))
3526 sv_setpvn(ERRSV,"",0);
3535 register PERL_CONTEXT *cx;
3536 const I32 gimme = GIMME_V;
3541 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3543 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3545 PL_in_eval = EVAL_INEVAL;
3546 sv_setpvn(ERRSV,"",0);
3548 return DOCATCH(PL_op->op_next);
3558 register PERL_CONTEXT *cx;
3563 PERL_UNUSED_VAR(optype);
3566 if (gimme == G_VOID)
3568 else if (gimme == G_SCALAR) {
3571 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3574 *MARK = sv_mortalcopy(TOPs);
3578 *MARK = &PL_sv_undef;
3583 /* in case LEAVE wipes old return values */
3584 for (mark = newsp + 1; mark <= SP; mark++) {
3585 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3586 *mark = sv_mortalcopy(*mark);
3587 TAINT_NOT; /* Each item is independent */
3591 PL_curpm = newpm; /* Don't pop $1 et al till now */
3594 sv_setpvn(ERRSV,"",0);
3599 S_doparseform(pTHX_ SV *sv)
3602 register char *s = SvPV_force(sv, len);
3603 register char *send = s + len;
3604 register char *base = Nullch;
3605 register I32 skipspaces = 0;
3606 bool noblank = FALSE;
3607 bool repeat = FALSE;
3608 bool postspace = FALSE;
3614 bool unchopnum = FALSE;
3615 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3618 Perl_croak(aTHX_ "Null picture in formline");
3620 /* estimate the buffer size needed */
3621 for (base = s; s <= send; s++) {
3622 if (*s == '\n' || *s == '@' || *s == '^')
3628 Newx(fops, maxops, U32);
3633 *fpc++ = FF_LINEMARK;
3634 noblank = repeat = FALSE;
3652 case ' ': case '\t':
3659 } /* else FALL THROUGH */
3667 *fpc++ = FF_LITERAL;
3675 *fpc++ = (U16)skipspaces;
3679 *fpc++ = FF_NEWLINE;
3683 arg = fpc - linepc + 1;
3690 *fpc++ = FF_LINEMARK;
3691 noblank = repeat = FALSE;
3700 ischop = s[-1] == '^';
3706 arg = (s - base) - 1;
3708 *fpc++ = FF_LITERAL;
3716 *fpc++ = 2; /* skip the @* or ^* */
3718 *fpc++ = FF_LINESNGL;
3721 *fpc++ = FF_LINEGLOB;
3723 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3724 arg = ischop ? 512 : 0;
3729 const char * const f = ++s;
3732 arg |= 256 + (s - f);
3734 *fpc++ = s - base; /* fieldsize for FETCH */
3735 *fpc++ = FF_DECIMAL;
3737 unchopnum |= ! ischop;
3739 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3740 arg = ischop ? 512 : 0;
3742 s++; /* skip the '0' first */
3746 const char * const f = ++s;
3749 arg |= 256 + (s - f);
3751 *fpc++ = s - base; /* fieldsize for FETCH */
3752 *fpc++ = FF_0DECIMAL;
3754 unchopnum |= ! ischop;
3758 bool ismore = FALSE;
3761 while (*++s == '>') ;
3762 prespace = FF_SPACE;
3764 else if (*s == '|') {
3765 while (*++s == '|') ;
3766 prespace = FF_HALFSPACE;
3771 while (*++s == '<') ;
3774 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3778 *fpc++ = s - base; /* fieldsize for FETCH */
3780 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3783 *fpc++ = (U16)prespace;
3797 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3799 { /* need to jump to the next word */
3801 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3802 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3803 s = SvPVX(sv) + SvCUR(sv) + z;
3805 Copy(fops, s, arg, U32);
3807 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3810 if (unchopnum && repeat)
3811 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3817 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3819 /* Can value be printed in fldsize chars, using %*.*f ? */
3823 int intsize = fldsize - (value < 0 ? 1 : 0);
3830 while (intsize--) pwr *= 10.0;
3831 while (frcsize--) eps /= 10.0;
3834 if (value + eps >= pwr)
3837 if (value - eps <= -pwr)
3844 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3847 SV *datasv = FILTER_DATA(idx);
3848 const int filter_has_file = IoLINES(datasv);
3849 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3850 SV *filter_state = (SV *)IoTOP_GV(datasv);
3851 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3854 /* I was having segfault trouble under Linux 2.2.5 after a
3855 parse error occured. (Had to hack around it with a test
3856 for PL_error_count == 0.) Solaris doesn't segfault --
3857 not sure where the trouble is yet. XXX */
3859 if (filter_has_file) {
3860 len = FILTER_READ(idx+1, buf_sv, maxlen);
3863 if (filter_sub && len >= 0) {
3874 PUSHs(sv_2mortal(newSViv(maxlen)));
3876 PUSHs(filter_state);
3879 count = call_sv(filter_sub, G_SCALAR);
3895 IoLINES(datasv) = 0;
3896 if (filter_child_proc) {
3897 SvREFCNT_dec(filter_child_proc);
3898 IoFMT_GV(datasv) = Nullgv;
3901 SvREFCNT_dec(filter_state);
3902 IoTOP_GV(datasv) = Nullgv;
3905 SvREFCNT_dec(filter_sub);
3906 IoBOTTOM_GV(datasv) = Nullgv;
3908 filter_del(run_user_filter);
3914 /* perhaps someone can come up with a better name for
3915 this? it is not really "absolute", per se ... */
3917 S_path_is_absolute(pTHX_ const char *name)
3919 if (PERL_FILE_IS_ABSOLUTE(name)
3920 #ifdef MACOS_TRADITIONAL
3923 || (*name == '.' && (name[1] == '/' ||
3924 (name[1] == '.' && name[2] == '/'))))
3935 * c-indentation-style: bsd
3937 * indent-tabs-mode: t
3940 * ex: set ts=8 sts=4 sw=4 noet: