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 Safefree(SvPVX(targ));
247 SvPV_set(targ, SvPVX(dstr));
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
252 SvPV_set(dstr, (char*)0);
255 TAINT_IF(cx->sb_rxtainted & 1);
256 PUSHs(sv_2mortal(newSViv(saviters - 1)));
258 (void)SvPOK_only_UTF8(targ);
259 TAINT_IF(cx->sb_rxtainted);
263 LEAVE_SCOPE(cx->sb_oldsave);
266 RETURNOP(pm->op_next);
268 cx->sb_iters = saviters;
270 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
273 cx->sb_orig = orig = rx->subbeg;
275 cx->sb_strend = s + (cx->sb_strend - m);
277 cx->sb_m = m = rx->startp[0] + orig;
279 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
280 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
282 sv_catpvn(dstr, s, m-s);
284 cx->sb_s = rx->endp[0] + orig;
285 { /* Update the pos() information. */
286 SV *sv = cx->sb_targ;
289 if (SvTYPE(sv) < SVt_PVMG)
290 (void)SvUPGRADE(sv, SVt_PVMG);
291 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
292 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
293 mg = mg_find(sv, PERL_MAGIC_regex_global);
302 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
303 rxres_save(&cx->sb_rxres, rx);
304 RETURNOP(pm->op_pmreplstart);
308 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
313 if (!p || p[1] < rx->nparens) {
314 #ifdef PERL_COPY_ON_WRITE
315 i = 7 + rx->nparens * 2;
317 i = 6 + rx->nparens * 2;
326 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
327 RX_MATCH_COPIED_off(rx);
329 #ifdef PERL_COPY_ON_WRITE
330 *p++ = PTR2UV(rx->saved_copy);
331 rx->saved_copy = Nullsv;
336 *p++ = PTR2UV(rx->subbeg);
337 *p++ = (UV)rx->sublen;
338 for (i = 0; i <= rx->nparens; ++i) {
339 *p++ = (UV)rx->startp[i];
340 *p++ = (UV)rx->endp[i];
345 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
350 RX_MATCH_COPY_FREE(rx);
351 RX_MATCH_COPIED_set(rx, *p);
354 #ifdef PERL_COPY_ON_WRITE
356 SvREFCNT_dec (rx->saved_copy);
357 rx->saved_copy = INT2PTR(SV*,*p);
363 rx->subbeg = INT2PTR(char*,*p++);
364 rx->sublen = (I32)(*p++);
365 for (i = 0; i <= rx->nparens; ++i) {
366 rx->startp[i] = (I32)(*p++);
367 rx->endp[i] = (I32)(*p++);
372 Perl_rxres_free(pTHX_ void **rsp)
377 Safefree(INT2PTR(char*,*p));
378 #ifdef PERL_COPY_ON_WRITE
380 SvREFCNT_dec (INT2PTR(SV*,p[1]));
390 dSP; dMARK; dORIGMARK;
391 register SV *tmpForm = *++MARK;
398 register SV *sv = Nullsv;
403 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
404 char *chophere = Nullch;
405 char *linemark = Nullch;
407 bool gotsome = FALSE;
409 STRLEN fudge = SvPOK(tmpForm)
410 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
411 bool item_is_utf8 = FALSE;
412 bool targ_is_utf8 = FALSE;
418 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
419 if (SvREADONLY(tmpForm)) {
420 SvREADONLY_off(tmpForm);
421 parseres = doparseform(tmpForm);
422 SvREADONLY_on(tmpForm);
425 parseres = doparseform(tmpForm);
429 SvPV_force(PL_formtarget, len);
430 if (DO_UTF8(PL_formtarget))
432 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
434 f = SvPV(tmpForm, len);
435 /* need to jump to the next word */
436 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
442 const char *name = "???";
445 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
446 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
447 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
448 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
449 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
451 case FF_CHECKNL: name = "CHECKNL"; break;
452 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
453 case FF_SPACE: name = "SPACE"; break;
454 case FF_HALFSPACE: name = "HALFSPACE"; break;
455 case FF_ITEM: name = "ITEM"; break;
456 case FF_CHOP: name = "CHOP"; break;
457 case FF_LINEGLOB: name = "LINEGLOB"; break;
458 case FF_NEWLINE: name = "NEWLINE"; break;
459 case FF_MORE: name = "MORE"; break;
460 case FF_LINEMARK: name = "LINEMARK"; break;
461 case FF_END: name = "END"; break;
462 case FF_0DECIMAL: name = "0DECIMAL"; break;
463 case FF_LINESNGL: name = "LINESNGL"; break;
466 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
468 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
479 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
480 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
482 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
483 t = SvEND(PL_formtarget);
486 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
487 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
489 sv_utf8_upgrade(PL_formtarget);
490 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
491 t = SvEND(PL_formtarget);
511 if (ckWARN(WARN_SYNTAX))
512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
517 item = s = SvPV(sv, len);
520 itemsize = sv_len_utf8(sv);
521 if (itemsize != (I32)len) {
523 if (itemsize > fieldsize) {
524 itemsize = fieldsize;
525 itembytes = itemsize;
526 sv_pos_u2b(sv, &itembytes, 0);
530 send = chophere = s + itembytes;
540 sv_pos_b2u(sv, &itemsize);
544 item_is_utf8 = FALSE;
545 if (itemsize > fieldsize)
546 itemsize = fieldsize;
547 send = chophere = s + itemsize;
559 item = s = SvPV(sv, len);
562 itemsize = sv_len_utf8(sv);
563 if (itemsize != (I32)len) {
565 if (itemsize <= fieldsize) {
566 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 send = chophere = s + itemsize;
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
630 if (strchr(PL_chopset, *s))
635 itemsize = chophere - item;
640 arg = fieldsize - itemsize;
649 arg = fieldsize - itemsize;
663 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
665 sv_utf8_upgrade(PL_formtarget);
666 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
667 t = SvEND(PL_formtarget);
671 if (UTF8_IS_CONTINUED(*s)) {
672 STRLEN skip = UTF8SKIP(s);
689 if ( !((*t++ = *s++) & ~31) )
695 if (targ_is_utf8 && !item_is_utf8) {
696 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
698 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
699 for (; t < SvEND(PL_formtarget); t++) {
712 int ch = *t++ = *s++;
715 if ( !((*t++ = *s++) & ~31) )
724 while (*s && isSPACE(*s))
738 item = s = SvPV(sv, len);
740 if ((item_is_utf8 = DO_UTF8(sv)))
741 itemsize = sv_len_utf8(sv);
743 bool chopped = FALSE;
746 chophere = s + itemsize;
762 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
764 SvUTF8_on(PL_formtarget);
766 SvCUR_set(sv, chophere - item);
767 sv_catsv(PL_formtarget, sv);
768 SvCUR_set(sv, itemsize);
770 sv_catsv(PL_formtarget, sv);
772 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
773 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
774 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
782 #if defined(USE_LONG_DOUBLE)
783 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
785 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
790 #if defined(USE_LONG_DOUBLE)
791 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
793 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
796 /* If the field is marked with ^ and the value is undefined,
798 if ((arg & 512) && !SvOK(sv)) {
806 /* overflow evidence */
807 if (num_overflow(value, fieldsize, arg)) {
813 /* Formats aren't yet marked for locales, so assume "yes". */
815 STORE_NUMERIC_STANDARD_SET_LOCAL();
816 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
817 RESTORE_NUMERIC_STANDARD();
824 while (t-- > linemark && *t == ' ') ;
832 if (arg) { /* repeat until fields exhausted? */
834 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
835 lines += FmLINES(PL_formtarget);
838 if (strnEQ(linemark, linemark - arg, arg))
839 DIE(aTHX_ "Runaway format");
842 SvUTF8_on(PL_formtarget);
843 FmLINES(PL_formtarget) = lines;
845 RETURNOP(cLISTOP->op_first);
858 while (*s && isSPACE(*s) && s < send)
862 arg = fieldsize - itemsize;
869 if (strnEQ(s," ",3)) {
870 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
881 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
883 SvUTF8_on(PL_formtarget);
884 FmLINES(PL_formtarget) += lines;
896 if (PL_stack_base + *PL_markstack_ptr == SP) {
898 if (GIMME_V == G_SCALAR)
899 XPUSHs(sv_2mortal(newSViv(0)));
900 RETURNOP(PL_op->op_next->op_next);
902 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
903 pp_pushmark(); /* push dst */
904 pp_pushmark(); /* push src */
905 ENTER; /* enter outer scope */
908 if (PL_op->op_private & OPpGREP_LEX)
909 SAVESPTR(PAD_SVl(PL_op->op_targ));
912 ENTER; /* enter inner scope */
915 src = PL_stack_base[*PL_markstack_ptr];
917 if (PL_op->op_private & OPpGREP_LEX)
918 PAD_SVl(PL_op->op_targ) = src;
923 if (PL_op->op_type == OP_MAPSTART)
924 pp_pushmark(); /* push top */
925 return ((LOGOP*)PL_op->op_next)->op_other;
930 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
937 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
943 /* first, move source pointer to the next item in the source list */
944 ++PL_markstack_ptr[-1];
946 /* if there are new items, push them into the destination list */
947 if (items && gimme != G_VOID) {
948 /* might need to make room back there first */
949 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
950 /* XXX this implementation is very pessimal because the stack
951 * is repeatedly extended for every set of items. Is possible
952 * to do this without any stack extension or copying at all
953 * by maintaining a separate list over which the map iterates
954 * (like foreach does). --gsar */
956 /* everything in the stack after the destination list moves
957 * towards the end the stack by the amount of room needed */
958 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
960 /* items to shift up (accounting for the moved source pointer) */
961 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
963 /* This optimization is by Ben Tilly and it does
964 * things differently from what Sarathy (gsar)
965 * is describing. The downside of this optimization is
966 * that leaves "holes" (uninitialized and hopefully unused areas)
967 * to the Perl stack, but on the other hand this
968 * shouldn't be a problem. If Sarathy's idea gets
969 * implemented, this optimization should become
970 * irrelevant. --jhi */
972 shift = count; /* Avoid shifting too often --Ben Tilly */
977 PL_markstack_ptr[-1] += shift;
978 *PL_markstack_ptr += shift;
982 /* copy the new items down to the destination list */
983 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
984 if (gimme == G_ARRAY) {
986 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
989 /* scalar context: we don't care about which values map returns
990 * (we use undef here). And so we certainly don't want to do mortal
991 * copies of meaningless values. */
992 while (items-- > 0) {
994 *dst-- = &PL_sv_undef;
998 LEAVE; /* exit inner scope */
1001 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1003 (void)POPMARK; /* pop top */
1004 LEAVE; /* exit outer scope */
1005 (void)POPMARK; /* pop src */
1006 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1007 (void)POPMARK; /* pop dst */
1008 SP = PL_stack_base + POPMARK; /* pop original mark */
1009 if (gimme == G_SCALAR) {
1010 if (PL_op->op_private & OPpGREP_LEX) {
1011 SV* sv = sv_newmortal();
1012 sv_setiv(sv, items);
1020 else if (gimme == G_ARRAY)
1027 ENTER; /* enter inner scope */
1030 /* set $_ to the new source item */
1031 src = PL_stack_base[PL_markstack_ptr[-1]];
1033 if (PL_op->op_private & OPpGREP_LEX)
1034 PAD_SVl(PL_op->op_targ) = src;
1038 RETURNOP(cLOGOP->op_other);
1046 if (GIMME == G_ARRAY)
1048 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1049 return cLOGOP->op_other;
1058 if (GIMME == G_ARRAY) {
1059 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1063 SV *targ = PAD_SV(PL_op->op_targ);
1066 if (PL_op->op_private & OPpFLIP_LINENUM) {
1067 if (GvIO(PL_last_in_gv)) {
1068 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1071 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1072 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1078 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1079 if (PL_op->op_flags & OPf_SPECIAL) {
1087 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1096 /* This code tries to decide if "$left .. $right" should use the
1097 magical string increment, or if the range is numeric (we make
1098 an exception for .."0" [#18165]). AMS 20021031. */
1100 #define RANGE_IS_NUMERIC(left,right) ( \
1101 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1102 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1103 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1104 looks_like_number(left)) && SvPOKp(left) && *SvPVX(left) != '0')) \
1105 && (!SvOK(right) || looks_like_number(right))))
1111 if (GIMME == G_ARRAY) {
1117 if (SvGMAGICAL(left))
1119 if (SvGMAGICAL(right))
1122 if (RANGE_IS_NUMERIC(left,right)) {
1123 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1124 (SvOK(right) && SvNV(right) > IV_MAX))
1125 DIE(aTHX_ "Range iterator outside integer range");
1136 sv = sv_2mortal(newSViv(i++));
1141 SV *final = sv_mortalcopy(right);
1143 char *tmps = SvPV(final, len);
1145 sv = sv_mortalcopy(left);
1147 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1149 if (strEQ(SvPVX(sv),tmps))
1151 sv = sv_2mortal(newSVsv(sv));
1158 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1162 if (PL_op->op_private & OPpFLIP_LINENUM) {
1163 if (GvIO(PL_last_in_gv)) {
1164 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1167 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1168 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1176 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1177 sv_catpv(targ, "E0");
1187 static const char * const context_name[] = {
1198 S_dopoptolabel(pTHX_ const char *label)
1202 for (i = cxstack_ix; i >= 0; i--) {
1203 register const PERL_CONTEXT *cx = &cxstack[i];
1204 switch (CxTYPE(cx)) {
1210 if (ckWARN(WARN_EXITING))
1211 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1212 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1213 if (CxTYPE(cx) == CXt_NULL)
1217 if (!cx->blk_loop.label ||
1218 strNE(label, cx->blk_loop.label) ) {
1219 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1220 (long)i, cx->blk_loop.label));
1223 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1231 Perl_dowantarray(pTHX)
1233 I32 gimme = block_gimme();
1234 return (gimme == G_VOID) ? G_SCALAR : gimme;
1238 Perl_block_gimme(pTHX)
1240 const I32 cxix = dopoptosub(cxstack_ix);
1244 switch (cxstack[cxix].blk_gimme) {
1252 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1259 Perl_is_lvalue_sub(pTHX)
1261 const I32 cxix = dopoptosub(cxstack_ix);
1262 assert(cxix >= 0); /* We should only be called from inside subs */
1264 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1265 return cxstack[cxix].blk_sub.lval;
1271 S_dopoptosub(pTHX_ I32 startingblock)
1273 return dopoptosub_at(cxstack, startingblock);
1277 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1280 for (i = startingblock; i >= 0; i--) {
1281 register const PERL_CONTEXT *cx = &cxstk[i];
1282 switch (CxTYPE(cx)) {
1288 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1296 S_dopoptoeval(pTHX_ I32 startingblock)
1299 for (i = startingblock; i >= 0; i--) {
1300 register const PERL_CONTEXT *cx = &cxstack[i];
1301 switch (CxTYPE(cx)) {
1305 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1313 S_dopoptoloop(pTHX_ I32 startingblock)
1316 for (i = startingblock; i >= 0; i--) {
1317 register const PERL_CONTEXT *cx = &cxstack[i];
1318 switch (CxTYPE(cx)) {
1324 if (ckWARN(WARN_EXITING))
1325 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1326 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1327 if ((CxTYPE(cx)) == CXt_NULL)
1331 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1339 Perl_dounwind(pTHX_ I32 cxix)
1343 while (cxstack_ix > cxix) {
1345 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1346 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1347 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1348 /* Note: we don't need to restore the base context info till the end. */
1349 switch (CxTYPE(cx)) {
1352 continue; /* not break */
1374 Perl_qerror(pTHX_ SV *err)
1377 sv_catsv(ERRSV, err);
1379 sv_catsv(PL_errors, err);
1381 Perl_warn(aTHX_ "%"SVf, err);
1386 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1397 if (PL_in_eval & EVAL_KEEPERR) {
1398 static const char prefix[] = "\t(in cleanup) ";
1400 const char *e = Nullch;
1403 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1406 if (*e != *message || strNE(e,message))
1410 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1411 sv_catpvn(err, prefix, sizeof(prefix)-1);
1412 sv_catpvn(err, message, msglen);
1413 if (ckWARN(WARN_MISC)) {
1414 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1415 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1420 sv_setpvn(ERRSV, message, msglen);
1424 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1425 && PL_curstackinfo->si_prev)
1433 register PERL_CONTEXT *cx;
1435 if (cxix < cxstack_ix)
1438 POPBLOCK(cx,PL_curpm);
1439 if (CxTYPE(cx) != CXt_EVAL) {
1441 message = SvPVx(ERRSV, msglen);
1442 PerlIO_write(Perl_error_log, "panic: die ", 11);
1443 PerlIO_write(Perl_error_log, message, msglen);
1448 if (gimme == G_SCALAR)
1449 *++newsp = &PL_sv_undef;
1450 PL_stack_sp = newsp;
1454 /* LEAVE could clobber PL_curcop (see save_re_context())
1455 * XXX it might be better to find a way to avoid messing with
1456 * PL_curcop in save_re_context() instead, but this is a more
1457 * minimal fix --GSAR */
1458 PL_curcop = cx->blk_oldcop;
1460 if (optype == OP_REQUIRE) {
1461 const char* msg = SvPVx(ERRSV, n_a);
1462 SV *nsv = cx->blk_eval.old_namesv;
1463 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1465 DIE(aTHX_ "%sCompilation failed in require",
1466 *msg ? msg : "Unknown error\n");
1468 assert(CxTYPE(cx) == CXt_EVAL);
1469 return cx->blk_eval.retop;
1473 message = SvPVx(ERRSV, msglen);
1475 write_to_stderr(message, msglen);
1484 if (SvTRUE(left) != SvTRUE(right))
1496 RETURNOP(cLOGOP->op_other);
1505 RETURNOP(cLOGOP->op_other);
1514 if (!sv || !SvANY(sv)) {
1515 RETURNOP(cLOGOP->op_other);
1518 switch (SvTYPE(sv)) {
1520 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1524 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1528 if (CvROOT(sv) || CvXSUB(sv))
1538 RETURNOP(cLOGOP->op_other);
1544 register I32 cxix = dopoptosub(cxstack_ix);
1545 register PERL_CONTEXT *cx;
1546 register PERL_CONTEXT *ccstack = cxstack;
1547 PERL_SI *top_si = PL_curstackinfo;
1550 const char *stashname;
1558 /* we may be in a higher stacklevel, so dig down deeper */
1559 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1560 top_si = top_si->si_prev;
1561 ccstack = top_si->si_cxstack;
1562 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1565 if (GIMME != G_ARRAY) {
1571 /* caller() should not report the automatic calls to &DB::sub */
1572 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1573 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1577 cxix = dopoptosub_at(ccstack, cxix - 1);
1580 cx = &ccstack[cxix];
1581 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1582 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1583 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1584 field below is defined for any cx. */
1585 /* caller() should not report the automatic calls to &DB::sub */
1586 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1587 cx = &ccstack[dbcxix];
1590 stashname = CopSTASHPV(cx->blk_oldcop);
1591 if (GIMME != G_ARRAY) {
1594 PUSHs(&PL_sv_undef);
1597 sv_setpv(TARG, stashname);
1606 PUSHs(&PL_sv_undef);
1608 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1609 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1610 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1613 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1614 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1615 /* So is ccstack[dbcxix]. */
1618 gv_efullname3(sv, cvgv, Nullch);
1619 PUSHs(sv_2mortal(sv));
1620 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1623 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1624 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1628 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1629 PUSHs(sv_2mortal(newSViv(0)));
1631 gimme = (I32)cx->blk_gimme;
1632 if (gimme == G_VOID)
1633 PUSHs(&PL_sv_undef);
1635 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1636 if (CxTYPE(cx) == CXt_EVAL) {
1638 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1639 PUSHs(cx->blk_eval.cur_text);
1643 else if (cx->blk_eval.old_namesv) {
1644 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1647 /* eval BLOCK (try blocks have old_namesv == 0) */
1649 PUSHs(&PL_sv_undef);
1650 PUSHs(&PL_sv_undef);
1654 PUSHs(&PL_sv_undef);
1655 PUSHs(&PL_sv_undef);
1657 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1658 && CopSTASH_eq(PL_curcop, PL_debstash))
1660 AV *ary = cx->blk_sub.argarray;
1661 const int off = AvARRAY(ary) - AvALLOC(ary);
1665 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1668 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1671 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1672 av_extend(PL_dbargs, AvFILLp(ary) + off);
1673 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1674 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1676 /* XXX only hints propagated via op_private are currently
1677 * visible (others are not easily accessible, since they
1678 * use the global PL_hints) */
1679 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1680 HINT_PRIVATE_MASK)));
1683 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1685 if (old_warnings == pWARN_NONE ||
1686 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1687 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1688 else if (old_warnings == pWARN_ALL ||
1689 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1690 /* Get the bit mask for $warnings::Bits{all}, because
1691 * it could have been extended by warnings::register */
1693 HV *bits = get_hv("warnings::Bits", FALSE);
1694 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1695 mask = newSVsv(*bits_all);
1698 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1702 mask = newSVsv(old_warnings);
1703 PUSHs(sv_2mortal(mask));
1718 sv_reset(tmps, CopSTASH(PL_curcop));
1728 /* like pp_nextstate, but used instead when the debugger is active */
1733 PL_curcop = (COP*)PL_op;
1734 TAINT_NOT; /* Each statement is presumed innocent */
1735 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1738 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1739 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1743 register PERL_CONTEXT *cx;
1744 I32 gimme = G_ARRAY;
1751 DIE(aTHX_ "No DB::DB routine defined");
1753 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1754 /* don't do recursive DB::DB call */
1766 PUSHBLOCK(cx, CXt_SUB, SP);
1768 cx->blk_sub.retop = PL_op->op_next;
1770 PAD_SET_CUR(CvPADLIST(cv),1);
1771 RETURNOP(CvSTART(cv));
1785 register PERL_CONTEXT *cx;
1786 I32 gimme = GIMME_V;
1788 U32 cxtype = CXt_LOOP;
1796 if (PL_op->op_targ) {
1797 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1798 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1799 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1800 SVs_PADSTALE, SVs_PADSTALE);
1802 #ifndef USE_ITHREADS
1803 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1806 SAVEPADSV(PL_op->op_targ);
1807 iterdata = INT2PTR(void*, PL_op->op_targ);
1808 cxtype |= CXp_PADVAR;
1813 svp = &GvSV(gv); /* symbol table variable */
1814 SAVEGENERICSV(*svp);
1817 iterdata = (void*)gv;
1823 PUSHBLOCK(cx, cxtype, SP);
1825 PUSHLOOP(cx, iterdata, MARK);
1827 PUSHLOOP(cx, svp, MARK);
1829 if (PL_op->op_flags & OPf_STACKED) {
1830 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1831 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1833 SV *right = (SV*)cx->blk_loop.iterary;
1834 if (RANGE_IS_NUMERIC(sv,right)) {
1835 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1836 (SvOK(right) && SvNV(right) >= IV_MAX))
1837 DIE(aTHX_ "Range iterator outside integer range");
1838 cx->blk_loop.iterix = SvIV(sv);
1839 cx->blk_loop.itermax = SvIV(right);
1843 cx->blk_loop.iterlval = newSVsv(sv);
1844 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1845 (void) SvPV(right,n_a);
1848 else if (PL_op->op_private & OPpITER_REVERSED) {
1849 cx->blk_loop.itermax = -1;
1850 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1855 cx->blk_loop.iterary = PL_curstack;
1856 AvFILLp(PL_curstack) = SP - PL_stack_base;
1857 if (PL_op->op_private & OPpITER_REVERSED) {
1858 cx->blk_loop.itermax = MARK - PL_stack_base;
1859 cx->blk_loop.iterix = cx->blk_oldsp;
1862 cx->blk_loop.iterix = MARK - PL_stack_base;
1872 register PERL_CONTEXT *cx;
1873 I32 gimme = GIMME_V;
1879 PUSHBLOCK(cx, CXt_LOOP, SP);
1880 PUSHLOOP(cx, 0, SP);
1888 register PERL_CONTEXT *cx;
1896 newsp = PL_stack_base + cx->blk_loop.resetsp;
1899 if (gimme == G_VOID)
1901 else if (gimme == G_SCALAR) {
1903 *++newsp = sv_mortalcopy(*SP);
1905 *++newsp = &PL_sv_undef;
1909 *++newsp = sv_mortalcopy(*++mark);
1910 TAINT_NOT; /* Each item is independent */
1916 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1917 PL_curpm = newpm; /* ... and pop $1 et al */
1929 register PERL_CONTEXT *cx;
1930 bool popsub2 = FALSE;
1931 bool clear_errsv = FALSE;
1939 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1940 if (cxstack_ix == PL_sortcxix
1941 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1943 if (cxstack_ix > PL_sortcxix)
1944 dounwind(PL_sortcxix);
1945 AvARRAY(PL_curstack)[1] = *SP;
1946 PL_stack_sp = PL_stack_base + 1;
1951 cxix = dopoptosub(cxstack_ix);
1953 DIE(aTHX_ "Can't return outside a subroutine");
1954 if (cxix < cxstack_ix)
1958 switch (CxTYPE(cx)) {
1961 retop = cx->blk_sub.retop;
1962 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1965 if (!(PL_in_eval & EVAL_KEEPERR))
1968 retop = cx->blk_eval.retop;
1972 if (optype == OP_REQUIRE &&
1973 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1975 /* Unassume the success we assumed earlier. */
1976 SV *nsv = cx->blk_eval.old_namesv;
1977 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1978 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1983 retop = cx->blk_sub.retop;
1986 DIE(aTHX_ "panic: return");
1990 if (gimme == G_SCALAR) {
1993 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1995 *++newsp = SvREFCNT_inc(*SP);
2000 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2002 *++newsp = sv_mortalcopy(sv);
2007 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2010 *++newsp = sv_mortalcopy(*SP);
2013 *++newsp = &PL_sv_undef;
2015 else if (gimme == G_ARRAY) {
2016 while (++MARK <= SP) {
2017 *++newsp = (popsub2 && SvTEMP(*MARK))
2018 ? *MARK : sv_mortalcopy(*MARK);
2019 TAINT_NOT; /* Each item is independent */
2022 PL_stack_sp = newsp;
2025 /* Stack values are safe: */
2028 POPSUB(cx,sv); /* release CV and @_ ... */
2032 PL_curpm = newpm; /* ... and pop $1 et al */
2044 register PERL_CONTEXT *cx;
2054 if (PL_op->op_flags & OPf_SPECIAL) {
2055 cxix = dopoptoloop(cxstack_ix);
2057 DIE(aTHX_ "Can't \"last\" outside a loop block");
2060 cxix = dopoptolabel(cPVOP->op_pv);
2062 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2064 if (cxix < cxstack_ix)
2068 cxstack_ix++; /* temporarily protect top context */
2070 switch (CxTYPE(cx)) {
2073 newsp = PL_stack_base + cx->blk_loop.resetsp;
2074 nextop = cx->blk_loop.last_op->op_next;
2078 nextop = cx->blk_sub.retop;
2082 nextop = cx->blk_eval.retop;
2086 nextop = cx->blk_sub.retop;
2089 DIE(aTHX_ "panic: last");
2093 if (gimme == G_SCALAR) {
2095 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2096 ? *SP : sv_mortalcopy(*SP);
2098 *++newsp = &PL_sv_undef;
2100 else if (gimme == G_ARRAY) {
2101 while (++MARK <= SP) {
2102 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2103 ? *MARK : sv_mortalcopy(*MARK);
2104 TAINT_NOT; /* Each item is independent */
2112 /* Stack values are safe: */
2115 POPLOOP(cx); /* release loop vars ... */
2119 POPSUB(cx,sv); /* release CV and @_ ... */
2122 PL_curpm = newpm; /* ... and pop $1 et al */
2132 register PERL_CONTEXT *cx;
2135 if (PL_op->op_flags & OPf_SPECIAL) {
2136 cxix = dopoptoloop(cxstack_ix);
2138 DIE(aTHX_ "Can't \"next\" outside a loop block");
2141 cxix = dopoptolabel(cPVOP->op_pv);
2143 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2145 if (cxix < cxstack_ix)
2148 /* clear off anything above the scope we're re-entering, but
2149 * save the rest until after a possible continue block */
2150 inner = PL_scopestack_ix;
2152 if (PL_scopestack_ix < inner)
2153 leave_scope(PL_scopestack[PL_scopestack_ix]);
2154 return cx->blk_loop.next_op;
2161 register PERL_CONTEXT *cx;
2164 if (PL_op->op_flags & OPf_SPECIAL) {
2165 cxix = dopoptoloop(cxstack_ix);
2167 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2170 cxix = dopoptolabel(cPVOP->op_pv);
2172 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2174 if (cxix < cxstack_ix)
2178 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2179 LEAVE_SCOPE(oldsave);
2181 return cx->blk_loop.redo_op;
2185 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2189 static const char too_deep[] = "Target of goto is too deeply nested";
2192 Perl_croak(aTHX_ too_deep);
2193 if (o->op_type == OP_LEAVE ||
2194 o->op_type == OP_SCOPE ||
2195 o->op_type == OP_LEAVELOOP ||
2196 o->op_type == OP_LEAVESUB ||
2197 o->op_type == OP_LEAVETRY)
2199 *ops++ = cUNOPo->op_first;
2201 Perl_croak(aTHX_ too_deep);
2204 if (o->op_flags & OPf_KIDS) {
2205 /* First try all the kids at this level, since that's likeliest. */
2206 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2207 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2208 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2211 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2212 if (kid == PL_lastgotoprobe)
2214 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2217 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2218 ops[-1]->op_type == OP_DBSTATE)
2223 if ((o = dofindlabel(kid, label, ops, oplimit)))
2242 register PERL_CONTEXT *cx;
2243 #define GOTO_DEPTH 64
2244 OP *enterops[GOTO_DEPTH];
2245 const char *label = 0;
2246 const bool do_dump = (PL_op->op_type == OP_DUMP);
2247 static const char must_have_label[] = "goto must have label";
2249 if (PL_op->op_flags & OPf_STACKED) {
2253 /* This egregious kludge implements goto &subroutine */
2254 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2256 register PERL_CONTEXT *cx;
2257 CV* cv = (CV*)SvRV(sv);
2264 if (!CvROOT(cv) && !CvXSUB(cv)) {
2265 const GV * const gv = CvGV(cv);
2269 /* autoloaded stub? */
2270 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2272 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2273 GvNAMELEN(gv), FALSE);
2274 if (autogv && (cv = GvCV(autogv)))
2276 tmpstr = sv_newmortal();
2277 gv_efullname3(tmpstr, gv, Nullch);
2278 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2280 DIE(aTHX_ "Goto undefined subroutine");
2283 /* First do some returnish stuff. */
2284 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2286 cxix = dopoptosub(cxstack_ix);
2288 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2289 if (cxix < cxstack_ix)
2293 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2294 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2295 /* put @_ back onto stack */
2296 AV* av = cx->blk_sub.argarray;
2298 items = AvFILLp(av) + 1;
2299 EXTEND(SP, items+1); /* @_ could have been extended. */
2300 Copy(AvARRAY(av), SP + 1, items, SV*);
2301 SvREFCNT_dec(GvAV(PL_defgv));
2302 GvAV(PL_defgv) = cx->blk_sub.savearray;
2304 /* abandon @_ if it got reified */
2309 av_extend(av, items-1);
2310 AvFLAGS(av) = AVf_REIFY;
2311 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2314 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2316 av = GvAV(PL_defgv);
2317 items = AvFILLp(av) + 1;
2318 EXTEND(SP, items+1); /* @_ could have been extended. */
2319 Copy(AvARRAY(av), SP + 1, items, SV*);
2323 if (CxTYPE(cx) == CXt_SUB &&
2324 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2325 SvREFCNT_dec(cx->blk_sub.cv);
2326 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2327 LEAVE_SCOPE(oldsave);
2329 /* Now do some callish stuff. */
2331 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2335 for (index=0; index<items; index++)
2336 sv_2mortal(SP[-index]);
2338 #ifdef PERL_XSUB_OLDSTYLE
2339 if (CvOLDSTYLE(cv)) {
2340 I32 (*fp3)(int,int,int);
2345 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2346 items = (*fp3)(CvXSUBANY(cv).any_i32,
2347 mark - PL_stack_base + 1,
2349 SP = PL_stack_base + items;
2352 #endif /* PERL_XSUB_OLDSTYLE */
2357 /* Push a mark for the start of arglist */
2360 (void)(*CvXSUB(cv))(aTHX_ cv);
2361 /* Pop the current context like a decent sub should */
2362 POPBLOCK(cx, PL_curpm);
2363 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2366 assert(CxTYPE(cx) == CXt_SUB);
2367 return cx->blk_sub.retop;
2370 AV* padlist = CvPADLIST(cv);
2371 if (CxTYPE(cx) == CXt_EVAL) {
2372 PL_in_eval = cx->blk_eval.old_in_eval;
2373 PL_eval_root = cx->blk_eval.old_eval_root;
2374 cx->cx_type = CXt_SUB;
2375 cx->blk_sub.hasargs = 0;
2377 cx->blk_sub.cv = cv;
2378 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2381 if (CvDEPTH(cv) < 2)
2382 (void)SvREFCNT_inc(cv);
2384 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2385 sub_crush_depth(cv);
2386 pad_push(padlist, CvDEPTH(cv));
2388 PAD_SET_CUR(padlist, CvDEPTH(cv));
2389 if (cx->blk_sub.hasargs)
2391 AV* av = (AV*)PAD_SVl(0);
2394 cx->blk_sub.savearray = GvAV(PL_defgv);
2395 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2396 CX_CURPAD_SAVE(cx->blk_sub);
2397 cx->blk_sub.argarray = av;
2399 if (items >= AvMAX(av) + 1) {
2401 if (AvARRAY(av) != ary) {
2402 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2403 SvPV_set(av, (char*)ary);
2405 if (items >= AvMAX(av) + 1) {
2406 AvMAX(av) = items - 1;
2407 Renew(ary,items+1,SV*);
2409 SvPV_set(av, (char*)ary);
2413 Copy(mark,AvARRAY(av),items,SV*);
2414 AvFILLp(av) = items - 1;
2415 assert(!AvREAL(av));
2417 /* transfer 'ownership' of refcnts to new @_ */
2427 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2429 * We do not care about using sv to call CV;
2430 * it's for informational purposes only.
2432 SV *sv = GvSV(PL_DBsub);
2436 if (PERLDB_SUB_NN) {
2437 int type = SvTYPE(sv);
2438 if (type < SVt_PVIV && type != SVt_IV)
2439 sv_upgrade(sv, SVt_PVIV);
2441 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2443 gv_efullname3(sv, CvGV(cv), Nullch);
2446 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2447 PUSHMARK( PL_stack_sp );
2448 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2452 RETURNOP(CvSTART(cv));
2456 label = SvPV(sv,n_a);
2457 if (!(do_dump || *label))
2458 DIE(aTHX_ must_have_label);
2461 else if (PL_op->op_flags & OPf_SPECIAL) {
2463 DIE(aTHX_ must_have_label);
2466 label = cPVOP->op_pv;
2468 if (label && *label) {
2470 bool leaving_eval = FALSE;
2471 bool in_block = FALSE;
2472 PERL_CONTEXT *last_eval_cx = 0;
2476 PL_lastgotoprobe = 0;
2478 for (ix = cxstack_ix; ix >= 0; ix--) {
2480 switch (CxTYPE(cx)) {
2482 leaving_eval = TRUE;
2483 if (!CxTRYBLOCK(cx)) {
2484 gotoprobe = (last_eval_cx ?
2485 last_eval_cx->blk_eval.old_eval_root :
2490 /* else fall through */
2492 gotoprobe = cx->blk_oldcop->op_sibling;
2498 gotoprobe = cx->blk_oldcop->op_sibling;
2501 gotoprobe = PL_main_root;
2504 if (CvDEPTH(cx->blk_sub.cv)) {
2505 gotoprobe = CvROOT(cx->blk_sub.cv);
2511 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2514 DIE(aTHX_ "panic: goto");
2515 gotoprobe = PL_main_root;
2519 retop = dofindlabel(gotoprobe, label,
2520 enterops, enterops + GOTO_DEPTH);
2524 PL_lastgotoprobe = gotoprobe;
2527 DIE(aTHX_ "Can't find label %s", label);
2529 /* if we're leaving an eval, check before we pop any frames
2530 that we're not going to punt, otherwise the error
2533 if (leaving_eval && *enterops && enterops[1]) {
2535 for (i = 1; enterops[i]; i++)
2536 if (enterops[i]->op_type == OP_ENTERITER)
2537 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2540 /* pop unwanted frames */
2542 if (ix < cxstack_ix) {
2549 oldsave = PL_scopestack[PL_scopestack_ix];
2550 LEAVE_SCOPE(oldsave);
2553 /* push wanted frames */
2555 if (*enterops && enterops[1]) {
2557 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2558 for (; enterops[ix]; ix++) {
2559 PL_op = enterops[ix];
2560 /* Eventually we may want to stack the needed arguments
2561 * for each op. For now, we punt on the hard ones. */
2562 if (PL_op->op_type == OP_ENTERITER)
2563 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2564 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2572 if (!retop) retop = PL_main_start;
2574 PL_restartop = retop;
2575 PL_do_undump = TRUE;
2579 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2580 PL_do_undump = FALSE;
2596 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2598 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2601 PL_exit_flags |= PERL_EXIT_EXPECTED;
2603 PUSHs(&PL_sv_undef);
2611 NV value = SvNVx(GvSV(cCOP->cop_gv));
2612 register I32 match = I_32(value);
2615 if (((NV)match) > value)
2616 --match; /* was fractional--truncate other way */
2618 match -= cCOP->uop.scop.scop_offset;
2621 else if (match > cCOP->uop.scop.scop_max)
2622 match = cCOP->uop.scop.scop_max;
2623 PL_op = cCOP->uop.scop.scop_next[match];
2633 PL_op = PL_op->op_next; /* can't assume anything */
2636 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2637 match -= cCOP->uop.scop.scop_offset;
2640 else if (match > cCOP->uop.scop.scop_max)
2641 match = cCOP->uop.scop.scop_max;
2642 PL_op = cCOP->uop.scop.scop_next[match];
2651 S_save_lines(pTHX_ AV *array, SV *sv)
2653 register const char *s = SvPVX(sv);
2654 register const char *send = SvPVX(sv) + SvCUR(sv);
2655 register const char *t;
2656 register I32 line = 1;
2658 while (s && s < send) {
2659 SV *tmpstr = NEWSV(85,0);
2661 sv_upgrade(tmpstr, SVt_PVMG);
2662 t = strchr(s, '\n');
2668 sv_setpvn(tmpstr, s, t - s);
2669 av_store(array, line++, tmpstr);
2675 S_docatch_body(pTHX)
2682 S_docatch(pTHX_ OP *o)
2685 OP * const oldop = PL_op;
2687 volatile PERL_SI *cursi = PL_curstackinfo;
2691 assert(CATCH_GET == TRUE);
2695 /* Normally, the leavetry at the end of this block of ops will
2696 * pop an op off the return stack and continue there. By setting
2697 * the op to Nullop, we force an exit from the inner runops()
2700 assert(cxstack_ix >= 0);
2701 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2702 retop = cxstack[cxstack_ix].blk_eval.retop;
2703 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2712 /* die caught by an inner eval - continue inner loop */
2713 if (PL_restartop && cursi == PL_curstackinfo) {
2714 PL_op = PL_restartop;
2718 /* a die in this eval - continue in outer loop */
2734 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2735 /* sv Text to convert to OP tree. */
2736 /* startop op_free() this to undo. */
2737 /* code Short string id of the caller. */
2739 dVAR; dSP; /* Make POPBLOCK work. */
2742 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2746 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2747 char *tmpbuf = tbuf;
2750 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2755 /* switch to eval mode */
2757 if (IN_PERL_COMPILETIME) {
2758 SAVECOPSTASH_FREE(&PL_compiling);
2759 CopSTASH_set(&PL_compiling, PL_curstash);
2761 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2762 SV *sv = sv_newmortal();
2763 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2764 code, (unsigned long)++PL_evalseq,
2765 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2769 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2770 SAVECOPFILE_FREE(&PL_compiling);
2771 CopFILE_set(&PL_compiling, tmpbuf+2);
2772 SAVECOPLINE(&PL_compiling);
2773 CopLINE_set(&PL_compiling, 1);
2774 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2775 deleting the eval's FILEGV from the stash before gv_check() runs
2776 (i.e. before run-time proper). To work around the coredump that
2777 ensues, we always turn GvMULTI_on for any globals that were
2778 introduced within evals. See force_ident(). GSAR 96-10-12 */
2779 safestr = savepv(tmpbuf);
2780 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2782 #ifdef OP_IN_REGISTER
2788 /* we get here either during compilation, or via pp_regcomp at runtime */
2789 runtime = IN_PERL_RUNTIME;
2791 runcv = find_runcv(NULL);
2794 PL_op->op_type = OP_ENTEREVAL;
2795 PL_op->op_flags = 0; /* Avoid uninit warning. */
2796 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2797 PUSHEVAL(cx, 0, Nullgv);
2800 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2802 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2803 POPBLOCK(cx,PL_curpm);
2806 (*startop)->op_type = OP_NULL;
2807 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2809 /* XXX DAPM do this properly one year */
2810 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2812 if (IN_PERL_COMPILETIME)
2813 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2814 #ifdef OP_IN_REGISTER
2822 =for apidoc find_runcv
2824 Locate the CV corresponding to the currently executing sub or eval.
2825 If db_seqp is non_null, skip CVs that are in the DB package and populate
2826 *db_seqp with the cop sequence number at the point that the DB:: code was
2827 entered. (allows debuggers to eval in the scope of the breakpoint rather
2828 than in in the scope of the debugger itself).
2834 Perl_find_runcv(pTHX_ U32 *db_seqp)
2839 *db_seqp = PL_curcop->cop_seq;
2840 for (si = PL_curstackinfo; si; si = si->si_prev) {
2842 for (ix = si->si_cxix; ix >= 0; ix--) {
2843 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2844 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2845 CV *cv = cx->blk_sub.cv;
2846 /* skip DB:: code */
2847 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2848 *db_seqp = cx->blk_oldcop->cop_seq;
2853 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2861 /* Compile a require/do, an eval '', or a /(?{...})/.
2862 * In the last case, startop is non-null, and contains the address of
2863 * a pointer that should be set to the just-compiled code.
2864 * outside is the lexically enclosing CV (if any) that invoked us.
2867 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2869 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2874 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2875 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2880 SAVESPTR(PL_compcv);
2881 PL_compcv = (CV*)NEWSV(1104,0);
2882 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2883 CvEVAL_on(PL_compcv);
2884 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2885 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2887 CvOUTSIDE_SEQ(PL_compcv) = seq;
2888 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2890 /* set up a scratch pad */
2892 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2895 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2897 /* make sure we compile in the right package */
2899 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2900 SAVESPTR(PL_curstash);
2901 PL_curstash = CopSTASH(PL_curcop);
2903 SAVESPTR(PL_beginav);
2904 PL_beginav = newAV();
2905 SAVEFREESV(PL_beginav);
2906 SAVEI32(PL_error_count);
2908 /* try to compile it */
2910 PL_eval_root = Nullop;
2912 PL_curcop = &PL_compiling;
2913 PL_curcop->cop_arybase = 0;
2914 if (saveop && saveop->op_flags & OPf_SPECIAL)
2915 PL_in_eval |= EVAL_KEEPERR;
2918 if (yyparse() || PL_error_count || !PL_eval_root) {
2919 SV **newsp; /* Used by POPBLOCK. */
2920 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2921 I32 optype = 0; /* Might be reset by POPEVAL. */
2926 op_free(PL_eval_root);
2927 PL_eval_root = Nullop;
2929 SP = PL_stack_base + POPMARK; /* pop original mark */
2931 POPBLOCK(cx,PL_curpm);
2936 if (optype == OP_REQUIRE) {
2937 const char* msg = SvPVx(ERRSV, n_a);
2938 SV *nsv = cx->blk_eval.old_namesv;
2939 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2941 DIE(aTHX_ "%sCompilation failed in require",
2942 *msg ? msg : "Unknown error\n");
2945 const char* msg = SvPVx(ERRSV, n_a);
2947 POPBLOCK(cx,PL_curpm);
2949 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2950 (*msg ? msg : "Unknown error\n"));
2953 const char* msg = SvPVx(ERRSV, n_a);
2955 sv_setpv(ERRSV, "Compilation error");
2960 CopLINE_set(&PL_compiling, 0);
2962 *startop = PL_eval_root;
2964 SAVEFREEOP(PL_eval_root);
2966 /* Set the context for this new optree.
2967 * If the last op is an OP_REQUIRE, force scalar context.
2968 * Otherwise, propagate the context from the eval(). */
2969 if (PL_eval_root->op_type == OP_LEAVEEVAL
2970 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2971 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2973 scalar(PL_eval_root);
2974 else if (gimme & G_VOID)
2975 scalarvoid(PL_eval_root);
2976 else if (gimme & G_ARRAY)
2979 scalar(PL_eval_root);
2981 DEBUG_x(dump_eval());
2983 /* Register with debugger: */
2984 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2985 CV *cv = get_cv("DB::postponed", FALSE);
2989 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2991 call_sv((SV*)cv, G_DISCARD);
2995 /* compiled okay, so do it */
2997 CvDEPTH(PL_compcv) = 1;
2998 SP = PL_stack_base + POPMARK; /* pop original mark */
2999 PL_op = saveop; /* The caller may need it. */
3000 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3002 RETURNOP(PL_eval_start);
3006 S_doopen_pm(pTHX_ const char *name, const char *mode)
3008 #ifndef PERL_DISABLE_PMC
3009 STRLEN namelen = strlen(name);
3012 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3013 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3014 const char * const pmc = SvPV_nolen(pmcsv);
3017 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3018 fp = PerlIO_open(name, mode);
3021 if (PerlLIO_stat(name, &pmstat) < 0 ||
3022 pmstat.st_mtime < pmcstat.st_mtime)
3024 fp = PerlIO_open(pmc, mode);
3027 fp = PerlIO_open(name, mode);
3030 SvREFCNT_dec(pmcsv);
3033 fp = PerlIO_open(name, mode);
3037 return PerlIO_open(name, mode);
3038 #endif /* !PERL_DISABLE_PMC */
3044 register PERL_CONTEXT *cx;
3048 char *tryname = Nullch;
3049 SV *namesv = Nullsv;
3051 I32 gimme = GIMME_V;
3052 PerlIO *tryrsfp = 0;
3054 int filter_has_file = 0;
3055 GV *filter_child_proc = 0;
3056 SV *filter_state = 0;
3063 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3064 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3065 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3066 "v-string in use/require non-portable");
3068 sv = new_version(sv);
3069 if (!sv_derived_from(PL_patchlevel, "version"))
3070 (void *)upg_version(PL_patchlevel);
3071 if ( vcmp(sv,PL_patchlevel) > 0 )
3072 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3073 vstringify(sv), vstringify(PL_patchlevel));
3077 name = SvPV(sv, len);
3078 if (!(name && len > 0 && *name))
3079 DIE(aTHX_ "Null filename used");
3080 TAINT_PROPER("require");
3081 if (PL_op->op_type == OP_REQUIRE &&
3082 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3083 if (*svp != &PL_sv_undef)
3086 DIE(aTHX_ "Compilation failed in require");
3089 /* prepare to compile file */
3091 if (path_is_absolute(name)) {
3093 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3095 #ifdef MACOS_TRADITIONAL
3099 MacPerl_CanonDir(name, newname, 1);
3100 if (path_is_absolute(newname)) {
3102 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3107 AV *ar = GvAVn(PL_incgv);
3111 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3114 namesv = NEWSV(806, 0);
3115 for (i = 0; i <= AvFILL(ar); i++) {
3116 SV *dirsv = *av_fetch(ar, i, TRUE);
3122 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3123 && !sv_isobject(loader))
3125 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3128 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3129 PTR2UV(SvRV(dirsv)), name);
3130 tryname = SvPVX(namesv);
3141 if (sv_isobject(loader))
3142 count = call_method("INC", G_ARRAY);
3144 count = call_sv(loader, G_ARRAY);
3154 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3158 if (SvTYPE(arg) == SVt_PVGV) {
3159 IO *io = GvIO((GV *)arg);
3164 tryrsfp = IoIFP(io);
3165 if (IoTYPE(io) == IoTYPE_PIPE) {
3166 /* reading from a child process doesn't
3167 nest -- when returning from reading
3168 the inner module, the outer one is
3169 unreadable (closed?) I've tried to
3170 save the gv to manage the lifespan of
3171 the pipe, but this didn't help. XXX */
3172 filter_child_proc = (GV *)arg;
3173 (void)SvREFCNT_inc(filter_child_proc);
3176 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3177 PerlIO_close(IoOFP(io));
3189 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3191 (void)SvREFCNT_inc(filter_sub);
3194 filter_state = SP[i];
3195 (void)SvREFCNT_inc(filter_state);
3199 tryrsfp = PerlIO_open("/dev/null",
3215 filter_has_file = 0;
3216 if (filter_child_proc) {
3217 SvREFCNT_dec(filter_child_proc);
3218 filter_child_proc = 0;
3221 SvREFCNT_dec(filter_state);
3225 SvREFCNT_dec(filter_sub);
3230 if (!path_is_absolute(name)
3231 #ifdef MACOS_TRADITIONAL
3232 /* We consider paths of the form :a:b ambiguous and interpret them first
3233 as global then as local
3235 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3238 char *dir = SvPVx(dirsv, n_a);
3239 #ifdef MACOS_TRADITIONAL
3243 MacPerl_CanonDir(name, buf2, 1);
3244 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3248 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3250 sv_setpv(namesv, unixdir);
3251 sv_catpv(namesv, unixname);
3254 if (PL_origfilename[0] &&
3255 PL_origfilename[1] == ':' &&
3256 !(dir[0] && dir[1] == ':'))
3257 Perl_sv_setpvf(aTHX_ namesv,
3262 Perl_sv_setpvf(aTHX_ namesv,
3266 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3270 TAINT_PROPER("require");
3271 tryname = SvPVX(namesv);
3272 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3274 if (tryname[0] == '.' && tryname[1] == '/')
3283 SAVECOPFILE_FREE(&PL_compiling);
3284 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3285 SvREFCNT_dec(namesv);
3287 if (PL_op->op_type == OP_REQUIRE) {
3288 char *msgstr = name;
3289 if (namesv) { /* did we lookup @INC? */
3290 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3291 SV *dirmsgsv = NEWSV(0, 0);
3292 AV *ar = GvAVn(PL_incgv);
3294 sv_catpvn(msg, " in @INC", 8);
3295 if (instr(SvPVX(msg), ".h "))
3296 sv_catpv(msg, " (change .h to .ph maybe?)");
3297 if (instr(SvPVX(msg), ".ph "))
3298 sv_catpv(msg, " (did you run h2ph?)");
3299 sv_catpv(msg, " (@INC contains:");
3300 for (i = 0; i <= AvFILL(ar); i++) {
3301 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3302 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3303 sv_catsv(msg, dirmsgsv);
3305 sv_catpvn(msg, ")", 1);
3306 SvREFCNT_dec(dirmsgsv);
3307 msgstr = SvPV_nolen(msg);
3309 DIE(aTHX_ "Can't locate %s", msgstr);
3315 SETERRNO(0, SS_NORMAL);
3317 /* Assume success here to prevent recursive requirement. */
3319 /* Check whether a hook in @INC has already filled %INC */
3320 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3321 (void)hv_store(GvHVn(PL_incgv), name, len,
3322 (hook_sv ? SvREFCNT_inc(hook_sv)
3323 : newSVpv(CopFILE(&PL_compiling), 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 *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;
3380 return pp_require();
3386 register PERL_CONTEXT *cx;
3388 I32 gimme = GIMME_V, was = PL_sub_generation;
3389 char tbuf[TYPE_DIGITS(long) + 12];
3390 char *tmpbuf = tbuf;
3399 TAINT_PROPER("eval");
3405 /* switch to eval mode */
3407 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3408 SV *sv = sv_newmortal();
3409 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3410 (unsigned long)++PL_evalseq,
3411 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3415 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3416 SAVECOPFILE_FREE(&PL_compiling);
3417 CopFILE_set(&PL_compiling, tmpbuf+2);
3418 SAVECOPLINE(&PL_compiling);
3419 CopLINE_set(&PL_compiling, 1);
3420 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3421 deleting the eval's FILEGV from the stash before gv_check() runs
3422 (i.e. before run-time proper). To work around the coredump that
3423 ensues, we always turn GvMULTI_on for any globals that were
3424 introduced within evals. See force_ident(). GSAR 96-10-12 */
3425 safestr = savepv(tmpbuf);
3426 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3428 PL_hints = PL_op->op_targ;
3429 SAVESPTR(PL_compiling.cop_warnings);
3430 if (specialWARN(PL_curcop->cop_warnings))
3431 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3433 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3434 SAVEFREESV(PL_compiling.cop_warnings);
3436 SAVESPTR(PL_compiling.cop_io);
3437 if (specialCopIO(PL_curcop->cop_io))
3438 PL_compiling.cop_io = PL_curcop->cop_io;
3440 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3441 SAVEFREESV(PL_compiling.cop_io);
3443 /* special case: an eval '' executed within the DB package gets lexically
3444 * placed in the first non-DB CV rather than the current CV - this
3445 * allows the debugger to execute code, find lexicals etc, in the
3446 * scope of the code being debugged. Passing &seq gets find_runcv
3447 * to do the dirty work for us */
3448 runcv = find_runcv(&seq);
3450 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3451 PUSHEVAL(cx, 0, Nullgv);
3452 cx->blk_eval.retop = PL_op->op_next;
3454 /* prepare to compile string */
3456 if (PERLDB_LINE && PL_curstash != PL_debstash)
3457 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3459 ret = doeval(gimme, NULL, runcv, seq);
3460 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3461 && ret != PL_op->op_next) { /* Successive compilation. */
3462 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3464 return DOCATCH(ret);
3474 register PERL_CONTEXT *cx;
3476 const U8 save_flags = PL_op -> op_flags;
3481 retop = cx->blk_eval.retop;
3484 if (gimme == G_VOID)
3486 else if (gimme == G_SCALAR) {
3489 if (SvFLAGS(TOPs) & SVs_TEMP)
3492 *MARK = sv_mortalcopy(TOPs);
3496 *MARK = &PL_sv_undef;
3501 /* in case LEAVE wipes old return values */
3502 for (mark = newsp + 1; mark <= SP; mark++) {
3503 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3504 *mark = sv_mortalcopy(*mark);
3505 TAINT_NOT; /* Each item is independent */
3509 PL_curpm = newpm; /* Don't pop $1 et al till now */
3512 assert(CvDEPTH(PL_compcv) == 1);
3514 CvDEPTH(PL_compcv) = 0;
3517 if (optype == OP_REQUIRE &&
3518 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3520 /* Unassume the success we assumed earlier. */
3521 SV *nsv = cx->blk_eval.old_namesv;
3522 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3523 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3524 /* die_where() did LEAVE, or we won't be here */
3528 if (!(save_flags & OPf_SPECIAL))
3538 register PERL_CONTEXT *cx;
3539 I32 gimme = GIMME_V;
3544 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3546 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3548 PL_in_eval = EVAL_INEVAL;
3551 return DOCATCH(PL_op->op_next);
3562 register PERL_CONTEXT *cx;
3567 retop = cx->blk_eval.retop;
3570 if (gimme == G_VOID)
3572 else if (gimme == G_SCALAR) {
3575 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3578 *MARK = sv_mortalcopy(TOPs);
3582 *MARK = &PL_sv_undef;
3587 /* in case LEAVE wipes old return values */
3588 for (mark = newsp + 1; mark <= SP; mark++) {
3589 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3590 *mark = sv_mortalcopy(*mark);
3591 TAINT_NOT; /* Each item is independent */
3595 PL_curpm = newpm; /* Don't pop $1 et al till now */
3603 S_doparseform(pTHX_ SV *sv)
3606 register char *s = SvPV_force(sv, len);
3607 register char *send = s + len;
3608 register char *base = Nullch;
3609 register I32 skipspaces = 0;
3610 bool noblank = FALSE;
3611 bool repeat = FALSE;
3612 bool postspace = FALSE;
3618 bool unchopnum = FALSE;
3619 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3622 Perl_croak(aTHX_ "Null picture in formline");
3624 /* estimate the buffer size needed */
3625 for (base = s; s <= send; s++) {
3626 if (*s == '\n' || *s == '@' || *s == '^')
3632 New(804, fops, maxops, U32);
3637 *fpc++ = FF_LINEMARK;
3638 noblank = repeat = FALSE;
3656 case ' ': case '\t':
3663 } /* else FALL THROUGH */
3671 *fpc++ = FF_LITERAL;
3679 *fpc++ = (U16)skipspaces;
3683 *fpc++ = FF_NEWLINE;
3687 arg = fpc - linepc + 1;
3694 *fpc++ = FF_LINEMARK;
3695 noblank = repeat = FALSE;
3704 ischop = s[-1] == '^';
3710 arg = (s - base) - 1;
3712 *fpc++ = FF_LITERAL;
3720 *fpc++ = 2; /* skip the @* or ^* */
3722 *fpc++ = FF_LINESNGL;
3725 *fpc++ = FF_LINEGLOB;
3727 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3728 arg = ischop ? 512 : 0;
3733 const char * const f = ++s;
3736 arg |= 256 + (s - f);
3738 *fpc++ = s - base; /* fieldsize for FETCH */
3739 *fpc++ = FF_DECIMAL;
3741 unchopnum |= ! ischop;
3743 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3744 arg = ischop ? 512 : 0;
3746 s++; /* skip the '0' first */
3750 const char * const f = ++s;
3753 arg |= 256 + (s - f);
3755 *fpc++ = s - base; /* fieldsize for FETCH */
3756 *fpc++ = FF_0DECIMAL;
3758 unchopnum |= ! ischop;
3762 bool ismore = FALSE;
3765 while (*++s == '>') ;
3766 prespace = FF_SPACE;
3768 else if (*s == '|') {
3769 while (*++s == '|') ;
3770 prespace = FF_HALFSPACE;
3775 while (*++s == '<') ;
3778 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3782 *fpc++ = s - base; /* fieldsize for FETCH */
3784 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3787 *fpc++ = (U16)prespace;
3801 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3803 { /* need to jump to the next word */
3805 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3806 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3807 s = SvPVX(sv) + SvCUR(sv) + z;
3809 Copy(fops, s, arg, U32);
3811 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3814 if (unchopnum && repeat)
3815 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3821 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3823 /* Can value be printed in fldsize chars, using %*.*f ? */
3827 int intsize = fldsize - (value < 0 ? 1 : 0);
3834 while (intsize--) pwr *= 10.0;
3835 while (frcsize--) eps /= 10.0;
3838 if (value + eps >= pwr)
3841 if (value - eps <= -pwr)
3848 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3851 SV *datasv = FILTER_DATA(idx);
3852 int filter_has_file = IoLINES(datasv);
3853 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3854 SV *filter_state = (SV *)IoTOP_GV(datasv);
3855 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3858 /* I was having segfault trouble under Linux 2.2.5 after a
3859 parse error occured. (Had to hack around it with a test
3860 for PL_error_count == 0.) Solaris doesn't segfault --
3861 not sure where the trouble is yet. XXX */
3863 if (filter_has_file) {
3864 len = FILTER_READ(idx+1, buf_sv, maxlen);
3867 if (filter_sub && len >= 0) {
3878 PUSHs(sv_2mortal(newSViv(maxlen)));
3880 PUSHs(filter_state);
3883 count = call_sv(filter_sub, G_SCALAR);
3899 IoLINES(datasv) = 0;
3900 if (filter_child_proc) {
3901 SvREFCNT_dec(filter_child_proc);
3902 IoFMT_GV(datasv) = Nullgv;
3905 SvREFCNT_dec(filter_state);
3906 IoTOP_GV(datasv) = Nullgv;
3909 SvREFCNT_dec(filter_sub);
3910 IoBOTTOM_GV(datasv) = Nullgv;
3912 filter_del(run_user_filter);
3918 /* perhaps someone can come up with a better name for
3919 this? it is not really "absolute", per se ... */
3921 S_path_is_absolute(pTHX_ const char *name)
3923 if (PERL_FILE_IS_ABSOLUTE(name)
3924 #ifdef MACOS_TRADITIONAL
3927 || (*name == '.' && (name[1] == '/' ||
3928 (name[1] == '.' && name[2] == '/'))))
3939 * c-indentation-style: bsd
3941 * indent-tabs-mode: t
3944 * vim: shiftwidth=4: