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 SvPVX(targ) = SvPVX(dstr);
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
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 *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)
1396 if (PL_in_eval & EVAL_KEEPERR) {
1397 static const char prefix[] = "\t(in cleanup) ";
1399 const char *e = Nullch;
1402 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1405 if (*e != *message || strNE(e,message))
1409 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1410 sv_catpvn(err, prefix, sizeof(prefix)-1);
1411 sv_catpvn(err, message, msglen);
1412 if (ckWARN(WARN_MISC)) {
1413 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1414 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1419 sv_setpvn(ERRSV, message, msglen);
1423 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1424 && PL_curstackinfo->si_prev)
1432 register PERL_CONTEXT *cx;
1434 if (cxix < cxstack_ix)
1437 POPBLOCK(cx,PL_curpm);
1438 if (CxTYPE(cx) != CXt_EVAL) {
1440 message = SvPVx(ERRSV, msglen);
1441 PerlIO_write(Perl_error_log, "panic: die ", 11);
1442 PerlIO_write(Perl_error_log, message, msglen);
1447 if (gimme == G_SCALAR)
1448 *++newsp = &PL_sv_undef;
1449 PL_stack_sp = newsp;
1453 /* LEAVE could clobber PL_curcop (see save_re_context())
1454 * XXX it might be better to find a way to avoid messing with
1455 * PL_curcop in save_re_context() instead, but this is a more
1456 * minimal fix --GSAR */
1457 PL_curcop = cx->blk_oldcop;
1459 if (optype == OP_REQUIRE) {
1460 const char* msg = SvPVx(ERRSV, n_a);
1461 SV *nsv = cx->blk_eval.old_namesv;
1462 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1464 DIE(aTHX_ "%sCompilation failed in require",
1465 *msg ? msg : "Unknown error\n");
1467 assert(CxTYPE(cx) == CXt_EVAL);
1468 return cx->blk_eval.retop;
1472 message = SvPVx(ERRSV, msglen);
1474 write_to_stderr(message, msglen);
1483 if (SvTRUE(left) != SvTRUE(right))
1495 RETURNOP(cLOGOP->op_other);
1504 RETURNOP(cLOGOP->op_other);
1513 if (!sv || !SvANY(sv)) {
1514 RETURNOP(cLOGOP->op_other);
1517 switch (SvTYPE(sv)) {
1519 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1523 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1527 if (CvROOT(sv) || CvXSUB(sv))
1537 RETURNOP(cLOGOP->op_other);
1543 register I32 cxix = dopoptosub(cxstack_ix);
1544 register PERL_CONTEXT *cx;
1545 register PERL_CONTEXT *ccstack = cxstack;
1546 PERL_SI *top_si = PL_curstackinfo;
1549 const char *stashname;
1557 /* we may be in a higher stacklevel, so dig down deeper */
1558 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1559 top_si = top_si->si_prev;
1560 ccstack = top_si->si_cxstack;
1561 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1564 if (GIMME != G_ARRAY) {
1570 if (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 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1584 cx = &ccstack[dbcxix];
1587 stashname = CopSTASHPV(cx->blk_oldcop);
1588 if (GIMME != G_ARRAY) {
1591 PUSHs(&PL_sv_undef);
1594 sv_setpv(TARG, stashname);
1603 PUSHs(&PL_sv_undef);
1605 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1606 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1607 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1610 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1611 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1612 /* So is ccstack[dbcxix]. */
1615 gv_efullname3(sv, cvgv, Nullch);
1616 PUSHs(sv_2mortal(sv));
1617 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1620 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1621 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1625 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1626 PUSHs(sv_2mortal(newSViv(0)));
1628 gimme = (I32)cx->blk_gimme;
1629 if (gimme == G_VOID)
1630 PUSHs(&PL_sv_undef);
1632 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1633 if (CxTYPE(cx) == CXt_EVAL) {
1635 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1636 PUSHs(cx->blk_eval.cur_text);
1640 else if (cx->blk_eval.old_namesv) {
1641 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1644 /* eval BLOCK (try blocks have old_namesv == 0) */
1646 PUSHs(&PL_sv_undef);
1647 PUSHs(&PL_sv_undef);
1651 PUSHs(&PL_sv_undef);
1652 PUSHs(&PL_sv_undef);
1654 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1655 && CopSTASH_eq(PL_curcop, PL_debstash))
1657 AV *ary = cx->blk_sub.argarray;
1658 const int off = AvARRAY(ary) - AvALLOC(ary);
1662 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1665 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1668 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1669 av_extend(PL_dbargs, AvFILLp(ary) + off);
1670 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1671 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1673 /* XXX only hints propagated via op_private are currently
1674 * visible (others are not easily accessible, since they
1675 * use the global PL_hints) */
1676 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1677 HINT_PRIVATE_MASK)));
1680 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1682 if (old_warnings == pWARN_NONE ||
1683 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1684 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1685 else if (old_warnings == pWARN_ALL ||
1686 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1687 /* Get the bit mask for $warnings::Bits{all}, because
1688 * it could have been extended by warnings::register */
1690 HV *bits = get_hv("warnings::Bits", FALSE);
1691 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1692 mask = newSVsv(*bits_all);
1695 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1699 mask = newSVsv(old_warnings);
1700 PUSHs(sv_2mortal(mask));
1715 sv_reset(tmps, CopSTASH(PL_curcop));
1725 /* like pp_nextstate, but used instead when the debugger is active */
1729 PL_curcop = (COP*)PL_op;
1730 TAINT_NOT; /* Each statement is presumed innocent */
1731 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1734 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1735 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1739 register PERL_CONTEXT *cx;
1740 I32 gimme = G_ARRAY;
1747 DIE(aTHX_ "No DB::DB routine defined");
1749 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1750 /* don't do recursive DB::DB call */
1762 PUSHBLOCK(cx, CXt_SUB, SP);
1764 cx->blk_sub.retop = PL_op->op_next;
1766 PAD_SET_CUR(CvPADLIST(cv),1);
1767 RETURNOP(CvSTART(cv));
1781 register PERL_CONTEXT *cx;
1782 I32 gimme = GIMME_V;
1784 U32 cxtype = CXt_LOOP;
1792 if (PL_op->op_targ) {
1793 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1794 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1795 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1796 SVs_PADSTALE, SVs_PADSTALE);
1798 #ifndef USE_ITHREADS
1799 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1802 SAVEPADSV(PL_op->op_targ);
1803 iterdata = INT2PTR(void*, PL_op->op_targ);
1804 cxtype |= CXp_PADVAR;
1809 svp = &GvSV(gv); /* symbol table variable */
1810 SAVEGENERICSV(*svp);
1813 iterdata = (void*)gv;
1819 PUSHBLOCK(cx, cxtype, SP);
1821 PUSHLOOP(cx, iterdata, MARK);
1823 PUSHLOOP(cx, svp, MARK);
1825 if (PL_op->op_flags & OPf_STACKED) {
1826 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1827 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1829 SV *right = (SV*)cx->blk_loop.iterary;
1830 if (RANGE_IS_NUMERIC(sv,right)) {
1831 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1832 (SvOK(right) && SvNV(right) >= IV_MAX))
1833 DIE(aTHX_ "Range iterator outside integer range");
1834 cx->blk_loop.iterix = SvIV(sv);
1835 cx->blk_loop.itermax = SvIV(right);
1839 cx->blk_loop.iterlval = newSVsv(sv);
1840 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1841 (void) SvPV(right,n_a);
1844 else if (PL_op->op_private & OPpITER_REVERSED) {
1845 cx->blk_loop.itermax = -1;
1846 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1851 cx->blk_loop.iterary = PL_curstack;
1852 AvFILLp(PL_curstack) = SP - PL_stack_base;
1853 if (PL_op->op_private & OPpITER_REVERSED) {
1854 cx->blk_loop.itermax = MARK - PL_stack_base;
1855 cx->blk_loop.iterix = cx->blk_oldsp;
1858 cx->blk_loop.iterix = MARK - PL_stack_base;
1868 register PERL_CONTEXT *cx;
1869 I32 gimme = GIMME_V;
1875 PUSHBLOCK(cx, CXt_LOOP, SP);
1876 PUSHLOOP(cx, 0, SP);
1884 register PERL_CONTEXT *cx;
1892 newsp = PL_stack_base + cx->blk_loop.resetsp;
1895 if (gimme == G_VOID)
1897 else if (gimme == G_SCALAR) {
1899 *++newsp = sv_mortalcopy(*SP);
1901 *++newsp = &PL_sv_undef;
1905 *++newsp = sv_mortalcopy(*++mark);
1906 TAINT_NOT; /* Each item is independent */
1912 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1913 PL_curpm = newpm; /* ... and pop $1 et al */
1925 register PERL_CONTEXT *cx;
1926 bool popsub2 = FALSE;
1927 bool clear_errsv = FALSE;
1935 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1936 if (cxstack_ix == PL_sortcxix
1937 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1939 if (cxstack_ix > PL_sortcxix)
1940 dounwind(PL_sortcxix);
1941 AvARRAY(PL_curstack)[1] = *SP;
1942 PL_stack_sp = PL_stack_base + 1;
1947 cxix = dopoptosub(cxstack_ix);
1949 DIE(aTHX_ "Can't return outside a subroutine");
1950 if (cxix < cxstack_ix)
1954 switch (CxTYPE(cx)) {
1957 retop = cx->blk_sub.retop;
1958 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1961 if (!(PL_in_eval & EVAL_KEEPERR))
1964 retop = cx->blk_eval.retop;
1968 if (optype == OP_REQUIRE &&
1969 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1971 /* Unassume the success we assumed earlier. */
1972 SV *nsv = cx->blk_eval.old_namesv;
1973 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1974 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1979 retop = cx->blk_sub.retop;
1982 DIE(aTHX_ "panic: return");
1986 if (gimme == G_SCALAR) {
1989 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1991 *++newsp = SvREFCNT_inc(*SP);
1996 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1998 *++newsp = sv_mortalcopy(sv);
2003 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2006 *++newsp = sv_mortalcopy(*SP);
2009 *++newsp = &PL_sv_undef;
2011 else if (gimme == G_ARRAY) {
2012 while (++MARK <= SP) {
2013 *++newsp = (popsub2 && SvTEMP(*MARK))
2014 ? *MARK : sv_mortalcopy(*MARK);
2015 TAINT_NOT; /* Each item is independent */
2018 PL_stack_sp = newsp;
2021 /* Stack values are safe: */
2024 POPSUB(cx,sv); /* release CV and @_ ... */
2028 PL_curpm = newpm; /* ... and pop $1 et al */
2040 register PERL_CONTEXT *cx;
2050 if (PL_op->op_flags & OPf_SPECIAL) {
2051 cxix = dopoptoloop(cxstack_ix);
2053 DIE(aTHX_ "Can't \"last\" outside a loop block");
2056 cxix = dopoptolabel(cPVOP->op_pv);
2058 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2060 if (cxix < cxstack_ix)
2064 cxstack_ix++; /* temporarily protect top context */
2066 switch (CxTYPE(cx)) {
2069 newsp = PL_stack_base + cx->blk_loop.resetsp;
2070 nextop = cx->blk_loop.last_op->op_next;
2074 nextop = cx->blk_sub.retop;
2078 nextop = cx->blk_eval.retop;
2082 nextop = cx->blk_sub.retop;
2085 DIE(aTHX_ "panic: last");
2089 if (gimme == G_SCALAR) {
2091 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2092 ? *SP : sv_mortalcopy(*SP);
2094 *++newsp = &PL_sv_undef;
2096 else if (gimme == G_ARRAY) {
2097 while (++MARK <= SP) {
2098 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2099 ? *MARK : sv_mortalcopy(*MARK);
2100 TAINT_NOT; /* Each item is independent */
2108 /* Stack values are safe: */
2111 POPLOOP(cx); /* release loop vars ... */
2115 POPSUB(cx,sv); /* release CV and @_ ... */
2118 PL_curpm = newpm; /* ... and pop $1 et al */
2127 register PERL_CONTEXT *cx;
2130 if (PL_op->op_flags & OPf_SPECIAL) {
2131 cxix = dopoptoloop(cxstack_ix);
2133 DIE(aTHX_ "Can't \"next\" outside a loop block");
2136 cxix = dopoptolabel(cPVOP->op_pv);
2138 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2140 if (cxix < cxstack_ix)
2143 /* clear off anything above the scope we're re-entering, but
2144 * save the rest until after a possible continue block */
2145 inner = PL_scopestack_ix;
2147 if (PL_scopestack_ix < inner)
2148 leave_scope(PL_scopestack[PL_scopestack_ix]);
2149 return cx->blk_loop.next_op;
2155 register PERL_CONTEXT *cx;
2158 if (PL_op->op_flags & OPf_SPECIAL) {
2159 cxix = dopoptoloop(cxstack_ix);
2161 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2164 cxix = dopoptolabel(cPVOP->op_pv);
2166 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2168 if (cxix < cxstack_ix)
2172 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2173 LEAVE_SCOPE(oldsave);
2175 return cx->blk_loop.redo_op;
2179 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2183 static const char too_deep[] = "Target of goto is too deeply nested";
2186 Perl_croak(aTHX_ too_deep);
2187 if (o->op_type == OP_LEAVE ||
2188 o->op_type == OP_SCOPE ||
2189 o->op_type == OP_LEAVELOOP ||
2190 o->op_type == OP_LEAVESUB ||
2191 o->op_type == OP_LEAVETRY)
2193 *ops++ = cUNOPo->op_first;
2195 Perl_croak(aTHX_ too_deep);
2198 if (o->op_flags & OPf_KIDS) {
2199 /* First try all the kids at this level, since that's likeliest. */
2200 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2201 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2202 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2205 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2206 if (kid == PL_lastgotoprobe)
2208 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2211 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2212 ops[-1]->op_type == OP_DBSTATE)
2217 if ((o = dofindlabel(kid, label, ops, oplimit)))
2236 register PERL_CONTEXT *cx;
2237 #define GOTO_DEPTH 64
2238 OP *enterops[GOTO_DEPTH];
2239 const char *label = 0;
2240 const bool do_dump = (PL_op->op_type == OP_DUMP);
2241 static const char must_have_label[] = "goto must have label";
2243 if (PL_op->op_flags & OPf_STACKED) {
2247 /* This egregious kludge implements goto &subroutine */
2248 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2250 register PERL_CONTEXT *cx;
2251 CV* cv = (CV*)SvRV(sv);
2258 if (!CvROOT(cv) && !CvXSUB(cv)) {
2259 const GV * const gv = CvGV(cv);
2263 /* autoloaded stub? */
2264 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2266 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2267 GvNAMELEN(gv), FALSE);
2268 if (autogv && (cv = GvCV(autogv)))
2270 tmpstr = sv_newmortal();
2271 gv_efullname3(tmpstr, gv, Nullch);
2272 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2274 DIE(aTHX_ "Goto undefined subroutine");
2277 /* First do some returnish stuff. */
2278 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2280 cxix = dopoptosub(cxstack_ix);
2282 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2283 if (cxix < cxstack_ix)
2287 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2288 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2289 /* put @_ back onto stack */
2290 AV* av = cx->blk_sub.argarray;
2292 items = AvFILLp(av) + 1;
2293 EXTEND(SP, items+1); /* @_ could have been extended. */
2294 Copy(AvARRAY(av), SP + 1, items, SV*);
2295 SvREFCNT_dec(GvAV(PL_defgv));
2296 GvAV(PL_defgv) = cx->blk_sub.savearray;
2298 /* abandon @_ if it got reified */
2303 av_extend(av, items-1);
2304 AvFLAGS(av) = AVf_REIFY;
2305 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2308 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2310 av = GvAV(PL_defgv);
2311 items = AvFILLp(av) + 1;
2312 EXTEND(SP, items+1); /* @_ could have been extended. */
2313 Copy(AvARRAY(av), SP + 1, items, SV*);
2317 if (CxTYPE(cx) == CXt_SUB &&
2318 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2319 SvREFCNT_dec(cx->blk_sub.cv);
2320 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2321 LEAVE_SCOPE(oldsave);
2323 /* Now do some callish stuff. */
2325 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2329 for (index=0; index<items; index++)
2330 sv_2mortal(SP[-index]);
2332 #ifdef PERL_XSUB_OLDSTYLE
2333 if (CvOLDSTYLE(cv)) {
2334 I32 (*fp3)(int,int,int);
2339 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2340 items = (*fp3)(CvXSUBANY(cv).any_i32,
2341 mark - PL_stack_base + 1,
2343 SP = PL_stack_base + items;
2346 #endif /* PERL_XSUB_OLDSTYLE */
2351 /* Push a mark for the start of arglist */
2354 (void)(*CvXSUB(cv))(aTHX_ cv);
2355 /* Pop the current context like a decent sub should */
2356 POPBLOCK(cx, PL_curpm);
2357 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2360 assert(CxTYPE(cx) == CXt_SUB);
2361 return cx->blk_sub.retop;
2364 AV* padlist = CvPADLIST(cv);
2365 if (CxTYPE(cx) == CXt_EVAL) {
2366 PL_in_eval = cx->blk_eval.old_in_eval;
2367 PL_eval_root = cx->blk_eval.old_eval_root;
2368 cx->cx_type = CXt_SUB;
2369 cx->blk_sub.hasargs = 0;
2371 cx->blk_sub.cv = cv;
2372 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2375 if (CvDEPTH(cv) < 2)
2376 (void)SvREFCNT_inc(cv);
2378 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2379 sub_crush_depth(cv);
2380 pad_push(padlist, CvDEPTH(cv));
2382 PAD_SET_CUR(padlist, CvDEPTH(cv));
2383 if (cx->blk_sub.hasargs)
2385 AV* av = (AV*)PAD_SVl(0);
2388 cx->blk_sub.savearray = GvAV(PL_defgv);
2389 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2390 CX_CURPAD_SAVE(cx->blk_sub);
2391 cx->blk_sub.argarray = av;
2393 if (items >= AvMAX(av) + 1) {
2395 if (AvARRAY(av) != ary) {
2396 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2397 SvPVX(av) = (char*)ary;
2399 if (items >= AvMAX(av) + 1) {
2400 AvMAX(av) = items - 1;
2401 Renew(ary,items+1,SV*);
2403 SvPVX(av) = (char*)ary;
2407 Copy(mark,AvARRAY(av),items,SV*);
2408 AvFILLp(av) = items - 1;
2409 assert(!AvREAL(av));
2411 /* transfer 'ownership' of refcnts to new @_ */
2421 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2423 * We do not care about using sv to call CV;
2424 * it's for informational purposes only.
2426 SV *sv = GvSV(PL_DBsub);
2429 if (PERLDB_SUB_NN) {
2430 (void)SvUPGRADE(sv, SVt_PVIV);
2433 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2436 gv_efullname3(sv, CvGV(cv), Nullch);
2439 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2440 PUSHMARK( PL_stack_sp );
2441 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2445 RETURNOP(CvSTART(cv));
2449 label = SvPV(sv,n_a);
2450 if (!(do_dump || *label))
2451 DIE(aTHX_ must_have_label);
2454 else if (PL_op->op_flags & OPf_SPECIAL) {
2456 DIE(aTHX_ must_have_label);
2459 label = cPVOP->op_pv;
2461 if (label && *label) {
2463 bool leaving_eval = FALSE;
2464 bool in_block = FALSE;
2465 PERL_CONTEXT *last_eval_cx = 0;
2469 PL_lastgotoprobe = 0;
2471 for (ix = cxstack_ix; ix >= 0; ix--) {
2473 switch (CxTYPE(cx)) {
2475 leaving_eval = TRUE;
2476 if (!CxTRYBLOCK(cx)) {
2477 gotoprobe = (last_eval_cx ?
2478 last_eval_cx->blk_eval.old_eval_root :
2483 /* else fall through */
2485 gotoprobe = cx->blk_oldcop->op_sibling;
2491 gotoprobe = cx->blk_oldcop->op_sibling;
2494 gotoprobe = PL_main_root;
2497 if (CvDEPTH(cx->blk_sub.cv)) {
2498 gotoprobe = CvROOT(cx->blk_sub.cv);
2504 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2507 DIE(aTHX_ "panic: goto");
2508 gotoprobe = PL_main_root;
2512 retop = dofindlabel(gotoprobe, label,
2513 enterops, enterops + GOTO_DEPTH);
2517 PL_lastgotoprobe = gotoprobe;
2520 DIE(aTHX_ "Can't find label %s", label);
2522 /* if we're leaving an eval, check before we pop any frames
2523 that we're not going to punt, otherwise the error
2526 if (leaving_eval && *enterops && enterops[1]) {
2528 for (i = 1; enterops[i]; i++)
2529 if (enterops[i]->op_type == OP_ENTERITER)
2530 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2533 /* pop unwanted frames */
2535 if (ix < cxstack_ix) {
2542 oldsave = PL_scopestack[PL_scopestack_ix];
2543 LEAVE_SCOPE(oldsave);
2546 /* push wanted frames */
2548 if (*enterops && enterops[1]) {
2550 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2551 for (; enterops[ix]; ix++) {
2552 PL_op = enterops[ix];
2553 /* Eventually we may want to stack the needed arguments
2554 * for each op. For now, we punt on the hard ones. */
2555 if (PL_op->op_type == OP_ENTERITER)
2556 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2557 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2565 if (!retop) retop = PL_main_start;
2567 PL_restartop = retop;
2568 PL_do_undump = TRUE;
2572 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2573 PL_do_undump = FALSE;
2589 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2591 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2594 PL_exit_flags |= PERL_EXIT_EXPECTED;
2596 PUSHs(&PL_sv_undef);
2604 NV value = SvNVx(GvSV(cCOP->cop_gv));
2605 register I32 match = I_32(value);
2608 if (((NV)match) > value)
2609 --match; /* was fractional--truncate other way */
2611 match -= cCOP->uop.scop.scop_offset;
2614 else if (match > cCOP->uop.scop.scop_max)
2615 match = cCOP->uop.scop.scop_max;
2616 PL_op = cCOP->uop.scop.scop_next[match];
2626 PL_op = PL_op->op_next; /* can't assume anything */
2629 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2630 match -= cCOP->uop.scop.scop_offset;
2633 else if (match > cCOP->uop.scop.scop_max)
2634 match = cCOP->uop.scop.scop_max;
2635 PL_op = cCOP->uop.scop.scop_next[match];
2644 S_save_lines(pTHX_ AV *array, SV *sv)
2646 register const char *s = SvPVX(sv);
2647 register const char *send = SvPVX(sv) + SvCUR(sv);
2648 register const char *t;
2649 register I32 line = 1;
2651 while (s && s < send) {
2652 SV *tmpstr = NEWSV(85,0);
2654 sv_upgrade(tmpstr, SVt_PVMG);
2655 t = strchr(s, '\n');
2661 sv_setpvn(tmpstr, s, t - s);
2662 av_store(array, line++, tmpstr);
2668 S_docatch_body(pTHX)
2675 S_docatch(pTHX_ OP *o)
2678 OP * const oldop = PL_op;
2680 volatile PERL_SI *cursi = PL_curstackinfo;
2684 assert(CATCH_GET == TRUE);
2688 /* Normally, the leavetry at the end of this block of ops will
2689 * pop an op off the return stack and continue there. By setting
2690 * the op to Nullop, we force an exit from the inner runops()
2693 assert(cxstack_ix >= 0);
2694 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2695 retop = cxstack[cxstack_ix].blk_eval.retop;
2696 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2705 /* die caught by an inner eval - continue inner loop */
2706 if (PL_restartop && cursi == PL_curstackinfo) {
2707 PL_op = PL_restartop;
2711 /* a die in this eval - continue in outer loop */
2727 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2728 /* sv Text to convert to OP tree. */
2729 /* startop op_free() this to undo. */
2730 /* code Short string id of the caller. */
2732 dSP; /* Make POPBLOCK work. */
2735 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2739 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2740 char *tmpbuf = tbuf;
2743 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2748 /* switch to eval mode */
2750 if (IN_PERL_COMPILETIME) {
2751 SAVECOPSTASH_FREE(&PL_compiling);
2752 CopSTASH_set(&PL_compiling, PL_curstash);
2754 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2755 SV *sv = sv_newmortal();
2756 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2757 code, (unsigned long)++PL_evalseq,
2758 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2762 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2763 SAVECOPFILE_FREE(&PL_compiling);
2764 CopFILE_set(&PL_compiling, tmpbuf+2);
2765 SAVECOPLINE(&PL_compiling);
2766 CopLINE_set(&PL_compiling, 1);
2767 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2768 deleting the eval's FILEGV from the stash before gv_check() runs
2769 (i.e. before run-time proper). To work around the coredump that
2770 ensues, we always turn GvMULTI_on for any globals that were
2771 introduced within evals. See force_ident(). GSAR 96-10-12 */
2772 safestr = savepv(tmpbuf);
2773 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2775 #ifdef OP_IN_REGISTER
2781 /* we get here either during compilation, or via pp_regcomp at runtime */
2782 runtime = IN_PERL_RUNTIME;
2784 runcv = find_runcv(NULL);
2787 PL_op->op_type = OP_ENTEREVAL;
2788 PL_op->op_flags = 0; /* Avoid uninit warning. */
2789 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2790 PUSHEVAL(cx, 0, Nullgv);
2793 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2795 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2796 POPBLOCK(cx,PL_curpm);
2799 (*startop)->op_type = OP_NULL;
2800 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2802 /* XXX DAPM do this properly one year */
2803 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2805 if (IN_PERL_COMPILETIME)
2806 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2807 #ifdef OP_IN_REGISTER
2815 =for apidoc find_runcv
2817 Locate the CV corresponding to the currently executing sub or eval.
2818 If db_seqp is non_null, skip CVs that are in the DB package and populate
2819 *db_seqp with the cop sequence number at the point that the DB:: code was
2820 entered. (allows debuggers to eval in the scope of the breakpoint rather
2821 than in in the scope of the debugger itself).
2827 Perl_find_runcv(pTHX_ U32 *db_seqp)
2832 *db_seqp = PL_curcop->cop_seq;
2833 for (si = PL_curstackinfo; si; si = si->si_prev) {
2835 for (ix = si->si_cxix; ix >= 0; ix--) {
2836 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2837 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2838 CV *cv = cx->blk_sub.cv;
2839 /* skip DB:: code */
2840 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2841 *db_seqp = cx->blk_oldcop->cop_seq;
2846 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2854 /* Compile a require/do, an eval '', or a /(?{...})/.
2855 * In the last case, startop is non-null, and contains the address of
2856 * a pointer that should be set to the just-compiled code.
2857 * outside is the lexically enclosing CV (if any) that invoked us.
2860 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2862 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2867 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2868 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2873 SAVESPTR(PL_compcv);
2874 PL_compcv = (CV*)NEWSV(1104,0);
2875 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2876 CvEVAL_on(PL_compcv);
2877 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2878 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2880 CvOUTSIDE_SEQ(PL_compcv) = seq;
2881 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2883 /* set up a scratch pad */
2885 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2888 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2890 /* make sure we compile in the right package */
2892 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2893 SAVESPTR(PL_curstash);
2894 PL_curstash = CopSTASH(PL_curcop);
2896 SAVESPTR(PL_beginav);
2897 PL_beginav = newAV();
2898 SAVEFREESV(PL_beginav);
2899 SAVEI32(PL_error_count);
2901 /* try to compile it */
2903 PL_eval_root = Nullop;
2905 PL_curcop = &PL_compiling;
2906 PL_curcop->cop_arybase = 0;
2907 if (saveop && saveop->op_flags & OPf_SPECIAL)
2908 PL_in_eval |= EVAL_KEEPERR;
2911 if (yyparse() || PL_error_count || !PL_eval_root) {
2912 SV **newsp; /* Used by POPBLOCK. */
2913 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2914 I32 optype = 0; /* Might be reset by POPEVAL. */
2919 op_free(PL_eval_root);
2920 PL_eval_root = Nullop;
2922 SP = PL_stack_base + POPMARK; /* pop original mark */
2924 POPBLOCK(cx,PL_curpm);
2929 if (optype == OP_REQUIRE) {
2930 const char* msg = SvPVx(ERRSV, n_a);
2931 SV *nsv = cx->blk_eval.old_namesv;
2932 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2934 DIE(aTHX_ "%sCompilation failed in require",
2935 *msg ? msg : "Unknown error\n");
2938 const char* msg = SvPVx(ERRSV, n_a);
2940 POPBLOCK(cx,PL_curpm);
2942 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2943 (*msg ? msg : "Unknown error\n"));
2946 const char* msg = SvPVx(ERRSV, n_a);
2948 sv_setpv(ERRSV, "Compilation error");
2953 CopLINE_set(&PL_compiling, 0);
2955 *startop = PL_eval_root;
2957 SAVEFREEOP(PL_eval_root);
2959 /* Set the context for this new optree.
2960 * If the last op is an OP_REQUIRE, force scalar context.
2961 * Otherwise, propagate the context from the eval(). */
2962 if (PL_eval_root->op_type == OP_LEAVEEVAL
2963 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2964 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2966 scalar(PL_eval_root);
2967 else if (gimme & G_VOID)
2968 scalarvoid(PL_eval_root);
2969 else if (gimme & G_ARRAY)
2972 scalar(PL_eval_root);
2974 DEBUG_x(dump_eval());
2976 /* Register with debugger: */
2977 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2978 CV *cv = get_cv("DB::postponed", FALSE);
2982 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2984 call_sv((SV*)cv, G_DISCARD);
2988 /* compiled okay, so do it */
2990 CvDEPTH(PL_compcv) = 1;
2991 SP = PL_stack_base + POPMARK; /* pop original mark */
2992 PL_op = saveop; /* The caller may need it. */
2993 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2995 RETURNOP(PL_eval_start);
2999 S_doopen_pm(pTHX_ const char *name, const char *mode)
3001 #ifndef PERL_DISABLE_PMC
3002 STRLEN namelen = strlen(name);
3005 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3006 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3007 const char * const pmc = SvPV_nolen(pmcsv);
3010 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3011 fp = PerlIO_open(name, mode);
3014 if (PerlLIO_stat(name, &pmstat) < 0 ||
3015 pmstat.st_mtime < pmcstat.st_mtime)
3017 fp = PerlIO_open(pmc, mode);
3020 fp = PerlIO_open(name, mode);
3023 SvREFCNT_dec(pmcsv);
3026 fp = PerlIO_open(name, mode);
3030 return PerlIO_open(name, mode);
3031 #endif /* !PERL_DISABLE_PMC */
3037 register PERL_CONTEXT *cx;
3041 char *tryname = Nullch;
3042 SV *namesv = Nullsv;
3044 I32 gimme = GIMME_V;
3045 PerlIO *tryrsfp = 0;
3047 int filter_has_file = 0;
3048 GV *filter_child_proc = 0;
3049 SV *filter_state = 0;
3056 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3057 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3058 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3059 "v-string in use/require non-portable");
3061 sv = new_version(sv);
3062 if (!sv_derived_from(PL_patchlevel, "version"))
3063 (void *)upg_version(PL_patchlevel);
3064 if ( vcmp(sv,PL_patchlevel) > 0 )
3065 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3066 vstringify(sv), vstringify(PL_patchlevel));
3070 name = SvPV(sv, len);
3071 if (!(name && len > 0 && *name))
3072 DIE(aTHX_ "Null filename used");
3073 TAINT_PROPER("require");
3074 if (PL_op->op_type == OP_REQUIRE &&
3075 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3076 if (*svp != &PL_sv_undef)
3079 DIE(aTHX_ "Compilation failed in require");
3082 /* prepare to compile file */
3084 if (path_is_absolute(name)) {
3086 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3088 #ifdef MACOS_TRADITIONAL
3092 MacPerl_CanonDir(name, newname, 1);
3093 if (path_is_absolute(newname)) {
3095 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3100 AV *ar = GvAVn(PL_incgv);
3104 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3107 namesv = NEWSV(806, 0);
3108 for (i = 0; i <= AvFILL(ar); i++) {
3109 SV *dirsv = *av_fetch(ar, i, TRUE);
3115 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3116 && !sv_isobject(loader))
3118 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3121 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3122 PTR2UV(SvRV(dirsv)), name);
3123 tryname = SvPVX(namesv);
3134 if (sv_isobject(loader))
3135 count = call_method("INC", G_ARRAY);
3137 count = call_sv(loader, G_ARRAY);
3147 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3151 if (SvTYPE(arg) == SVt_PVGV) {
3152 IO *io = GvIO((GV *)arg);
3157 tryrsfp = IoIFP(io);
3158 if (IoTYPE(io) == IoTYPE_PIPE) {
3159 /* reading from a child process doesn't
3160 nest -- when returning from reading
3161 the inner module, the outer one is
3162 unreadable (closed?) I've tried to
3163 save the gv to manage the lifespan of
3164 the pipe, but this didn't help. XXX */
3165 filter_child_proc = (GV *)arg;
3166 (void)SvREFCNT_inc(filter_child_proc);
3169 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3170 PerlIO_close(IoOFP(io));
3182 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3184 (void)SvREFCNT_inc(filter_sub);
3187 filter_state = SP[i];
3188 (void)SvREFCNT_inc(filter_state);
3192 tryrsfp = PerlIO_open("/dev/null",
3208 filter_has_file = 0;
3209 if (filter_child_proc) {
3210 SvREFCNT_dec(filter_child_proc);
3211 filter_child_proc = 0;
3214 SvREFCNT_dec(filter_state);
3218 SvREFCNT_dec(filter_sub);
3223 if (!path_is_absolute(name)
3224 #ifdef MACOS_TRADITIONAL
3225 /* We consider paths of the form :a:b ambiguous and interpret them first
3226 as global then as local
3228 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3231 char *dir = SvPVx(dirsv, n_a);
3232 #ifdef MACOS_TRADITIONAL
3236 MacPerl_CanonDir(name, buf2, 1);
3237 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3241 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3243 sv_setpv(namesv, unixdir);
3244 sv_catpv(namesv, unixname);
3246 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3249 TAINT_PROPER("require");
3250 tryname = SvPVX(namesv);
3251 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3253 if (tryname[0] == '.' && tryname[1] == '/')
3262 SAVECOPFILE_FREE(&PL_compiling);
3263 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3264 SvREFCNT_dec(namesv);
3266 if (PL_op->op_type == OP_REQUIRE) {
3267 char *msgstr = name;
3268 if (namesv) { /* did we lookup @INC? */
3269 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3270 SV *dirmsgsv = NEWSV(0, 0);
3271 AV *ar = GvAVn(PL_incgv);
3273 sv_catpvn(msg, " in @INC", 8);
3274 if (instr(SvPVX(msg), ".h "))
3275 sv_catpv(msg, " (change .h to .ph maybe?)");
3276 if (instr(SvPVX(msg), ".ph "))
3277 sv_catpv(msg, " (did you run h2ph?)");
3278 sv_catpv(msg, " (@INC contains:");
3279 for (i = 0; i <= AvFILL(ar); i++) {
3280 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3281 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3282 sv_catsv(msg, dirmsgsv);
3284 sv_catpvn(msg, ")", 1);
3285 SvREFCNT_dec(dirmsgsv);
3286 msgstr = SvPV_nolen(msg);
3288 DIE(aTHX_ "Can't locate %s", msgstr);
3294 SETERRNO(0, SS_NORMAL);
3296 /* Assume success here to prevent recursive requirement. */
3298 /* Check whether a hook in @INC has already filled %INC */
3299 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3300 (void)hv_store(GvHVn(PL_incgv), name, len,
3301 (hook_sv ? SvREFCNT_inc(hook_sv)
3302 : newSVpv(CopFILE(&PL_compiling), 0)),
3308 lex_start(sv_2mortal(newSVpvn("",0)));
3309 SAVEGENERICSV(PL_rsfp_filters);
3310 PL_rsfp_filters = Nullav;
3315 SAVESPTR(PL_compiling.cop_warnings);
3316 if (PL_dowarn & G_WARN_ALL_ON)
3317 PL_compiling.cop_warnings = pWARN_ALL ;
3318 else if (PL_dowarn & G_WARN_ALL_OFF)
3319 PL_compiling.cop_warnings = pWARN_NONE ;
3320 else if (PL_taint_warn)
3321 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3323 PL_compiling.cop_warnings = pWARN_STD ;
3324 SAVESPTR(PL_compiling.cop_io);
3325 PL_compiling.cop_io = Nullsv;
3327 if (filter_sub || filter_child_proc) {
3328 SV *datasv = filter_add(run_user_filter, Nullsv);
3329 IoLINES(datasv) = filter_has_file;
3330 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3331 IoTOP_GV(datasv) = (GV *)filter_state;
3332 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3335 /* switch to eval mode */
3336 PUSHBLOCK(cx, CXt_EVAL, SP);
3337 PUSHEVAL(cx, name, Nullgv);
3338 cx->blk_eval.retop = PL_op->op_next;
3340 SAVECOPLINE(&PL_compiling);
3341 CopLINE_set(&PL_compiling, 0);
3345 /* Store and reset encoding. */
3346 encoding = PL_encoding;
3347 PL_encoding = Nullsv;
3349 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3351 /* Restore encoding. */
3352 PL_encoding = encoding;
3359 return pp_require();
3365 register PERL_CONTEXT *cx;
3367 I32 gimme = GIMME_V, was = PL_sub_generation;
3368 char tbuf[TYPE_DIGITS(long) + 12];
3369 char *tmpbuf = tbuf;
3378 TAINT_PROPER("eval");
3384 /* switch to eval mode */
3386 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3387 SV *sv = sv_newmortal();
3388 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3389 (unsigned long)++PL_evalseq,
3390 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3394 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3395 SAVECOPFILE_FREE(&PL_compiling);
3396 CopFILE_set(&PL_compiling, tmpbuf+2);
3397 SAVECOPLINE(&PL_compiling);
3398 CopLINE_set(&PL_compiling, 1);
3399 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3400 deleting the eval's FILEGV from the stash before gv_check() runs
3401 (i.e. before run-time proper). To work around the coredump that
3402 ensues, we always turn GvMULTI_on for any globals that were
3403 introduced within evals. See force_ident(). GSAR 96-10-12 */
3404 safestr = savepv(tmpbuf);
3405 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3407 PL_hints = PL_op->op_targ;
3408 SAVESPTR(PL_compiling.cop_warnings);
3409 if (specialWARN(PL_curcop->cop_warnings))
3410 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3412 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3413 SAVEFREESV(PL_compiling.cop_warnings);
3415 SAVESPTR(PL_compiling.cop_io);
3416 if (specialCopIO(PL_curcop->cop_io))
3417 PL_compiling.cop_io = PL_curcop->cop_io;
3419 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3420 SAVEFREESV(PL_compiling.cop_io);
3422 /* special case: an eval '' executed within the DB package gets lexically
3423 * placed in the first non-DB CV rather than the current CV - this
3424 * allows the debugger to execute code, find lexicals etc, in the
3425 * scope of the code being debugged. Passing &seq gets find_runcv
3426 * to do the dirty work for us */
3427 runcv = find_runcv(&seq);
3429 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3430 PUSHEVAL(cx, 0, Nullgv);
3431 cx->blk_eval.retop = PL_op->op_next;
3433 /* prepare to compile string */
3435 if (PERLDB_LINE && PL_curstash != PL_debstash)
3436 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3438 ret = doeval(gimme, NULL, runcv, seq);
3439 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3440 && ret != PL_op->op_next) { /* Successive compilation. */
3441 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3443 return DOCATCH(ret);
3453 register PERL_CONTEXT *cx;
3455 const U8 save_flags = PL_op -> op_flags;
3460 retop = cx->blk_eval.retop;
3463 if (gimme == G_VOID)
3465 else if (gimme == G_SCALAR) {
3468 if (SvFLAGS(TOPs) & SVs_TEMP)
3471 *MARK = sv_mortalcopy(TOPs);
3475 *MARK = &PL_sv_undef;
3480 /* in case LEAVE wipes old return values */
3481 for (mark = newsp + 1; mark <= SP; mark++) {
3482 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3483 *mark = sv_mortalcopy(*mark);
3484 TAINT_NOT; /* Each item is independent */
3488 PL_curpm = newpm; /* Don't pop $1 et al till now */
3491 assert(CvDEPTH(PL_compcv) == 1);
3493 CvDEPTH(PL_compcv) = 0;
3496 if (optype == OP_REQUIRE &&
3497 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3499 /* Unassume the success we assumed earlier. */
3500 SV *nsv = cx->blk_eval.old_namesv;
3501 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3502 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3503 /* die_where() did LEAVE, or we won't be here */
3507 if (!(save_flags & OPf_SPECIAL))
3517 register PERL_CONTEXT *cx;
3518 I32 gimme = GIMME_V;
3523 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3525 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3527 PL_in_eval = EVAL_INEVAL;
3530 return DOCATCH(PL_op->op_next);
3541 register PERL_CONTEXT *cx;
3546 retop = cx->blk_eval.retop;
3549 if (gimme == G_VOID)
3551 else if (gimme == G_SCALAR) {
3554 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3557 *MARK = sv_mortalcopy(TOPs);
3561 *MARK = &PL_sv_undef;
3566 /* in case LEAVE wipes old return values */
3567 for (mark = newsp + 1; mark <= SP; mark++) {
3568 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3569 *mark = sv_mortalcopy(*mark);
3570 TAINT_NOT; /* Each item is independent */
3574 PL_curpm = newpm; /* Don't pop $1 et al till now */
3582 S_doparseform(pTHX_ SV *sv)
3585 register char *s = SvPV_force(sv, len);
3586 register char *send = s + len;
3587 register char *base = Nullch;
3588 register I32 skipspaces = 0;
3589 bool noblank = FALSE;
3590 bool repeat = FALSE;
3591 bool postspace = FALSE;
3597 bool unchopnum = FALSE;
3598 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3601 Perl_croak(aTHX_ "Null picture in formline");
3603 /* estimate the buffer size needed */
3604 for (base = s; s <= send; s++) {
3605 if (*s == '\n' || *s == '@' || *s == '^')
3611 New(804, fops, maxops, U32);
3616 *fpc++ = FF_LINEMARK;
3617 noblank = repeat = FALSE;
3635 case ' ': case '\t':
3642 } /* else FALL THROUGH */
3650 *fpc++ = FF_LITERAL;
3658 *fpc++ = (U16)skipspaces;
3662 *fpc++ = FF_NEWLINE;
3666 arg = fpc - linepc + 1;
3673 *fpc++ = FF_LINEMARK;
3674 noblank = repeat = FALSE;
3683 ischop = s[-1] == '^';
3689 arg = (s - base) - 1;
3691 *fpc++ = FF_LITERAL;
3699 *fpc++ = 2; /* skip the @* or ^* */
3701 *fpc++ = FF_LINESNGL;
3704 *fpc++ = FF_LINEGLOB;
3706 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3707 arg = ischop ? 512 : 0;
3712 const char * const f = ++s;
3715 arg |= 256 + (s - f);
3717 *fpc++ = s - base; /* fieldsize for FETCH */
3718 *fpc++ = FF_DECIMAL;
3720 unchopnum |= ! ischop;
3722 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3723 arg = ischop ? 512 : 0;
3725 s++; /* skip the '0' first */
3729 const char * const f = ++s;
3732 arg |= 256 + (s - f);
3734 *fpc++ = s - base; /* fieldsize for FETCH */
3735 *fpc++ = FF_0DECIMAL;
3737 unchopnum |= ! ischop;
3741 bool ismore = FALSE;
3744 while (*++s == '>') ;
3745 prespace = FF_SPACE;
3747 else if (*s == '|') {
3748 while (*++s == '|') ;
3749 prespace = FF_HALFSPACE;
3754 while (*++s == '<') ;
3757 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3761 *fpc++ = s - base; /* fieldsize for FETCH */
3763 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3766 *fpc++ = (U16)prespace;
3780 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3782 { /* need to jump to the next word */
3784 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3785 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3786 s = SvPVX(sv) + SvCUR(sv) + z;
3788 Copy(fops, s, arg, U32);
3790 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3793 if (unchopnum && repeat)
3794 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3800 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3802 /* Can value be printed in fldsize chars, using %*.*f ? */
3806 int intsize = fldsize - (value < 0 ? 1 : 0);
3813 while (intsize--) pwr *= 10.0;
3814 while (frcsize--) eps /= 10.0;
3817 if (value + eps >= pwr)
3820 if (value - eps <= -pwr)
3827 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3829 SV *datasv = FILTER_DATA(idx);
3830 int filter_has_file = IoLINES(datasv);
3831 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3832 SV *filter_state = (SV *)IoTOP_GV(datasv);
3833 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3836 /* I was having segfault trouble under Linux 2.2.5 after a
3837 parse error occured. (Had to hack around it with a test
3838 for PL_error_count == 0.) Solaris doesn't segfault --
3839 not sure where the trouble is yet. XXX */
3841 if (filter_has_file) {
3842 len = FILTER_READ(idx+1, buf_sv, maxlen);
3845 if (filter_sub && len >= 0) {
3856 PUSHs(sv_2mortal(newSViv(maxlen)));
3858 PUSHs(filter_state);
3861 count = call_sv(filter_sub, G_SCALAR);
3877 IoLINES(datasv) = 0;
3878 if (filter_child_proc) {
3879 SvREFCNT_dec(filter_child_proc);
3880 IoFMT_GV(datasv) = Nullgv;
3883 SvREFCNT_dec(filter_state);
3884 IoTOP_GV(datasv) = Nullgv;
3887 SvREFCNT_dec(filter_sub);
3888 IoBOTTOM_GV(datasv) = Nullgv;
3890 filter_del(run_user_filter);
3896 /* perhaps someone can come up with a better name for
3897 this? it is not really "absolute", per se ... */
3899 S_path_is_absolute(pTHX_ const char *name)
3901 if (PERL_FILE_IS_ABSOLUTE(name)
3902 #ifdef MACOS_TRADITIONAL
3905 || (*name == '.' && (name[1] == '/' ||
3906 (name[1] == '.' && name[2] == '/'))))
3917 * c-indentation-style: bsd
3919 * indent-tabs-mode: t
3922 * vim: shiftwidth=4: