3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
49 cxix = dopoptosub(cxstack_ix);
53 switch (cxstack[cxix].blk_gimme) {
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 MAGIC *mg = Null(MAGIC*);
86 /* prevent recompiling under /o and ithreads. */
87 #if defined(USE_ITHREADS)
88 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
89 if (PL_op->op_flags & OPf_STACKED) {
98 if (PL_op->op_flags & OPf_STACKED) {
99 /* multiple args; concatentate them */
101 tmpstr = PAD_SV(ARGTARG);
102 sv_setpvn(tmpstr, "", 0);
103 while (++MARK <= SP) {
104 if (PL_amagic_generation) {
106 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
107 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
109 sv_setsv(tmpstr, sv);
113 sv_catsv(tmpstr, *MARK);
122 SV *sv = SvRV(tmpstr);
124 mg = mg_find(sv, PERL_MAGIC_qr);
127 regexp *re = (regexp *)mg->mg_obj;
128 ReREFCNT_dec(PM_GETRE(pm));
129 PM_SETRE(pm, ReREFCNT_inc(re));
132 t = SvPV(tmpstr, len);
134 /* Check against the last compiled regexp. */
135 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
136 PM_GETRE(pm)->prelen != (I32)len ||
137 memNE(PM_GETRE(pm)->precomp, t, len))
140 ReREFCNT_dec(PM_GETRE(pm));
141 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
143 if (PL_op->op_flags & OPf_SPECIAL)
144 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
146 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
148 pm->op_pmdynflags |= PMdf_DYN_UTF8;
150 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
151 if (pm->op_pmdynflags & PMdf_UTF8)
152 t = (char*)bytes_to_utf8((U8*)t, &len);
154 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
155 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
157 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
158 inside tie/overload accessors. */
162 #ifndef INCOMPLETE_TAINTS
165 pm->op_pmdynflags |= PMdf_TAINTED;
167 pm->op_pmdynflags &= ~PMdf_TAINTED;
171 if (!PM_GETRE(pm)->prelen && PL_curpm)
173 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
174 pm->op_pmflags |= PMf_WHITE;
176 pm->op_pmflags &= ~PMf_WHITE;
178 /* XXX runtime compiled output needs to move to the pad */
179 if (pm->op_pmflags & PMf_KEEP) {
180 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
181 #if !defined(USE_ITHREADS)
182 /* XXX can't change the optree at runtime either */
183 cLOGOP->op_first->op_next = PL_op->op_next;
192 register PMOP *pm = (PMOP*) cLOGOP->op_other;
193 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
194 register SV *dstr = cx->sb_dstr;
195 register char *s = cx->sb_s;
196 register char *m = cx->sb_m;
197 char *orig = cx->sb_orig;
198 register REGEXP *rx = cx->sb_rx;
200 REGEXP *old = PM_GETRE(pm);
207 rxres_restore(&cx->sb_rxres, rx);
208 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
210 if (cx->sb_iters++) {
211 I32 saviters = cx->sb_iters;
212 if (cx->sb_iters > cx->sb_maxiters)
213 DIE(aTHX_ "Substitution loop");
215 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
216 cx->sb_rxtainted |= 2;
217 sv_catsv(dstr, POPs);
220 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
221 s == m, cx->sb_targ, NULL,
222 ((cx->sb_rflags & REXEC_COPY_STR)
223 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
224 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
226 SV *targ = cx->sb_targ;
228 assert(cx->sb_strend >= s);
229 if(cx->sb_strend > s) {
230 if (DO_UTF8(dstr) && !SvUTF8(targ))
231 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
233 sv_catpvn(dstr, s, cx->sb_strend - s);
235 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
237 #ifdef PERL_COPY_ON_WRITE
239 sv_force_normal_flags(targ, SV_COW_DROP_PV);
245 SvPV_set(targ, SvPVX(dstr));
246 SvCUR_set(targ, SvCUR(dstr));
247 SvLEN_set(targ, SvLEN(dstr));
250 SvPV_set(dstr, (char*)0);
253 TAINT_IF(cx->sb_rxtainted & 1);
254 PUSHs(sv_2mortal(newSViv(saviters - 1)));
256 (void)SvPOK_only_UTF8(targ);
257 TAINT_IF(cx->sb_rxtainted);
261 LEAVE_SCOPE(cx->sb_oldsave);
264 RETURNOP(pm->op_next);
266 cx->sb_iters = saviters;
268 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
271 cx->sb_orig = orig = rx->subbeg;
273 cx->sb_strend = s + (cx->sb_strend - m);
275 cx->sb_m = m = rx->startp[0] + orig;
277 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
278 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
280 sv_catpvn(dstr, s, m-s);
282 cx->sb_s = rx->endp[0] + orig;
283 { /* Update the pos() information. */
284 SV *sv = cx->sb_targ;
287 if (SvTYPE(sv) < SVt_PVMG)
288 (void)SvUPGRADE(sv, SVt_PVMG);
289 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
290 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
291 mg = mg_find(sv, PERL_MAGIC_regex_global);
300 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
301 rxres_save(&cx->sb_rxres, rx);
302 RETURNOP(pm->op_pmreplstart);
306 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
311 if (!p || p[1] < rx->nparens) {
312 #ifdef PERL_COPY_ON_WRITE
313 i = 7 + rx->nparens * 2;
315 i = 6 + rx->nparens * 2;
324 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
325 RX_MATCH_COPIED_off(rx);
327 #ifdef PERL_COPY_ON_WRITE
328 *p++ = PTR2UV(rx->saved_copy);
329 rx->saved_copy = Nullsv;
334 *p++ = PTR2UV(rx->subbeg);
335 *p++ = (UV)rx->sublen;
336 for (i = 0; i <= rx->nparens; ++i) {
337 *p++ = (UV)rx->startp[i];
338 *p++ = (UV)rx->endp[i];
343 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
348 RX_MATCH_COPY_FREE(rx);
349 RX_MATCH_COPIED_set(rx, *p);
352 #ifdef PERL_COPY_ON_WRITE
354 SvREFCNT_dec (rx->saved_copy);
355 rx->saved_copy = INT2PTR(SV*,*p);
361 rx->subbeg = INT2PTR(char*,*p++);
362 rx->sublen = (I32)(*p++);
363 for (i = 0; i <= rx->nparens; ++i) {
364 rx->startp[i] = (I32)(*p++);
365 rx->endp[i] = (I32)(*p++);
370 Perl_rxres_free(pTHX_ void **rsp)
375 Safefree(INT2PTR(char*,*p));
376 #ifdef PERL_COPY_ON_WRITE
378 SvREFCNT_dec (INT2PTR(SV*,p[1]));
388 dSP; dMARK; dORIGMARK;
389 register SV *tmpForm = *++MARK;
396 register SV *sv = Nullsv;
401 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
402 char *chophere = Nullch;
403 char *linemark = Nullch;
405 bool gotsome = FALSE;
407 STRLEN fudge = SvPOK(tmpForm)
408 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
409 bool item_is_utf8 = FALSE;
410 bool targ_is_utf8 = FALSE;
416 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
417 if (SvREADONLY(tmpForm)) {
418 SvREADONLY_off(tmpForm);
419 parseres = doparseform(tmpForm);
420 SvREADONLY_on(tmpForm);
423 parseres = doparseform(tmpForm);
427 SvPV_force(PL_formtarget, len);
428 if (DO_UTF8(PL_formtarget))
430 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
432 f = SvPV(tmpForm, len);
433 /* need to jump to the next word */
434 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
440 const char *name = "???";
443 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
444 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
445 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
446 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
447 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
449 case FF_CHECKNL: name = "CHECKNL"; break;
450 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
451 case FF_SPACE: name = "SPACE"; break;
452 case FF_HALFSPACE: name = "HALFSPACE"; break;
453 case FF_ITEM: name = "ITEM"; break;
454 case FF_CHOP: name = "CHOP"; break;
455 case FF_LINEGLOB: name = "LINEGLOB"; break;
456 case FF_NEWLINE: name = "NEWLINE"; break;
457 case FF_MORE: name = "MORE"; break;
458 case FF_LINEMARK: name = "LINEMARK"; break;
459 case FF_END: name = "END"; break;
460 case FF_0DECIMAL: name = "0DECIMAL"; break;
461 case FF_LINESNGL: name = "LINESNGL"; break;
464 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
466 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
477 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
478 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
480 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
481 t = SvEND(PL_formtarget);
484 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
485 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
487 sv_utf8_upgrade(PL_formtarget);
488 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
489 t = SvEND(PL_formtarget);
509 if (ckWARN(WARN_SYNTAX))
510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
515 item = s = SvPV(sv, len);
518 itemsize = sv_len_utf8(sv);
519 if (itemsize != (I32)len) {
521 if (itemsize > fieldsize) {
522 itemsize = fieldsize;
523 itembytes = itemsize;
524 sv_pos_u2b(sv, &itembytes, 0);
528 send = chophere = s + itembytes;
538 sv_pos_b2u(sv, &itemsize);
542 item_is_utf8 = FALSE;
543 if (itemsize > fieldsize)
544 itemsize = fieldsize;
545 send = chophere = s + itemsize;
557 item = s = SvPV(sv, len);
560 itemsize = sv_len_utf8(sv);
561 if (itemsize != (I32)len) {
563 if (itemsize <= fieldsize) {
564 send = chophere = s + itemsize;
576 itemsize = fieldsize;
577 itembytes = itemsize;
578 sv_pos_u2b(sv, &itembytes, 0);
579 send = chophere = s + itembytes;
580 while (s < send || (s == send && isSPACE(*s))) {
590 if (strchr(PL_chopset, *s))
595 itemsize = chophere - item;
596 sv_pos_b2u(sv, &itemsize);
602 item_is_utf8 = FALSE;
603 if (itemsize <= fieldsize) {
604 send = chophere = s + itemsize;
616 itemsize = fieldsize;
617 send = chophere = s + itemsize;
618 while (s < send || (s == send && isSPACE(*s))) {
628 if (strchr(PL_chopset, *s))
633 itemsize = chophere - item;
638 arg = fieldsize - itemsize;
647 arg = fieldsize - itemsize;
661 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
663 sv_utf8_upgrade(PL_formtarget);
664 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
665 t = SvEND(PL_formtarget);
669 if (UTF8_IS_CONTINUED(*s)) {
670 STRLEN skip = UTF8SKIP(s);
687 if ( !((*t++ = *s++) & ~31) )
693 if (targ_is_utf8 && !item_is_utf8) {
694 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
696 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
697 for (; t < SvEND(PL_formtarget); t++) {
710 int ch = *t++ = *s++;
713 if ( !((*t++ = *s++) & ~31) )
722 while (*s && isSPACE(*s))
736 item = s = SvPV(sv, len);
738 if ((item_is_utf8 = DO_UTF8(sv)))
739 itemsize = sv_len_utf8(sv);
741 bool chopped = FALSE;
744 chophere = s + itemsize;
760 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
762 SvUTF8_on(PL_formtarget);
764 SvCUR_set(sv, chophere - item);
765 sv_catsv(PL_formtarget, sv);
766 SvCUR_set(sv, itemsize);
768 sv_catsv(PL_formtarget, sv);
770 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
771 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
772 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
780 #if defined(USE_LONG_DOUBLE)
781 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
783 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
788 #if defined(USE_LONG_DOUBLE)
789 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
791 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
794 /* If the field is marked with ^ and the value is undefined,
796 if ((arg & 512) && !SvOK(sv)) {
804 /* overflow evidence */
805 if (num_overflow(value, fieldsize, arg)) {
811 /* Formats aren't yet marked for locales, so assume "yes". */
813 STORE_NUMERIC_STANDARD_SET_LOCAL();
814 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
815 RESTORE_NUMERIC_STANDARD();
822 while (t-- > linemark && *t == ' ') ;
830 if (arg) { /* repeat until fields exhausted? */
832 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
833 lines += FmLINES(PL_formtarget);
836 if (strnEQ(linemark, linemark - arg, arg))
837 DIE(aTHX_ "Runaway format");
840 SvUTF8_on(PL_formtarget);
841 FmLINES(PL_formtarget) = lines;
843 RETURNOP(cLISTOP->op_first);
856 while (*s && isSPACE(*s) && s < send)
860 arg = fieldsize - itemsize;
867 if (strnEQ(s," ",3)) {
868 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
879 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
881 SvUTF8_on(PL_formtarget);
882 FmLINES(PL_formtarget) += lines;
894 if (PL_stack_base + *PL_markstack_ptr == SP) {
896 if (GIMME_V == G_SCALAR)
897 XPUSHs(sv_2mortal(newSViv(0)));
898 RETURNOP(PL_op->op_next->op_next);
900 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
901 pp_pushmark(); /* push dst */
902 pp_pushmark(); /* push src */
903 ENTER; /* enter outer scope */
906 if (PL_op->op_private & OPpGREP_LEX)
907 SAVESPTR(PAD_SVl(PL_op->op_targ));
910 ENTER; /* enter inner scope */
913 src = PL_stack_base[*PL_markstack_ptr];
915 if (PL_op->op_private & OPpGREP_LEX)
916 PAD_SVl(PL_op->op_targ) = src;
921 if (PL_op->op_type == OP_MAPSTART)
922 pp_pushmark(); /* push top */
923 return ((LOGOP*)PL_op->op_next)->op_other;
928 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
935 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
941 /* first, move source pointer to the next item in the source list */
942 ++PL_markstack_ptr[-1];
944 /* if there are new items, push them into the destination list */
945 if (items && gimme != G_VOID) {
946 /* might need to make room back there first */
947 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
948 /* XXX this implementation is very pessimal because the stack
949 * is repeatedly extended for every set of items. Is possible
950 * to do this without any stack extension or copying at all
951 * by maintaining a separate list over which the map iterates
952 * (like foreach does). --gsar */
954 /* everything in the stack after the destination list moves
955 * towards the end the stack by the amount of room needed */
956 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
958 /* items to shift up (accounting for the moved source pointer) */
959 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
961 /* This optimization is by Ben Tilly and it does
962 * things differently from what Sarathy (gsar)
963 * is describing. The downside of this optimization is
964 * that leaves "holes" (uninitialized and hopefully unused areas)
965 * to the Perl stack, but on the other hand this
966 * shouldn't be a problem. If Sarathy's idea gets
967 * implemented, this optimization should become
968 * irrelevant. --jhi */
970 shift = count; /* Avoid shifting too often --Ben Tilly */
975 PL_markstack_ptr[-1] += shift;
976 *PL_markstack_ptr += shift;
980 /* copy the new items down to the destination list */
981 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
982 if (gimme == G_ARRAY) {
984 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
987 /* scalar context: we don't care about which values map returns
988 * (we use undef here). And so we certainly don't want to do mortal
989 * copies of meaningless values. */
990 while (items-- > 0) {
992 *dst-- = &PL_sv_undef;
996 LEAVE; /* exit inner scope */
999 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1001 (void)POPMARK; /* pop top */
1002 LEAVE; /* exit outer scope */
1003 (void)POPMARK; /* pop src */
1004 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1005 (void)POPMARK; /* pop dst */
1006 SP = PL_stack_base + POPMARK; /* pop original mark */
1007 if (gimme == G_SCALAR) {
1008 if (PL_op->op_private & OPpGREP_LEX) {
1009 SV* sv = sv_newmortal();
1010 sv_setiv(sv, items);
1018 else if (gimme == G_ARRAY)
1025 ENTER; /* enter inner scope */
1028 /* set $_ to the new source item */
1029 src = PL_stack_base[PL_markstack_ptr[-1]];
1031 if (PL_op->op_private & OPpGREP_LEX)
1032 PAD_SVl(PL_op->op_targ) = src;
1036 RETURNOP(cLOGOP->op_other);
1044 if (GIMME == G_ARRAY)
1046 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1047 return cLOGOP->op_other;
1056 if (GIMME == G_ARRAY) {
1057 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1061 SV *targ = PAD_SV(PL_op->op_targ);
1064 if (PL_op->op_private & OPpFLIP_LINENUM) {
1065 if (GvIO(PL_last_in_gv)) {
1066 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1069 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1070 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1076 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1077 if (PL_op->op_flags & OPf_SPECIAL) {
1085 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1094 /* This code tries to decide if "$left .. $right" should use the
1095 magical string increment, or if the range is numeric (we make
1096 an exception for .."0" [#18165]). AMS 20021031. */
1098 #define RANGE_IS_NUMERIC(left,right) ( \
1099 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1100 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1101 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1102 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1103 && (!SvOK(right) || looks_like_number(right))))
1109 if (GIMME == G_ARRAY) {
1115 if (SvGMAGICAL(left))
1117 if (SvGMAGICAL(right))
1120 if (RANGE_IS_NUMERIC(left,right)) {
1121 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1122 (SvOK(right) && SvNV(right) > IV_MAX))
1123 DIE(aTHX_ "Range iterator outside integer range");
1134 sv = sv_2mortal(newSViv(i++));
1139 SV *final = sv_mortalcopy(right);
1141 char *tmps = SvPV(final, len);
1143 sv = sv_mortalcopy(left);
1145 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1147 if (strEQ(SvPVX(sv),tmps))
1149 sv = sv_2mortal(newSVsv(sv));
1156 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1160 if (PL_op->op_private & OPpFLIP_LINENUM) {
1161 if (GvIO(PL_last_in_gv)) {
1162 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1165 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1166 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1174 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1175 sv_catpv(targ, "E0");
1185 static const char * const context_name[] = {
1196 S_dopoptolabel(pTHX_ const char *label)
1200 for (i = cxstack_ix; i >= 0; i--) {
1201 register const PERL_CONTEXT *cx = &cxstack[i];
1202 switch (CxTYPE(cx)) {
1208 if (ckWARN(WARN_EXITING))
1209 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1210 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1211 if (CxTYPE(cx) == CXt_NULL)
1215 if (!cx->blk_loop.label ||
1216 strNE(label, cx->blk_loop.label) ) {
1217 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1218 (long)i, cx->blk_loop.label));
1221 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1229 Perl_dowantarray(pTHX)
1231 I32 gimme = block_gimme();
1232 return (gimme == G_VOID) ? G_SCALAR : gimme;
1236 Perl_block_gimme(pTHX)
1238 const I32 cxix = dopoptosub(cxstack_ix);
1242 switch (cxstack[cxix].blk_gimme) {
1250 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1257 Perl_is_lvalue_sub(pTHX)
1259 const I32 cxix = dopoptosub(cxstack_ix);
1260 assert(cxix >= 0); /* We should only be called from inside subs */
1262 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1263 return cxstack[cxix].blk_sub.lval;
1269 S_dopoptosub(pTHX_ I32 startingblock)
1271 return dopoptosub_at(cxstack, startingblock);
1275 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1278 for (i = startingblock; i >= 0; i--) {
1279 register const PERL_CONTEXT *cx = &cxstk[i];
1280 switch (CxTYPE(cx)) {
1286 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1294 S_dopoptoeval(pTHX_ I32 startingblock)
1297 for (i = startingblock; i >= 0; i--) {
1298 register const PERL_CONTEXT *cx = &cxstack[i];
1299 switch (CxTYPE(cx)) {
1303 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1311 S_dopoptoloop(pTHX_ I32 startingblock)
1314 for (i = startingblock; i >= 0; i--) {
1315 register const PERL_CONTEXT *cx = &cxstack[i];
1316 switch (CxTYPE(cx)) {
1322 if (ckWARN(WARN_EXITING))
1323 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1324 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1325 if ((CxTYPE(cx)) == CXt_NULL)
1329 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1337 Perl_dounwind(pTHX_ I32 cxix)
1341 while (cxstack_ix > cxix) {
1343 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1344 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1345 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1346 /* Note: we don't need to restore the base context info till the end. */
1347 switch (CxTYPE(cx)) {
1350 continue; /* not break */
1372 Perl_qerror(pTHX_ SV *err)
1375 sv_catsv(ERRSV, err);
1377 sv_catsv(PL_errors, err);
1379 Perl_warn(aTHX_ "%"SVf, err);
1384 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1395 if (PL_in_eval & EVAL_KEEPERR) {
1396 static const char prefix[] = "\t(in cleanup) ";
1398 const char *e = Nullch;
1401 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1404 if (*e != *message || strNE(e,message))
1408 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1409 sv_catpvn(err, prefix, sizeof(prefix)-1);
1410 sv_catpvn(err, message, msglen);
1411 if (ckWARN(WARN_MISC)) {
1412 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1413 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1418 sv_setpvn(ERRSV, message, msglen);
1422 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1423 && PL_curstackinfo->si_prev)
1431 register PERL_CONTEXT *cx;
1433 if (cxix < cxstack_ix)
1436 POPBLOCK(cx,PL_curpm);
1437 if (CxTYPE(cx) != CXt_EVAL) {
1439 message = SvPVx(ERRSV, msglen);
1440 PerlIO_write(Perl_error_log, "panic: die ", 11);
1441 PerlIO_write(Perl_error_log, message, msglen);
1446 if (gimme == G_SCALAR)
1447 *++newsp = &PL_sv_undef;
1448 PL_stack_sp = newsp;
1452 /* LEAVE could clobber PL_curcop (see save_re_context())
1453 * XXX it might be better to find a way to avoid messing with
1454 * PL_curcop in save_re_context() instead, but this is a more
1455 * minimal fix --GSAR */
1456 PL_curcop = cx->blk_oldcop;
1458 if (optype == OP_REQUIRE) {
1459 const char* msg = SvPVx(ERRSV, n_a);
1460 SV *nsv = cx->blk_eval.old_namesv;
1461 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1463 DIE(aTHX_ "%sCompilation failed in require",
1464 *msg ? msg : "Unknown error\n");
1466 assert(CxTYPE(cx) == CXt_EVAL);
1467 return cx->blk_eval.retop;
1471 message = SvPVx(ERRSV, msglen);
1473 write_to_stderr(message, msglen);
1482 if (SvTRUE(left) != SvTRUE(right))
1494 RETURNOP(cLOGOP->op_other);
1503 RETURNOP(cLOGOP->op_other);
1512 if (!sv || !SvANY(sv)) {
1513 RETURNOP(cLOGOP->op_other);
1516 switch (SvTYPE(sv)) {
1518 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1522 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1526 if (CvROOT(sv) || CvXSUB(sv))
1536 RETURNOP(cLOGOP->op_other);
1542 register I32 cxix = dopoptosub(cxstack_ix);
1543 register PERL_CONTEXT *cx;
1544 register PERL_CONTEXT *ccstack = cxstack;
1545 PERL_SI *top_si = PL_curstackinfo;
1548 const char *stashname;
1556 /* we may be in a higher stacklevel, so dig down deeper */
1557 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1558 top_si = top_si->si_prev;
1559 ccstack = top_si->si_cxstack;
1560 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1563 if (GIMME != G_ARRAY) {
1569 /* caller() should not report the automatic calls to &DB::sub */
1570 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1571 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1575 cxix = dopoptosub_at(ccstack, cxix - 1);
1578 cx = &ccstack[cxix];
1579 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1580 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1581 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1582 field below is defined for any cx. */
1583 /* caller() should not report the automatic calls to &DB::sub */
1584 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1585 cx = &ccstack[dbcxix];
1588 stashname = CopSTASHPV(cx->blk_oldcop);
1589 if (GIMME != G_ARRAY) {
1592 PUSHs(&PL_sv_undef);
1595 sv_setpv(TARG, stashname);
1604 PUSHs(&PL_sv_undef);
1606 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1607 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1608 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1611 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1612 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1613 /* So is ccstack[dbcxix]. */
1616 gv_efullname3(sv, cvgv, Nullch);
1617 PUSHs(sv_2mortal(sv));
1618 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1621 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1622 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1626 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1627 PUSHs(sv_2mortal(newSViv(0)));
1629 gimme = (I32)cx->blk_gimme;
1630 if (gimme == G_VOID)
1631 PUSHs(&PL_sv_undef);
1633 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1634 if (CxTYPE(cx) == CXt_EVAL) {
1636 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1637 PUSHs(cx->blk_eval.cur_text);
1641 else if (cx->blk_eval.old_namesv) {
1642 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1645 /* eval BLOCK (try blocks have old_namesv == 0) */
1647 PUSHs(&PL_sv_undef);
1648 PUSHs(&PL_sv_undef);
1652 PUSHs(&PL_sv_undef);
1653 PUSHs(&PL_sv_undef);
1655 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1656 && CopSTASH_eq(PL_curcop, PL_debstash))
1658 AV *ary = cx->blk_sub.argarray;
1659 const int off = AvARRAY(ary) - AvALLOC(ary);
1663 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1666 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1669 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1670 av_extend(PL_dbargs, AvFILLp(ary) + off);
1671 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1672 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1674 /* XXX only hints propagated via op_private are currently
1675 * visible (others are not easily accessible, since they
1676 * use the global PL_hints) */
1677 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1678 HINT_PRIVATE_MASK)));
1681 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1683 if (old_warnings == pWARN_NONE ||
1684 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1685 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1686 else if (old_warnings == pWARN_ALL ||
1687 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1688 /* Get the bit mask for $warnings::Bits{all}, because
1689 * it could have been extended by warnings::register */
1691 HV *bits = get_hv("warnings::Bits", FALSE);
1692 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1693 mask = newSVsv(*bits_all);
1696 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1700 mask = newSVsv(old_warnings);
1701 PUSHs(sv_2mortal(mask));
1716 sv_reset(tmps, CopSTASH(PL_curcop));
1726 /* like pp_nextstate, but used instead when the debugger is active */
1731 PL_curcop = (COP*)PL_op;
1732 TAINT_NOT; /* Each statement is presumed innocent */
1733 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1736 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1737 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1741 register PERL_CONTEXT *cx;
1742 I32 gimme = G_ARRAY;
1749 DIE(aTHX_ "No DB::DB routine defined");
1751 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1752 /* don't do recursive DB::DB call */
1764 PUSHBLOCK(cx, CXt_SUB, SP);
1766 cx->blk_sub.retop = PL_op->op_next;
1768 PAD_SET_CUR(CvPADLIST(cv),1);
1769 RETURNOP(CvSTART(cv));
1783 register PERL_CONTEXT *cx;
1784 I32 gimme = GIMME_V;
1786 U32 cxtype = CXt_LOOP;
1794 if (PL_op->op_targ) {
1795 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1796 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1797 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1798 SVs_PADSTALE, SVs_PADSTALE);
1800 #ifndef USE_ITHREADS
1801 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1804 SAVEPADSV(PL_op->op_targ);
1805 iterdata = INT2PTR(void*, PL_op->op_targ);
1806 cxtype |= CXp_PADVAR;
1811 svp = &GvSV(gv); /* symbol table variable */
1812 SAVEGENERICSV(*svp);
1815 iterdata = (void*)gv;
1821 PUSHBLOCK(cx, cxtype, SP);
1823 PUSHLOOP(cx, iterdata, MARK);
1825 PUSHLOOP(cx, svp, MARK);
1827 if (PL_op->op_flags & OPf_STACKED) {
1828 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1829 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1831 SV *right = (SV*)cx->blk_loop.iterary;
1832 if (RANGE_IS_NUMERIC(sv,right)) {
1833 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1834 (SvOK(right) && SvNV(right) >= IV_MAX))
1835 DIE(aTHX_ "Range iterator outside integer range");
1836 cx->blk_loop.iterix = SvIV(sv);
1837 cx->blk_loop.itermax = SvIV(right);
1841 cx->blk_loop.iterlval = newSVsv(sv);
1842 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1843 (void) SvPV(right,n_a);
1846 else if (PL_op->op_private & OPpITER_REVERSED) {
1847 cx->blk_loop.itermax = -1;
1848 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1853 cx->blk_loop.iterary = PL_curstack;
1854 AvFILLp(PL_curstack) = SP - PL_stack_base;
1855 if (PL_op->op_private & OPpITER_REVERSED) {
1856 cx->blk_loop.itermax = MARK - PL_stack_base;
1857 cx->blk_loop.iterix = cx->blk_oldsp;
1860 cx->blk_loop.iterix = MARK - PL_stack_base;
1870 register PERL_CONTEXT *cx;
1871 I32 gimme = GIMME_V;
1877 PUSHBLOCK(cx, CXt_LOOP, SP);
1878 PUSHLOOP(cx, 0, SP);
1886 register PERL_CONTEXT *cx;
1893 assert(CxTYPE(cx) == CXt_LOOP);
1895 newsp = PL_stack_base + cx->blk_loop.resetsp;
1898 if (gimme == G_VOID)
1900 else if (gimme == G_SCALAR) {
1902 *++newsp = sv_mortalcopy(*SP);
1904 *++newsp = &PL_sv_undef;
1908 *++newsp = sv_mortalcopy(*++mark);
1909 TAINT_NOT; /* Each item is independent */
1915 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1916 PL_curpm = newpm; /* ... and pop $1 et al */
1928 register PERL_CONTEXT *cx;
1929 bool popsub2 = FALSE;
1930 bool clear_errsv = FALSE;
1938 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1939 if (cxstack_ix == PL_sortcxix
1940 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1942 if (cxstack_ix > PL_sortcxix)
1943 dounwind(PL_sortcxix);
1944 AvARRAY(PL_curstack)[1] = *SP;
1945 PL_stack_sp = PL_stack_base + 1;
1950 cxix = dopoptosub(cxstack_ix);
1952 DIE(aTHX_ "Can't return outside a subroutine");
1953 if (cxix < cxstack_ix)
1957 switch (CxTYPE(cx)) {
1960 retop = cx->blk_sub.retop;
1961 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1964 if (!(PL_in_eval & EVAL_KEEPERR))
1967 retop = cx->blk_eval.retop;
1971 if (optype == OP_REQUIRE &&
1972 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1974 /* Unassume the success we assumed earlier. */
1975 SV *nsv = cx->blk_eval.old_namesv;
1976 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1977 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1982 retop = cx->blk_sub.retop;
1985 DIE(aTHX_ "panic: return");
1989 if (gimme == G_SCALAR) {
1992 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1994 *++newsp = SvREFCNT_inc(*SP);
1999 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2001 *++newsp = sv_mortalcopy(sv);
2006 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2009 *++newsp = sv_mortalcopy(*SP);
2012 *++newsp = &PL_sv_undef;
2014 else if (gimme == G_ARRAY) {
2015 while (++MARK <= SP) {
2016 *++newsp = (popsub2 && SvTEMP(*MARK))
2017 ? *MARK : sv_mortalcopy(*MARK);
2018 TAINT_NOT; /* Each item is independent */
2021 PL_stack_sp = newsp;
2024 /* Stack values are safe: */
2027 POPSUB(cx,sv); /* release CV and @_ ... */
2031 PL_curpm = newpm; /* ... and pop $1 et al */
2043 register PERL_CONTEXT *cx;
2053 if (PL_op->op_flags & OPf_SPECIAL) {
2054 cxix = dopoptoloop(cxstack_ix);
2056 DIE(aTHX_ "Can't \"last\" outside a loop block");
2059 cxix = dopoptolabel(cPVOP->op_pv);
2061 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2063 if (cxix < cxstack_ix)
2067 cxstack_ix++; /* temporarily protect top context */
2069 switch (CxTYPE(cx)) {
2072 newsp = PL_stack_base + cx->blk_loop.resetsp;
2073 nextop = cx->blk_loop.last_op->op_next;
2077 nextop = cx->blk_sub.retop;
2081 nextop = cx->blk_eval.retop;
2085 nextop = cx->blk_sub.retop;
2088 DIE(aTHX_ "panic: last");
2092 if (gimme == G_SCALAR) {
2094 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2095 ? *SP : sv_mortalcopy(*SP);
2097 *++newsp = &PL_sv_undef;
2099 else if (gimme == G_ARRAY) {
2100 while (++MARK <= SP) {
2101 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2102 ? *MARK : sv_mortalcopy(*MARK);
2103 TAINT_NOT; /* Each item is independent */
2111 /* Stack values are safe: */
2114 POPLOOP(cx); /* release loop vars ... */
2118 POPSUB(cx,sv); /* release CV and @_ ... */
2121 PL_curpm = newpm; /* ... and pop $1 et al */
2131 register PERL_CONTEXT *cx;
2134 if (PL_op->op_flags & OPf_SPECIAL) {
2135 cxix = dopoptoloop(cxstack_ix);
2137 DIE(aTHX_ "Can't \"next\" outside a loop block");
2140 cxix = dopoptolabel(cPVOP->op_pv);
2142 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2144 if (cxix < cxstack_ix)
2147 /* clear off anything above the scope we're re-entering, but
2148 * save the rest until after a possible continue block */
2149 inner = PL_scopestack_ix;
2151 if (PL_scopestack_ix < inner)
2152 leave_scope(PL_scopestack[PL_scopestack_ix]);
2153 PL_curcop = cx->blk_oldcop;
2154 return cx->blk_loop.next_op;
2161 register PERL_CONTEXT *cx;
2165 if (PL_op->op_flags & OPf_SPECIAL) {
2166 cxix = dopoptoloop(cxstack_ix);
2168 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2171 cxix = dopoptolabel(cPVOP->op_pv);
2173 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2175 if (cxix < cxstack_ix)
2178 redo_op = cxstack[cxix].blk_loop.redo_op;
2179 if (redo_op->op_type == OP_ENTER) {
2180 /* pop one less context to avoid $x being freed in while (my $x..) */
2182 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2183 redo_op = redo_op->op_next;
2187 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2188 LEAVE_SCOPE(oldsave);
2190 PL_curcop = cx->blk_oldcop;
2195 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2199 static const char too_deep[] = "Target of goto is too deeply nested";
2202 Perl_croak(aTHX_ too_deep);
2203 if (o->op_type == OP_LEAVE ||
2204 o->op_type == OP_SCOPE ||
2205 o->op_type == OP_LEAVELOOP ||
2206 o->op_type == OP_LEAVESUB ||
2207 o->op_type == OP_LEAVETRY)
2209 *ops++ = cUNOPo->op_first;
2211 Perl_croak(aTHX_ too_deep);
2214 if (o->op_flags & OPf_KIDS) {
2215 /* First try all the kids at this level, since that's likeliest. */
2216 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2217 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2218 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2221 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2222 if (kid == PL_lastgotoprobe)
2224 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2227 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2228 ops[-1]->op_type == OP_DBSTATE)
2233 if ((o = dofindlabel(kid, label, ops, oplimit)))
2252 register PERL_CONTEXT *cx;
2253 #define GOTO_DEPTH 64
2254 OP *enterops[GOTO_DEPTH];
2255 const char *label = 0;
2256 const bool do_dump = (PL_op->op_type == OP_DUMP);
2257 static const char must_have_label[] = "goto must have label";
2259 if (PL_op->op_flags & OPf_STACKED) {
2263 /* This egregious kludge implements goto &subroutine */
2264 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2266 register PERL_CONTEXT *cx;
2267 CV* cv = (CV*)SvRV(sv);
2274 if (!CvROOT(cv) && !CvXSUB(cv)) {
2275 const GV * const gv = CvGV(cv);
2279 /* autoloaded stub? */
2280 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2282 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2283 GvNAMELEN(gv), FALSE);
2284 if (autogv && (cv = GvCV(autogv)))
2286 tmpstr = sv_newmortal();
2287 gv_efullname3(tmpstr, gv, Nullch);
2288 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2290 DIE(aTHX_ "Goto undefined subroutine");
2293 /* First do some returnish stuff. */
2294 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2296 cxix = dopoptosub(cxstack_ix);
2298 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2299 if (cxix < cxstack_ix)
2303 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2304 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2305 /* put @_ back onto stack */
2306 AV* av = cx->blk_sub.argarray;
2308 items = AvFILLp(av) + 1;
2309 EXTEND(SP, items+1); /* @_ could have been extended. */
2310 Copy(AvARRAY(av), SP + 1, items, SV*);
2311 SvREFCNT_dec(GvAV(PL_defgv));
2312 GvAV(PL_defgv) = cx->blk_sub.savearray;
2314 /* abandon @_ if it got reified */
2319 av_extend(av, items-1);
2320 AvFLAGS(av) = AVf_REIFY;
2321 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2324 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2326 av = GvAV(PL_defgv);
2327 items = AvFILLp(av) + 1;
2328 EXTEND(SP, items+1); /* @_ could have been extended. */
2329 Copy(AvARRAY(av), SP + 1, items, SV*);
2333 if (CxTYPE(cx) == CXt_SUB &&
2334 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2335 SvREFCNT_dec(cx->blk_sub.cv);
2336 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2337 LEAVE_SCOPE(oldsave);
2339 /* Now do some callish stuff. */
2341 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2345 for (index=0; index<items; index++)
2346 sv_2mortal(SP[-index]);
2348 #ifdef PERL_XSUB_OLDSTYLE
2349 if (CvOLDSTYLE(cv)) {
2350 I32 (*fp3)(int,int,int);
2355 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2356 items = (*fp3)(CvXSUBANY(cv).any_i32,
2357 mark - PL_stack_base + 1,
2359 SP = PL_stack_base + items;
2362 #endif /* PERL_XSUB_OLDSTYLE */
2367 /* Push a mark for the start of arglist */
2370 (void)(*CvXSUB(cv))(aTHX_ cv);
2371 /* Pop the current context like a decent sub should */
2372 POPBLOCK(cx, PL_curpm);
2373 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2376 assert(CxTYPE(cx) == CXt_SUB);
2377 return cx->blk_sub.retop;
2380 AV* padlist = CvPADLIST(cv);
2381 if (CxTYPE(cx) == CXt_EVAL) {
2382 PL_in_eval = cx->blk_eval.old_in_eval;
2383 PL_eval_root = cx->blk_eval.old_eval_root;
2384 cx->cx_type = CXt_SUB;
2385 cx->blk_sub.hasargs = 0;
2387 cx->blk_sub.cv = cv;
2388 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2391 if (CvDEPTH(cv) < 2)
2392 (void)SvREFCNT_inc(cv);
2394 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2395 sub_crush_depth(cv);
2396 pad_push(padlist, CvDEPTH(cv));
2398 PAD_SET_CUR(padlist, CvDEPTH(cv));
2399 if (cx->blk_sub.hasargs)
2401 AV* av = (AV*)PAD_SVl(0);
2404 cx->blk_sub.savearray = GvAV(PL_defgv);
2405 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2406 CX_CURPAD_SAVE(cx->blk_sub);
2407 cx->blk_sub.argarray = av;
2409 if (items >= AvMAX(av) + 1) {
2411 if (AvARRAY(av) != ary) {
2412 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2413 SvPV_set(av, (char*)ary);
2415 if (items >= AvMAX(av) + 1) {
2416 AvMAX(av) = items - 1;
2417 Renew(ary,items+1,SV*);
2419 SvPV_set(av, (char*)ary);
2423 Copy(mark,AvARRAY(av),items,SV*);
2424 AvFILLp(av) = items - 1;
2425 assert(!AvREAL(av));
2427 /* transfer 'ownership' of refcnts to new @_ */
2437 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2439 * We do not care about using sv to call CV;
2440 * it's for informational purposes only.
2442 SV *sv = GvSV(PL_DBsub);
2446 if (PERLDB_SUB_NN) {
2447 int type = SvTYPE(sv);
2448 if (type < SVt_PVIV && type != SVt_IV)
2449 sv_upgrade(sv, SVt_PVIV);
2451 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2453 gv_efullname3(sv, CvGV(cv), Nullch);
2456 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2457 PUSHMARK( PL_stack_sp );
2458 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2462 RETURNOP(CvSTART(cv));
2466 label = SvPV(sv,n_a);
2467 if (!(do_dump || *label))
2468 DIE(aTHX_ must_have_label);
2471 else if (PL_op->op_flags & OPf_SPECIAL) {
2473 DIE(aTHX_ must_have_label);
2476 label = cPVOP->op_pv;
2478 if (label && *label) {
2480 bool leaving_eval = FALSE;
2481 bool in_block = FALSE;
2482 PERL_CONTEXT *last_eval_cx = 0;
2486 PL_lastgotoprobe = 0;
2488 for (ix = cxstack_ix; ix >= 0; ix--) {
2490 switch (CxTYPE(cx)) {
2492 leaving_eval = TRUE;
2493 if (!CxTRYBLOCK(cx)) {
2494 gotoprobe = (last_eval_cx ?
2495 last_eval_cx->blk_eval.old_eval_root :
2500 /* else fall through */
2502 gotoprobe = cx->blk_oldcop->op_sibling;
2508 gotoprobe = cx->blk_oldcop->op_sibling;
2511 gotoprobe = PL_main_root;
2514 if (CvDEPTH(cx->blk_sub.cv)) {
2515 gotoprobe = CvROOT(cx->blk_sub.cv);
2521 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2524 DIE(aTHX_ "panic: goto");
2525 gotoprobe = PL_main_root;
2529 retop = dofindlabel(gotoprobe, label,
2530 enterops, enterops + GOTO_DEPTH);
2534 PL_lastgotoprobe = gotoprobe;
2537 DIE(aTHX_ "Can't find label %s", label);
2539 /* if we're leaving an eval, check before we pop any frames
2540 that we're not going to punt, otherwise the error
2543 if (leaving_eval && *enterops && enterops[1]) {
2545 for (i = 1; enterops[i]; i++)
2546 if (enterops[i]->op_type == OP_ENTERITER)
2547 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2550 /* pop unwanted frames */
2552 if (ix < cxstack_ix) {
2559 oldsave = PL_scopestack[PL_scopestack_ix];
2560 LEAVE_SCOPE(oldsave);
2563 /* push wanted frames */
2565 if (*enterops && enterops[1]) {
2567 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2568 for (; enterops[ix]; ix++) {
2569 PL_op = enterops[ix];
2570 /* Eventually we may want to stack the needed arguments
2571 * for each op. For now, we punt on the hard ones. */
2572 if (PL_op->op_type == OP_ENTERITER)
2573 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2574 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2582 if (!retop) retop = PL_main_start;
2584 PL_restartop = retop;
2585 PL_do_undump = TRUE;
2589 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2590 PL_do_undump = FALSE;
2606 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2608 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2611 PL_exit_flags |= PERL_EXIT_EXPECTED;
2613 PUSHs(&PL_sv_undef);
2621 NV value = SvNVx(GvSV(cCOP->cop_gv));
2622 register I32 match = I_32(value);
2625 if (((NV)match) > value)
2626 --match; /* was fractional--truncate other way */
2628 match -= cCOP->uop.scop.scop_offset;
2631 else if (match > cCOP->uop.scop.scop_max)
2632 match = cCOP->uop.scop.scop_max;
2633 PL_op = cCOP->uop.scop.scop_next[match];
2643 PL_op = PL_op->op_next; /* can't assume anything */
2646 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2647 match -= cCOP->uop.scop.scop_offset;
2650 else if (match > cCOP->uop.scop.scop_max)
2651 match = cCOP->uop.scop.scop_max;
2652 PL_op = cCOP->uop.scop.scop_next[match];
2661 S_save_lines(pTHX_ AV *array, SV *sv)
2663 register const char *s = SvPVX(sv);
2664 register const char *send = SvPVX(sv) + SvCUR(sv);
2665 register const char *t;
2666 register I32 line = 1;
2668 while (s && s < send) {
2669 SV *tmpstr = NEWSV(85,0);
2671 sv_upgrade(tmpstr, SVt_PVMG);
2672 t = strchr(s, '\n');
2678 sv_setpvn(tmpstr, s, t - s);
2679 av_store(array, line++, tmpstr);
2685 S_docatch_body(pTHX)
2692 S_docatch(pTHX_ OP *o)
2695 OP * const oldop = PL_op;
2699 assert(CATCH_GET == TRUE);
2706 assert(cxstack_ix >= 0);
2707 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2708 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2713 /* die caught by an inner eval - continue inner loop */
2715 /* NB XXX we rely on the old popped CxEVAL still being at the top
2716 * of the stack; the way die_where() currently works, this
2717 * assumption is valid. In theory The cur_top_env value should be
2718 * returned in another global, the way retop (aka PL_restartop)
2720 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2723 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2725 PL_op = PL_restartop;
2742 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2743 /* sv Text to convert to OP tree. */
2744 /* startop op_free() this to undo. */
2745 /* code Short string id of the caller. */
2747 dVAR; dSP; /* Make POPBLOCK work. */
2750 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2754 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2755 char *tmpbuf = tbuf;
2758 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2763 /* switch to eval mode */
2765 if (IN_PERL_COMPILETIME) {
2766 SAVECOPSTASH_FREE(&PL_compiling);
2767 CopSTASH_set(&PL_compiling, PL_curstash);
2769 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2770 SV *sv = sv_newmortal();
2771 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2772 code, (unsigned long)++PL_evalseq,
2773 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2777 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2778 SAVECOPFILE_FREE(&PL_compiling);
2779 CopFILE_set(&PL_compiling, tmpbuf+2);
2780 SAVECOPLINE(&PL_compiling);
2781 CopLINE_set(&PL_compiling, 1);
2782 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2783 deleting the eval's FILEGV from the stash before gv_check() runs
2784 (i.e. before run-time proper). To work around the coredump that
2785 ensues, we always turn GvMULTI_on for any globals that were
2786 introduced within evals. See force_ident(). GSAR 96-10-12 */
2787 safestr = savepv(tmpbuf);
2788 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2790 #ifdef OP_IN_REGISTER
2796 /* we get here either during compilation, or via pp_regcomp at runtime */
2797 runtime = IN_PERL_RUNTIME;
2799 runcv = find_runcv(NULL);
2802 PL_op->op_type = OP_ENTEREVAL;
2803 PL_op->op_flags = 0; /* Avoid uninit warning. */
2804 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2805 PUSHEVAL(cx, 0, Nullgv);
2808 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2810 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2811 POPBLOCK(cx,PL_curpm);
2814 (*startop)->op_type = OP_NULL;
2815 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2817 /* XXX DAPM do this properly one year */
2818 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2820 if (IN_PERL_COMPILETIME)
2821 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2822 #ifdef OP_IN_REGISTER
2830 =for apidoc find_runcv
2832 Locate the CV corresponding to the currently executing sub or eval.
2833 If db_seqp is non_null, skip CVs that are in the DB package and populate
2834 *db_seqp with the cop sequence number at the point that the DB:: code was
2835 entered. (allows debuggers to eval in the scope of the breakpoint rather
2836 than in in the scope of the debugger itself).
2842 Perl_find_runcv(pTHX_ U32 *db_seqp)
2847 *db_seqp = PL_curcop->cop_seq;
2848 for (si = PL_curstackinfo; si; si = si->si_prev) {
2850 for (ix = si->si_cxix; ix >= 0; ix--) {
2851 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2852 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2853 CV *cv = cx->blk_sub.cv;
2854 /* skip DB:: code */
2855 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2856 *db_seqp = cx->blk_oldcop->cop_seq;
2861 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2869 /* Compile a require/do, an eval '', or a /(?{...})/.
2870 * In the last case, startop is non-null, and contains the address of
2871 * a pointer that should be set to the just-compiled code.
2872 * outside is the lexically enclosing CV (if any) that invoked us.
2875 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2877 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2882 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2883 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2888 SAVESPTR(PL_compcv);
2889 PL_compcv = (CV*)NEWSV(1104,0);
2890 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2891 CvEVAL_on(PL_compcv);
2892 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2893 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2895 CvOUTSIDE_SEQ(PL_compcv) = seq;
2896 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2898 /* set up a scratch pad */
2900 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2903 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2905 /* make sure we compile in the right package */
2907 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2908 SAVESPTR(PL_curstash);
2909 PL_curstash = CopSTASH(PL_curcop);
2911 SAVESPTR(PL_beginav);
2912 PL_beginav = newAV();
2913 SAVEFREESV(PL_beginav);
2914 SAVEI32(PL_error_count);
2916 /* try to compile it */
2918 PL_eval_root = Nullop;
2920 PL_curcop = &PL_compiling;
2921 PL_curcop->cop_arybase = 0;
2922 if (saveop && saveop->op_flags & OPf_SPECIAL)
2923 PL_in_eval |= EVAL_KEEPERR;
2926 if (yyparse() || PL_error_count || !PL_eval_root) {
2927 SV **newsp; /* Used by POPBLOCK. */
2928 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2929 I32 optype = 0; /* Might be reset by POPEVAL. */
2934 op_free(PL_eval_root);
2935 PL_eval_root = Nullop;
2937 SP = PL_stack_base + POPMARK; /* pop original mark */
2939 POPBLOCK(cx,PL_curpm);
2944 if (optype == OP_REQUIRE) {
2945 const char* msg = SvPVx(ERRSV, n_a);
2946 SV *nsv = cx->blk_eval.old_namesv;
2947 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2949 DIE(aTHX_ "%sCompilation failed in require",
2950 *msg ? msg : "Unknown error\n");
2953 const char* msg = SvPVx(ERRSV, n_a);
2955 POPBLOCK(cx,PL_curpm);
2957 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2958 (*msg ? msg : "Unknown error\n"));
2961 const char* msg = SvPVx(ERRSV, n_a);
2963 sv_setpv(ERRSV, "Compilation error");
2968 CopLINE_set(&PL_compiling, 0);
2970 *startop = PL_eval_root;
2972 SAVEFREEOP(PL_eval_root);
2974 /* Set the context for this new optree.
2975 * If the last op is an OP_REQUIRE, force scalar context.
2976 * Otherwise, propagate the context from the eval(). */
2977 if (PL_eval_root->op_type == OP_LEAVEEVAL
2978 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2979 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2981 scalar(PL_eval_root);
2982 else if (gimme & G_VOID)
2983 scalarvoid(PL_eval_root);
2984 else if (gimme & G_ARRAY)
2987 scalar(PL_eval_root);
2989 DEBUG_x(dump_eval());
2991 /* Register with debugger: */
2992 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2993 CV *cv = get_cv("DB::postponed", FALSE);
2997 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2999 call_sv((SV*)cv, G_DISCARD);
3003 /* compiled okay, so do it */
3005 CvDEPTH(PL_compcv) = 1;
3006 SP = PL_stack_base + POPMARK; /* pop original mark */
3007 PL_op = saveop; /* The caller may need it. */
3008 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3010 RETURNOP(PL_eval_start);
3014 S_doopen_pm(pTHX_ const char *name, const char *mode)
3016 #ifndef PERL_DISABLE_PMC
3017 STRLEN namelen = strlen(name);
3020 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3021 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3022 const char * const pmc = SvPV_nolen(pmcsv);
3025 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3026 fp = PerlIO_open(name, mode);
3029 if (PerlLIO_stat(name, &pmstat) < 0 ||
3030 pmstat.st_mtime < pmcstat.st_mtime)
3032 fp = PerlIO_open(pmc, mode);
3035 fp = PerlIO_open(name, mode);
3038 SvREFCNT_dec(pmcsv);
3041 fp = PerlIO_open(name, mode);
3045 return PerlIO_open(name, mode);
3046 #endif /* !PERL_DISABLE_PMC */
3052 register PERL_CONTEXT *cx;
3056 char *tryname = Nullch;
3057 SV *namesv = Nullsv;
3059 I32 gimme = GIMME_V;
3060 PerlIO *tryrsfp = 0;
3062 int filter_has_file = 0;
3063 GV *filter_child_proc = 0;
3064 SV *filter_state = 0;
3071 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3072 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3073 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3074 "v-string in use/require non-portable");
3076 sv = new_version(sv);
3077 if (!sv_derived_from(PL_patchlevel, "version"))
3078 (void *)upg_version(PL_patchlevel);
3079 if ( vcmp(sv,PL_patchlevel) > 0 )
3080 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3081 vstringify(sv), vstringify(PL_patchlevel));
3085 name = SvPV(sv, len);
3086 if (!(name && len > 0 && *name))
3087 DIE(aTHX_ "Null filename used");
3088 TAINT_PROPER("require");
3089 if (PL_op->op_type == OP_REQUIRE &&
3090 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3091 if (*svp != &PL_sv_undef)
3094 DIE(aTHX_ "Compilation failed in require");
3097 /* prepare to compile file */
3099 if (path_is_absolute(name)) {
3101 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3103 #ifdef MACOS_TRADITIONAL
3107 MacPerl_CanonDir(name, newname, 1);
3108 if (path_is_absolute(newname)) {
3110 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3115 AV *ar = GvAVn(PL_incgv);
3119 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3122 namesv = NEWSV(806, 0);
3123 for (i = 0; i <= AvFILL(ar); i++) {
3124 SV *dirsv = *av_fetch(ar, i, TRUE);
3130 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3131 && !sv_isobject(loader))
3133 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3136 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3137 PTR2UV(SvRV(dirsv)), name);
3138 tryname = SvPVX(namesv);
3149 if (sv_isobject(loader))
3150 count = call_method("INC", G_ARRAY);
3152 count = call_sv(loader, G_ARRAY);
3162 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3166 if (SvTYPE(arg) == SVt_PVGV) {
3167 IO *io = GvIO((GV *)arg);
3172 tryrsfp = IoIFP(io);
3173 if (IoTYPE(io) == IoTYPE_PIPE) {
3174 /* reading from a child process doesn't
3175 nest -- when returning from reading
3176 the inner module, the outer one is
3177 unreadable (closed?) I've tried to
3178 save the gv to manage the lifespan of
3179 the pipe, but this didn't help. XXX */
3180 filter_child_proc = (GV *)arg;
3181 (void)SvREFCNT_inc(filter_child_proc);
3184 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3185 PerlIO_close(IoOFP(io));
3197 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3199 (void)SvREFCNT_inc(filter_sub);
3202 filter_state = SP[i];
3203 (void)SvREFCNT_inc(filter_state);
3207 tryrsfp = PerlIO_open("/dev/null",
3223 filter_has_file = 0;
3224 if (filter_child_proc) {
3225 SvREFCNT_dec(filter_child_proc);
3226 filter_child_proc = 0;
3229 SvREFCNT_dec(filter_state);
3233 SvREFCNT_dec(filter_sub);
3238 if (!path_is_absolute(name)
3239 #ifdef MACOS_TRADITIONAL
3240 /* We consider paths of the form :a:b ambiguous and interpret them first
3241 as global then as local
3243 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3246 char *dir = SvPVx(dirsv, n_a);
3247 #ifdef MACOS_TRADITIONAL
3251 MacPerl_CanonDir(name, buf2, 1);
3252 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3256 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3258 sv_setpv(namesv, unixdir);
3259 sv_catpv(namesv, unixname);
3262 if (PL_origfilename[0] &&
3263 PL_origfilename[1] == ':' &&
3264 !(dir[0] && dir[1] == ':'))
3265 Perl_sv_setpvf(aTHX_ namesv,
3270 Perl_sv_setpvf(aTHX_ namesv,
3274 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3278 TAINT_PROPER("require");
3279 tryname = SvPVX(namesv);
3280 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3282 if (tryname[0] == '.' && tryname[1] == '/')
3291 SAVECOPFILE_FREE(&PL_compiling);
3292 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3293 SvREFCNT_dec(namesv);
3295 if (PL_op->op_type == OP_REQUIRE) {
3296 char *msgstr = name;
3297 if (namesv) { /* did we lookup @INC? */
3298 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3299 SV *dirmsgsv = NEWSV(0, 0);
3300 AV *ar = GvAVn(PL_incgv);
3302 sv_catpvn(msg, " in @INC", 8);
3303 if (instr(SvPVX(msg), ".h "))
3304 sv_catpv(msg, " (change .h to .ph maybe?)");
3305 if (instr(SvPVX(msg), ".ph "))
3306 sv_catpv(msg, " (did you run h2ph?)");
3307 sv_catpv(msg, " (@INC contains:");
3308 for (i = 0; i <= AvFILL(ar); i++) {
3309 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3310 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3311 sv_catsv(msg, dirmsgsv);
3313 sv_catpvn(msg, ")", 1);
3314 SvREFCNT_dec(dirmsgsv);
3315 msgstr = SvPV_nolen(msg);
3317 DIE(aTHX_ "Can't locate %s", msgstr);
3323 SETERRNO(0, SS_NORMAL);
3325 /* Assume success here to prevent recursive requirement. */
3327 /* Check whether a hook in @INC has already filled %INC */
3328 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3329 (void)hv_store(GvHVn(PL_incgv), name, len,
3330 (hook_sv ? SvREFCNT_inc(hook_sv)
3331 : newSVpv(CopFILE(&PL_compiling), 0)),
3337 lex_start(sv_2mortal(newSVpvn("",0)));
3338 SAVEGENERICSV(PL_rsfp_filters);
3339 PL_rsfp_filters = Nullav;
3344 SAVESPTR(PL_compiling.cop_warnings);
3345 if (PL_dowarn & G_WARN_ALL_ON)
3346 PL_compiling.cop_warnings = pWARN_ALL ;
3347 else if (PL_dowarn & G_WARN_ALL_OFF)
3348 PL_compiling.cop_warnings = pWARN_NONE ;
3349 else if (PL_taint_warn)
3350 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3352 PL_compiling.cop_warnings = pWARN_STD ;
3353 SAVESPTR(PL_compiling.cop_io);
3354 PL_compiling.cop_io = Nullsv;
3356 if (filter_sub || filter_child_proc) {
3357 SV *datasv = filter_add(run_user_filter, Nullsv);
3358 IoLINES(datasv) = filter_has_file;
3359 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3360 IoTOP_GV(datasv) = (GV *)filter_state;
3361 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3364 /* switch to eval mode */
3365 PUSHBLOCK(cx, CXt_EVAL, SP);
3366 PUSHEVAL(cx, name, Nullgv);
3367 cx->blk_eval.retop = PL_op->op_next;
3369 SAVECOPLINE(&PL_compiling);
3370 CopLINE_set(&PL_compiling, 0);
3374 /* Store and reset encoding. */
3375 encoding = PL_encoding;
3376 PL_encoding = Nullsv;
3378 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3380 /* Restore encoding. */
3381 PL_encoding = encoding;
3388 return pp_require();
3394 register PERL_CONTEXT *cx;
3396 I32 gimme = GIMME_V, was = PL_sub_generation;
3397 char tbuf[TYPE_DIGITS(long) + 12];
3398 char *tmpbuf = tbuf;
3407 TAINT_PROPER("eval");
3413 /* switch to eval mode */
3415 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3416 SV *sv = sv_newmortal();
3417 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3418 (unsigned long)++PL_evalseq,
3419 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3423 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3424 SAVECOPFILE_FREE(&PL_compiling);
3425 CopFILE_set(&PL_compiling, tmpbuf+2);
3426 SAVECOPLINE(&PL_compiling);
3427 CopLINE_set(&PL_compiling, 1);
3428 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3429 deleting the eval's FILEGV from the stash before gv_check() runs
3430 (i.e. before run-time proper). To work around the coredump that
3431 ensues, we always turn GvMULTI_on for any globals that were
3432 introduced within evals. See force_ident(). GSAR 96-10-12 */
3433 safestr = savepv(tmpbuf);
3434 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3436 PL_hints = PL_op->op_targ;
3437 SAVESPTR(PL_compiling.cop_warnings);
3438 if (specialWARN(PL_curcop->cop_warnings))
3439 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3441 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3442 SAVEFREESV(PL_compiling.cop_warnings);
3444 SAVESPTR(PL_compiling.cop_io);
3445 if (specialCopIO(PL_curcop->cop_io))
3446 PL_compiling.cop_io = PL_curcop->cop_io;
3448 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3449 SAVEFREESV(PL_compiling.cop_io);
3451 /* special case: an eval '' executed within the DB package gets lexically
3452 * placed in the first non-DB CV rather than the current CV - this
3453 * allows the debugger to execute code, find lexicals etc, in the
3454 * scope of the code being debugged. Passing &seq gets find_runcv
3455 * to do the dirty work for us */
3456 runcv = find_runcv(&seq);
3458 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3459 PUSHEVAL(cx, 0, Nullgv);
3460 cx->blk_eval.retop = PL_op->op_next;
3462 /* prepare to compile string */
3464 if (PERLDB_LINE && PL_curstash != PL_debstash)
3465 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3467 ret = doeval(gimme, NULL, runcv, seq);
3468 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3469 && ret != PL_op->op_next) { /* Successive compilation. */
3470 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3472 return DOCATCH(ret);
3482 register PERL_CONTEXT *cx;
3484 const U8 save_flags = PL_op -> op_flags;
3489 retop = cx->blk_eval.retop;
3492 if (gimme == G_VOID)
3494 else if (gimme == G_SCALAR) {
3497 if (SvFLAGS(TOPs) & SVs_TEMP)
3500 *MARK = sv_mortalcopy(TOPs);
3504 *MARK = &PL_sv_undef;
3509 /* in case LEAVE wipes old return values */
3510 for (mark = newsp + 1; mark <= SP; mark++) {
3511 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3512 *mark = sv_mortalcopy(*mark);
3513 TAINT_NOT; /* Each item is independent */
3517 PL_curpm = newpm; /* Don't pop $1 et al till now */
3520 assert(CvDEPTH(PL_compcv) == 1);
3522 CvDEPTH(PL_compcv) = 0;
3525 if (optype == OP_REQUIRE &&
3526 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3528 /* Unassume the success we assumed earlier. */
3529 SV *nsv = cx->blk_eval.old_namesv;
3530 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3531 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3532 /* die_where() did LEAVE, or we won't be here */
3536 if (!(save_flags & OPf_SPECIAL))
3546 register PERL_CONTEXT *cx;
3547 I32 gimme = GIMME_V;
3552 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3554 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3556 PL_in_eval = EVAL_INEVAL;
3559 return DOCATCH(PL_op->op_next);
3569 register PERL_CONTEXT *cx;
3576 if (gimme == G_VOID)
3578 else if (gimme == G_SCALAR) {
3581 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3584 *MARK = sv_mortalcopy(TOPs);
3588 *MARK = &PL_sv_undef;
3593 /* in case LEAVE wipes old return values */
3594 for (mark = newsp + 1; mark <= SP; mark++) {
3595 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3596 *mark = sv_mortalcopy(*mark);
3597 TAINT_NOT; /* Each item is independent */
3601 PL_curpm = newpm; /* Don't pop $1 et al till now */
3609 S_doparseform(pTHX_ SV *sv)
3612 register char *s = SvPV_force(sv, len);
3613 register char *send = s + len;
3614 register char *base = Nullch;
3615 register I32 skipspaces = 0;
3616 bool noblank = FALSE;
3617 bool repeat = FALSE;
3618 bool postspace = FALSE;
3624 bool unchopnum = FALSE;
3625 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3628 Perl_croak(aTHX_ "Null picture in formline");
3630 /* estimate the buffer size needed */
3631 for (base = s; s <= send; s++) {
3632 if (*s == '\n' || *s == '@' || *s == '^')
3638 New(804, fops, maxops, U32);
3643 *fpc++ = FF_LINEMARK;
3644 noblank = repeat = FALSE;
3662 case ' ': case '\t':
3669 } /* else FALL THROUGH */
3677 *fpc++ = FF_LITERAL;
3685 *fpc++ = (U16)skipspaces;
3689 *fpc++ = FF_NEWLINE;
3693 arg = fpc - linepc + 1;
3700 *fpc++ = FF_LINEMARK;
3701 noblank = repeat = FALSE;
3710 ischop = s[-1] == '^';
3716 arg = (s - base) - 1;
3718 *fpc++ = FF_LITERAL;
3726 *fpc++ = 2; /* skip the @* or ^* */
3728 *fpc++ = FF_LINESNGL;
3731 *fpc++ = FF_LINEGLOB;
3733 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3734 arg = ischop ? 512 : 0;
3739 const char * const f = ++s;
3742 arg |= 256 + (s - f);
3744 *fpc++ = s - base; /* fieldsize for FETCH */
3745 *fpc++ = FF_DECIMAL;
3747 unchopnum |= ! ischop;
3749 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3750 arg = ischop ? 512 : 0;
3752 s++; /* skip the '0' first */
3756 const char * const f = ++s;
3759 arg |= 256 + (s - f);
3761 *fpc++ = s - base; /* fieldsize for FETCH */
3762 *fpc++ = FF_0DECIMAL;
3764 unchopnum |= ! ischop;
3768 bool ismore = FALSE;
3771 while (*++s == '>') ;
3772 prespace = FF_SPACE;
3774 else if (*s == '|') {
3775 while (*++s == '|') ;
3776 prespace = FF_HALFSPACE;
3781 while (*++s == '<') ;
3784 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3788 *fpc++ = s - base; /* fieldsize for FETCH */
3790 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3793 *fpc++ = (U16)prespace;
3807 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3809 { /* need to jump to the next word */
3811 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3812 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3813 s = SvPVX(sv) + SvCUR(sv) + z;
3815 Copy(fops, s, arg, U32);
3817 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3820 if (unchopnum && repeat)
3821 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3827 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3829 /* Can value be printed in fldsize chars, using %*.*f ? */
3833 int intsize = fldsize - (value < 0 ? 1 : 0);
3840 while (intsize--) pwr *= 10.0;
3841 while (frcsize--) eps /= 10.0;
3844 if (value + eps >= pwr)
3847 if (value - eps <= -pwr)
3854 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3857 SV *datasv = FILTER_DATA(idx);
3858 int filter_has_file = IoLINES(datasv);
3859 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3860 SV *filter_state = (SV *)IoTOP_GV(datasv);
3861 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3864 /* I was having segfault trouble under Linux 2.2.5 after a
3865 parse error occured. (Had to hack around it with a test
3866 for PL_error_count == 0.) Solaris doesn't segfault --
3867 not sure where the trouble is yet. XXX */
3869 if (filter_has_file) {
3870 len = FILTER_READ(idx+1, buf_sv, maxlen);
3873 if (filter_sub && len >= 0) {
3884 PUSHs(sv_2mortal(newSViv(maxlen)));
3886 PUSHs(filter_state);
3889 count = call_sv(filter_sub, G_SCALAR);
3905 IoLINES(datasv) = 0;
3906 if (filter_child_proc) {
3907 SvREFCNT_dec(filter_child_proc);
3908 IoFMT_GV(datasv) = Nullgv;
3911 SvREFCNT_dec(filter_state);
3912 IoTOP_GV(datasv) = Nullgv;
3915 SvREFCNT_dec(filter_sub);
3916 IoBOTTOM_GV(datasv) = Nullgv;
3918 filter_del(run_user_filter);
3924 /* perhaps someone can come up with a better name for
3925 this? it is not really "absolute", per se ... */
3927 S_path_is_absolute(pTHX_ const char *name)
3929 if (PERL_FILE_IS_ABSOLUTE(name)
3930 #ifdef MACOS_TRADITIONAL
3933 || (*name == '.' && (name[1] == '/' ||
3934 (name[1] == '.' && name[2] == '/'))))
3945 * c-indentation-style: bsd
3947 * indent-tabs-mode: t
3950 * vim: shiftwidth=4: