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);
2430 if (PERLDB_SUB_NN) {
2431 int type = SvTYPE(sv);
2432 if (type < SVt_PVIV && type != SVt_IV)
2433 sv_upgrade(sv, SVt_PVIV);
2435 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2437 gv_efullname3(sv, CvGV(cv), Nullch);
2440 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2441 PUSHMARK( PL_stack_sp );
2442 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2446 RETURNOP(CvSTART(cv));
2450 label = SvPV(sv,n_a);
2451 if (!(do_dump || *label))
2452 DIE(aTHX_ must_have_label);
2455 else if (PL_op->op_flags & OPf_SPECIAL) {
2457 DIE(aTHX_ must_have_label);
2460 label = cPVOP->op_pv;
2462 if (label && *label) {
2464 bool leaving_eval = FALSE;
2465 bool in_block = FALSE;
2466 PERL_CONTEXT *last_eval_cx = 0;
2470 PL_lastgotoprobe = 0;
2472 for (ix = cxstack_ix; ix >= 0; ix--) {
2474 switch (CxTYPE(cx)) {
2476 leaving_eval = TRUE;
2477 if (!CxTRYBLOCK(cx)) {
2478 gotoprobe = (last_eval_cx ?
2479 last_eval_cx->blk_eval.old_eval_root :
2484 /* else fall through */
2486 gotoprobe = cx->blk_oldcop->op_sibling;
2492 gotoprobe = cx->blk_oldcop->op_sibling;
2495 gotoprobe = PL_main_root;
2498 if (CvDEPTH(cx->blk_sub.cv)) {
2499 gotoprobe = CvROOT(cx->blk_sub.cv);
2505 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2508 DIE(aTHX_ "panic: goto");
2509 gotoprobe = PL_main_root;
2513 retop = dofindlabel(gotoprobe, label,
2514 enterops, enterops + GOTO_DEPTH);
2518 PL_lastgotoprobe = gotoprobe;
2521 DIE(aTHX_ "Can't find label %s", label);
2523 /* if we're leaving an eval, check before we pop any frames
2524 that we're not going to punt, otherwise the error
2527 if (leaving_eval && *enterops && enterops[1]) {
2529 for (i = 1; enterops[i]; i++)
2530 if (enterops[i]->op_type == OP_ENTERITER)
2531 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2534 /* pop unwanted frames */
2536 if (ix < cxstack_ix) {
2543 oldsave = PL_scopestack[PL_scopestack_ix];
2544 LEAVE_SCOPE(oldsave);
2547 /* push wanted frames */
2549 if (*enterops && enterops[1]) {
2551 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2552 for (; enterops[ix]; ix++) {
2553 PL_op = enterops[ix];
2554 /* Eventually we may want to stack the needed arguments
2555 * for each op. For now, we punt on the hard ones. */
2556 if (PL_op->op_type == OP_ENTERITER)
2557 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2558 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2566 if (!retop) retop = PL_main_start;
2568 PL_restartop = retop;
2569 PL_do_undump = TRUE;
2573 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2574 PL_do_undump = FALSE;
2590 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2592 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2595 PL_exit_flags |= PERL_EXIT_EXPECTED;
2597 PUSHs(&PL_sv_undef);
2605 NV value = SvNVx(GvSV(cCOP->cop_gv));
2606 register I32 match = I_32(value);
2609 if (((NV)match) > value)
2610 --match; /* was fractional--truncate other way */
2612 match -= cCOP->uop.scop.scop_offset;
2615 else if (match > cCOP->uop.scop.scop_max)
2616 match = cCOP->uop.scop.scop_max;
2617 PL_op = cCOP->uop.scop.scop_next[match];
2627 PL_op = PL_op->op_next; /* can't assume anything */
2630 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2631 match -= cCOP->uop.scop.scop_offset;
2634 else if (match > cCOP->uop.scop.scop_max)
2635 match = cCOP->uop.scop.scop_max;
2636 PL_op = cCOP->uop.scop.scop_next[match];
2645 S_save_lines(pTHX_ AV *array, SV *sv)
2647 register const char *s = SvPVX(sv);
2648 register const char *send = SvPVX(sv) + SvCUR(sv);
2649 register const char *t;
2650 register I32 line = 1;
2652 while (s && s < send) {
2653 SV *tmpstr = NEWSV(85,0);
2655 sv_upgrade(tmpstr, SVt_PVMG);
2656 t = strchr(s, '\n');
2662 sv_setpvn(tmpstr, s, t - s);
2663 av_store(array, line++, tmpstr);
2669 S_docatch_body(pTHX)
2676 S_docatch(pTHX_ OP *o)
2679 OP * const oldop = PL_op;
2681 volatile PERL_SI *cursi = PL_curstackinfo;
2685 assert(CATCH_GET == TRUE);
2689 /* Normally, the leavetry at the end of this block of ops will
2690 * pop an op off the return stack and continue there. By setting
2691 * the op to Nullop, we force an exit from the inner runops()
2694 assert(cxstack_ix >= 0);
2695 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2696 retop = cxstack[cxstack_ix].blk_eval.retop;
2697 cxstack[cxstack_ix].blk_eval.retop = Nullop;
2706 /* die caught by an inner eval - continue inner loop */
2707 if (PL_restartop && cursi == PL_curstackinfo) {
2708 PL_op = PL_restartop;
2712 /* a die in this eval - continue in outer loop */
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2733 dSP; /* Make POPBLOCK work. */
2736 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2740 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741 char *tmpbuf = tbuf;
2744 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2749 /* switch to eval mode */
2751 if (IN_PERL_COMPILETIME) {
2752 SAVECOPSTASH_FREE(&PL_compiling);
2753 CopSTASH_set(&PL_compiling, PL_curstash);
2755 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2756 SV *sv = sv_newmortal();
2757 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2758 code, (unsigned long)++PL_evalseq,
2759 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2763 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2764 SAVECOPFILE_FREE(&PL_compiling);
2765 CopFILE_set(&PL_compiling, tmpbuf+2);
2766 SAVECOPLINE(&PL_compiling);
2767 CopLINE_set(&PL_compiling, 1);
2768 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2769 deleting the eval's FILEGV from the stash before gv_check() runs
2770 (i.e. before run-time proper). To work around the coredump that
2771 ensues, we always turn GvMULTI_on for any globals that were
2772 introduced within evals. See force_ident(). GSAR 96-10-12 */
2773 safestr = savepv(tmpbuf);
2774 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2776 #ifdef OP_IN_REGISTER
2782 /* we get here either during compilation, or via pp_regcomp at runtime */
2783 runtime = IN_PERL_RUNTIME;
2785 runcv = find_runcv(NULL);
2788 PL_op->op_type = OP_ENTEREVAL;
2789 PL_op->op_flags = 0; /* Avoid uninit warning. */
2790 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2791 PUSHEVAL(cx, 0, Nullgv);
2794 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2796 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2797 POPBLOCK(cx,PL_curpm);
2800 (*startop)->op_type = OP_NULL;
2801 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2803 /* XXX DAPM do this properly one year */
2804 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2806 if (IN_PERL_COMPILETIME)
2807 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2808 #ifdef OP_IN_REGISTER
2816 =for apidoc find_runcv
2818 Locate the CV corresponding to the currently executing sub or eval.
2819 If db_seqp is non_null, skip CVs that are in the DB package and populate
2820 *db_seqp with the cop sequence number at the point that the DB:: code was
2821 entered. (allows debuggers to eval in the scope of the breakpoint rather
2822 than in in the scope of the debugger itself).
2828 Perl_find_runcv(pTHX_ U32 *db_seqp)
2833 *db_seqp = PL_curcop->cop_seq;
2834 for (si = PL_curstackinfo; si; si = si->si_prev) {
2836 for (ix = si->si_cxix; ix >= 0; ix--) {
2837 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2838 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2839 CV *cv = cx->blk_sub.cv;
2840 /* skip DB:: code */
2841 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2842 *db_seqp = cx->blk_oldcop->cop_seq;
2847 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2855 /* Compile a require/do, an eval '', or a /(?{...})/.
2856 * In the last case, startop is non-null, and contains the address of
2857 * a pointer that should be set to the just-compiled code.
2858 * outside is the lexically enclosing CV (if any) that invoked us.
2861 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2863 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2868 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2869 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2874 SAVESPTR(PL_compcv);
2875 PL_compcv = (CV*)NEWSV(1104,0);
2876 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2877 CvEVAL_on(PL_compcv);
2878 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2879 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2881 CvOUTSIDE_SEQ(PL_compcv) = seq;
2882 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2884 /* set up a scratch pad */
2886 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2889 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2891 /* make sure we compile in the right package */
2893 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2894 SAVESPTR(PL_curstash);
2895 PL_curstash = CopSTASH(PL_curcop);
2897 SAVESPTR(PL_beginav);
2898 PL_beginav = newAV();
2899 SAVEFREESV(PL_beginav);
2900 SAVEI32(PL_error_count);
2902 /* try to compile it */
2904 PL_eval_root = Nullop;
2906 PL_curcop = &PL_compiling;
2907 PL_curcop->cop_arybase = 0;
2908 if (saveop && saveop->op_flags & OPf_SPECIAL)
2909 PL_in_eval |= EVAL_KEEPERR;
2912 if (yyparse() || PL_error_count || !PL_eval_root) {
2913 SV **newsp; /* Used by POPBLOCK. */
2914 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2915 I32 optype = 0; /* Might be reset by POPEVAL. */
2920 op_free(PL_eval_root);
2921 PL_eval_root = Nullop;
2923 SP = PL_stack_base + POPMARK; /* pop original mark */
2925 POPBLOCK(cx,PL_curpm);
2930 if (optype == OP_REQUIRE) {
2931 const char* msg = SvPVx(ERRSV, n_a);
2932 SV *nsv = cx->blk_eval.old_namesv;
2933 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2935 DIE(aTHX_ "%sCompilation failed in require",
2936 *msg ? msg : "Unknown error\n");
2939 const char* msg = SvPVx(ERRSV, n_a);
2941 POPBLOCK(cx,PL_curpm);
2943 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2944 (*msg ? msg : "Unknown error\n"));
2947 const char* msg = SvPVx(ERRSV, n_a);
2949 sv_setpv(ERRSV, "Compilation error");
2954 CopLINE_set(&PL_compiling, 0);
2956 *startop = PL_eval_root;
2958 SAVEFREEOP(PL_eval_root);
2960 /* Set the context for this new optree.
2961 * If the last op is an OP_REQUIRE, force scalar context.
2962 * Otherwise, propagate the context from the eval(). */
2963 if (PL_eval_root->op_type == OP_LEAVEEVAL
2964 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2965 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2967 scalar(PL_eval_root);
2968 else if (gimme & G_VOID)
2969 scalarvoid(PL_eval_root);
2970 else if (gimme & G_ARRAY)
2973 scalar(PL_eval_root);
2975 DEBUG_x(dump_eval());
2977 /* Register with debugger: */
2978 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2979 CV *cv = get_cv("DB::postponed", FALSE);
2983 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2985 call_sv((SV*)cv, G_DISCARD);
2989 /* compiled okay, so do it */
2991 CvDEPTH(PL_compcv) = 1;
2992 SP = PL_stack_base + POPMARK; /* pop original mark */
2993 PL_op = saveop; /* The caller may need it. */
2994 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2996 RETURNOP(PL_eval_start);
3000 S_doopen_pm(pTHX_ const char *name, const char *mode)
3002 #ifndef PERL_DISABLE_PMC
3003 STRLEN namelen = strlen(name);
3006 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3007 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3008 const char * const pmc = SvPV_nolen(pmcsv);
3011 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3012 fp = PerlIO_open(name, mode);
3015 if (PerlLIO_stat(name, &pmstat) < 0 ||
3016 pmstat.st_mtime < pmcstat.st_mtime)
3018 fp = PerlIO_open(pmc, mode);
3021 fp = PerlIO_open(name, mode);
3024 SvREFCNT_dec(pmcsv);
3027 fp = PerlIO_open(name, mode);
3031 return PerlIO_open(name, mode);
3032 #endif /* !PERL_DISABLE_PMC */
3038 register PERL_CONTEXT *cx;
3042 char *tryname = Nullch;
3043 SV *namesv = Nullsv;
3045 I32 gimme = GIMME_V;
3046 PerlIO *tryrsfp = 0;
3048 int filter_has_file = 0;
3049 GV *filter_child_proc = 0;
3050 SV *filter_state = 0;
3057 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3058 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3059 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3060 "v-string in use/require non-portable");
3062 sv = new_version(sv);
3063 if (!sv_derived_from(PL_patchlevel, "version"))
3064 (void *)upg_version(PL_patchlevel);
3065 if ( vcmp(sv,PL_patchlevel) > 0 )
3066 DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3067 vstringify(sv), vstringify(PL_patchlevel));
3071 name = SvPV(sv, len);
3072 if (!(name && len > 0 && *name))
3073 DIE(aTHX_ "Null filename used");
3074 TAINT_PROPER("require");
3075 if (PL_op->op_type == OP_REQUIRE &&
3076 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3077 if (*svp != &PL_sv_undef)
3080 DIE(aTHX_ "Compilation failed in require");
3083 /* prepare to compile file */
3085 if (path_is_absolute(name)) {
3087 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3089 #ifdef MACOS_TRADITIONAL
3093 MacPerl_CanonDir(name, newname, 1);
3094 if (path_is_absolute(newname)) {
3096 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3101 AV *ar = GvAVn(PL_incgv);
3105 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3108 namesv = NEWSV(806, 0);
3109 for (i = 0; i <= AvFILL(ar); i++) {
3110 SV *dirsv = *av_fetch(ar, i, TRUE);
3116 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3117 && !sv_isobject(loader))
3119 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3122 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3123 PTR2UV(SvRV(dirsv)), name);
3124 tryname = SvPVX(namesv);
3135 if (sv_isobject(loader))
3136 count = call_method("INC", G_ARRAY);
3138 count = call_sv(loader, G_ARRAY);
3148 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3152 if (SvTYPE(arg) == SVt_PVGV) {
3153 IO *io = GvIO((GV *)arg);
3158 tryrsfp = IoIFP(io);
3159 if (IoTYPE(io) == IoTYPE_PIPE) {
3160 /* reading from a child process doesn't
3161 nest -- when returning from reading
3162 the inner module, the outer one is
3163 unreadable (closed?) I've tried to
3164 save the gv to manage the lifespan of
3165 the pipe, but this didn't help. XXX */
3166 filter_child_proc = (GV *)arg;
3167 (void)SvREFCNT_inc(filter_child_proc);
3170 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3171 PerlIO_close(IoOFP(io));
3183 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3185 (void)SvREFCNT_inc(filter_sub);
3188 filter_state = SP[i];
3189 (void)SvREFCNT_inc(filter_state);
3193 tryrsfp = PerlIO_open("/dev/null",
3209 filter_has_file = 0;
3210 if (filter_child_proc) {
3211 SvREFCNT_dec(filter_child_proc);
3212 filter_child_proc = 0;
3215 SvREFCNT_dec(filter_state);
3219 SvREFCNT_dec(filter_sub);
3224 if (!path_is_absolute(name)
3225 #ifdef MACOS_TRADITIONAL
3226 /* We consider paths of the form :a:b ambiguous and interpret them first
3227 as global then as local
3229 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3232 char *dir = SvPVx(dirsv, n_a);
3233 #ifdef MACOS_TRADITIONAL
3237 MacPerl_CanonDir(name, buf2, 1);
3238 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3242 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3244 sv_setpv(namesv, unixdir);
3245 sv_catpv(namesv, unixname);
3247 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3250 TAINT_PROPER("require");
3251 tryname = SvPVX(namesv);
3252 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3254 if (tryname[0] == '.' && tryname[1] == '/')
3263 SAVECOPFILE_FREE(&PL_compiling);
3264 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3265 SvREFCNT_dec(namesv);
3267 if (PL_op->op_type == OP_REQUIRE) {
3268 char *msgstr = name;
3269 if (namesv) { /* did we lookup @INC? */
3270 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3271 SV *dirmsgsv = NEWSV(0, 0);
3272 AV *ar = GvAVn(PL_incgv);
3274 sv_catpvn(msg, " in @INC", 8);
3275 if (instr(SvPVX(msg), ".h "))
3276 sv_catpv(msg, " (change .h to .ph maybe?)");
3277 if (instr(SvPVX(msg), ".ph "))
3278 sv_catpv(msg, " (did you run h2ph?)");
3279 sv_catpv(msg, " (@INC contains:");
3280 for (i = 0; i <= AvFILL(ar); i++) {
3281 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3282 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3283 sv_catsv(msg, dirmsgsv);
3285 sv_catpvn(msg, ")", 1);
3286 SvREFCNT_dec(dirmsgsv);
3287 msgstr = SvPV_nolen(msg);
3289 DIE(aTHX_ "Can't locate %s", msgstr);
3295 SETERRNO(0, SS_NORMAL);
3297 /* Assume success here to prevent recursive requirement. */
3299 /* Check whether a hook in @INC has already filled %INC */
3300 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3301 (void)hv_store(GvHVn(PL_incgv), name, len,
3302 (hook_sv ? SvREFCNT_inc(hook_sv)
3303 : newSVpv(CopFILE(&PL_compiling), 0)),
3309 lex_start(sv_2mortal(newSVpvn("",0)));
3310 SAVEGENERICSV(PL_rsfp_filters);
3311 PL_rsfp_filters = Nullav;
3316 SAVESPTR(PL_compiling.cop_warnings);
3317 if (PL_dowarn & G_WARN_ALL_ON)
3318 PL_compiling.cop_warnings = pWARN_ALL ;
3319 else if (PL_dowarn & G_WARN_ALL_OFF)
3320 PL_compiling.cop_warnings = pWARN_NONE ;
3321 else if (PL_taint_warn)
3322 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3324 PL_compiling.cop_warnings = pWARN_STD ;
3325 SAVESPTR(PL_compiling.cop_io);
3326 PL_compiling.cop_io = Nullsv;
3328 if (filter_sub || filter_child_proc) {
3329 SV *datasv = filter_add(run_user_filter, Nullsv);
3330 IoLINES(datasv) = filter_has_file;
3331 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3332 IoTOP_GV(datasv) = (GV *)filter_state;
3333 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3336 /* switch to eval mode */
3337 PUSHBLOCK(cx, CXt_EVAL, SP);
3338 PUSHEVAL(cx, name, Nullgv);
3339 cx->blk_eval.retop = PL_op->op_next;
3341 SAVECOPLINE(&PL_compiling);
3342 CopLINE_set(&PL_compiling, 0);
3346 /* Store and reset encoding. */
3347 encoding = PL_encoding;
3348 PL_encoding = Nullsv;
3350 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3352 /* Restore encoding. */
3353 PL_encoding = encoding;
3360 return pp_require();
3366 register PERL_CONTEXT *cx;
3368 I32 gimme = GIMME_V, was = PL_sub_generation;
3369 char tbuf[TYPE_DIGITS(long) + 12];
3370 char *tmpbuf = tbuf;
3379 TAINT_PROPER("eval");
3385 /* switch to eval mode */
3387 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3388 SV *sv = sv_newmortal();
3389 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3390 (unsigned long)++PL_evalseq,
3391 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3395 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3396 SAVECOPFILE_FREE(&PL_compiling);
3397 CopFILE_set(&PL_compiling, tmpbuf+2);
3398 SAVECOPLINE(&PL_compiling);
3399 CopLINE_set(&PL_compiling, 1);
3400 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3401 deleting the eval's FILEGV from the stash before gv_check() runs
3402 (i.e. before run-time proper). To work around the coredump that
3403 ensues, we always turn GvMULTI_on for any globals that were
3404 introduced within evals. See force_ident(). GSAR 96-10-12 */
3405 safestr = savepv(tmpbuf);
3406 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3408 PL_hints = PL_op->op_targ;
3409 SAVESPTR(PL_compiling.cop_warnings);
3410 if (specialWARN(PL_curcop->cop_warnings))
3411 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3413 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3414 SAVEFREESV(PL_compiling.cop_warnings);
3416 SAVESPTR(PL_compiling.cop_io);
3417 if (specialCopIO(PL_curcop->cop_io))
3418 PL_compiling.cop_io = PL_curcop->cop_io;
3420 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3421 SAVEFREESV(PL_compiling.cop_io);
3423 /* special case: an eval '' executed within the DB package gets lexically
3424 * placed in the first non-DB CV rather than the current CV - this
3425 * allows the debugger to execute code, find lexicals etc, in the
3426 * scope of the code being debugged. Passing &seq gets find_runcv
3427 * to do the dirty work for us */
3428 runcv = find_runcv(&seq);
3430 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3431 PUSHEVAL(cx, 0, Nullgv);
3432 cx->blk_eval.retop = PL_op->op_next;
3434 /* prepare to compile string */
3436 if (PERLDB_LINE && PL_curstash != PL_debstash)
3437 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3439 ret = doeval(gimme, NULL, runcv, seq);
3440 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3441 && ret != PL_op->op_next) { /* Successive compilation. */
3442 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3444 return DOCATCH(ret);
3454 register PERL_CONTEXT *cx;
3456 const U8 save_flags = PL_op -> op_flags;
3461 retop = cx->blk_eval.retop;
3464 if (gimme == G_VOID)
3466 else if (gimme == G_SCALAR) {
3469 if (SvFLAGS(TOPs) & SVs_TEMP)
3472 *MARK = sv_mortalcopy(TOPs);
3476 *MARK = &PL_sv_undef;
3481 /* in case LEAVE wipes old return values */
3482 for (mark = newsp + 1; mark <= SP; mark++) {
3483 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3484 *mark = sv_mortalcopy(*mark);
3485 TAINT_NOT; /* Each item is independent */
3489 PL_curpm = newpm; /* Don't pop $1 et al till now */
3492 assert(CvDEPTH(PL_compcv) == 1);
3494 CvDEPTH(PL_compcv) = 0;
3497 if (optype == OP_REQUIRE &&
3498 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3500 /* Unassume the success we assumed earlier. */
3501 SV *nsv = cx->blk_eval.old_namesv;
3502 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3503 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3504 /* die_where() did LEAVE, or we won't be here */
3508 if (!(save_flags & OPf_SPECIAL))
3518 register PERL_CONTEXT *cx;
3519 I32 gimme = GIMME_V;
3524 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3526 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3528 PL_in_eval = EVAL_INEVAL;
3531 return DOCATCH(PL_op->op_next);
3542 register PERL_CONTEXT *cx;
3547 retop = cx->blk_eval.retop;
3550 if (gimme == G_VOID)
3552 else if (gimme == G_SCALAR) {
3555 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3558 *MARK = sv_mortalcopy(TOPs);
3562 *MARK = &PL_sv_undef;
3567 /* in case LEAVE wipes old return values */
3568 for (mark = newsp + 1; mark <= SP; mark++) {
3569 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3570 *mark = sv_mortalcopy(*mark);
3571 TAINT_NOT; /* Each item is independent */
3575 PL_curpm = newpm; /* Don't pop $1 et al till now */
3583 S_doparseform(pTHX_ SV *sv)
3586 register char *s = SvPV_force(sv, len);
3587 register char *send = s + len;
3588 register char *base = Nullch;
3589 register I32 skipspaces = 0;
3590 bool noblank = FALSE;
3591 bool repeat = FALSE;
3592 bool postspace = FALSE;
3598 bool unchopnum = FALSE;
3599 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3602 Perl_croak(aTHX_ "Null picture in formline");
3604 /* estimate the buffer size needed */
3605 for (base = s; s <= send; s++) {
3606 if (*s == '\n' || *s == '@' || *s == '^')
3612 New(804, fops, maxops, U32);
3617 *fpc++ = FF_LINEMARK;
3618 noblank = repeat = FALSE;
3636 case ' ': case '\t':
3643 } /* else FALL THROUGH */
3651 *fpc++ = FF_LITERAL;
3659 *fpc++ = (U16)skipspaces;
3663 *fpc++ = FF_NEWLINE;
3667 arg = fpc - linepc + 1;
3674 *fpc++ = FF_LINEMARK;
3675 noblank = repeat = FALSE;
3684 ischop = s[-1] == '^';
3690 arg = (s - base) - 1;
3692 *fpc++ = FF_LITERAL;
3700 *fpc++ = 2; /* skip the @* or ^* */
3702 *fpc++ = FF_LINESNGL;
3705 *fpc++ = FF_LINEGLOB;
3707 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3708 arg = ischop ? 512 : 0;
3713 const char * const f = ++s;
3716 arg |= 256 + (s - f);
3718 *fpc++ = s - base; /* fieldsize for FETCH */
3719 *fpc++ = FF_DECIMAL;
3721 unchopnum |= ! ischop;
3723 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3724 arg = ischop ? 512 : 0;
3726 s++; /* skip the '0' first */
3730 const char * const f = ++s;
3733 arg |= 256 + (s - f);
3735 *fpc++ = s - base; /* fieldsize for FETCH */
3736 *fpc++ = FF_0DECIMAL;
3738 unchopnum |= ! ischop;
3742 bool ismore = FALSE;
3745 while (*++s == '>') ;
3746 prespace = FF_SPACE;
3748 else if (*s == '|') {
3749 while (*++s == '|') ;
3750 prespace = FF_HALFSPACE;
3755 while (*++s == '<') ;
3758 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3762 *fpc++ = s - base; /* fieldsize for FETCH */
3764 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3767 *fpc++ = (U16)prespace;
3781 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3783 { /* need to jump to the next word */
3785 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3786 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3787 s = SvPVX(sv) + SvCUR(sv) + z;
3789 Copy(fops, s, arg, U32);
3791 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3794 if (unchopnum && repeat)
3795 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3801 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3803 /* Can value be printed in fldsize chars, using %*.*f ? */
3807 int intsize = fldsize - (value < 0 ? 1 : 0);
3814 while (intsize--) pwr *= 10.0;
3815 while (frcsize--) eps /= 10.0;
3818 if (value + eps >= pwr)
3821 if (value - eps <= -pwr)
3828 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3830 SV *datasv = FILTER_DATA(idx);
3831 int filter_has_file = IoLINES(datasv);
3832 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3833 SV *filter_state = (SV *)IoTOP_GV(datasv);
3834 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3837 /* I was having segfault trouble under Linux 2.2.5 after a
3838 parse error occured. (Had to hack around it with a test
3839 for PL_error_count == 0.) Solaris doesn't segfault --
3840 not sure where the trouble is yet. XXX */
3842 if (filter_has_file) {
3843 len = FILTER_READ(idx+1, buf_sv, maxlen);
3846 if (filter_sub && len >= 0) {
3857 PUSHs(sv_2mortal(newSViv(maxlen)));
3859 PUSHs(filter_state);
3862 count = call_sv(filter_sub, G_SCALAR);
3878 IoLINES(datasv) = 0;
3879 if (filter_child_proc) {
3880 SvREFCNT_dec(filter_child_proc);
3881 IoFMT_GV(datasv) = Nullgv;
3884 SvREFCNT_dec(filter_state);
3885 IoTOP_GV(datasv) = Nullgv;
3888 SvREFCNT_dec(filter_sub);
3889 IoBOTTOM_GV(datasv) = Nullgv;
3891 filter_del(run_user_filter);
3897 /* perhaps someone can come up with a better name for
3898 this? it is not really "absolute", per se ... */
3900 S_path_is_absolute(pTHX_ const char *name)
3902 if (PERL_FILE_IS_ABSOLUTE(name)
3903 #ifdef MACOS_TRADITIONAL
3906 || (*name == '.' && (name[1] == '/' ||
3907 (name[1] == '.' && name[2] == '/'))))
3918 * c-indentation-style: bsd
3920 * indent-tabs-mode: t
3923 * vim: shiftwidth=4: