3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 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.
21 #define PERL_IN_PP_CTL_C
25 #define WORD_ALIGN sizeof(U16)
28 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
30 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
38 cxix = dopoptosub(cxstack_ix);
42 switch (cxstack[cxix].blk_gimme) {
59 /* XXXX Should store the old value to allow for tie/overload - and
60 restore in regcomp, where marked with XXXX. */
68 register PMOP *pm = (PMOP*)cLOGOP->op_other;
72 MAGIC *mg = Null(MAGIC*);
76 /* prevent recompiling under /o and ithreads. */
77 #if defined(USE_ITHREADS)
78 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
83 SV *sv = SvRV(tmpstr);
85 mg = mg_find(sv, PERL_MAGIC_qr);
88 regexp *re = (regexp *)mg->mg_obj;
89 ReREFCNT_dec(PM_GETRE(pm));
90 PM_SETRE(pm, ReREFCNT_inc(re));
93 t = SvPV(tmpstr, len);
95 /* Check against the last compiled regexp. */
96 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
97 PM_GETRE(pm)->prelen != (I32)len ||
98 memNE(PM_GETRE(pm)->precomp, t, len))
101 ReREFCNT_dec(PM_GETRE(pm));
102 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
104 if (PL_op->op_flags & OPf_SPECIAL)
105 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
107 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
109 pm->op_pmdynflags |= PMdf_DYN_UTF8;
111 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
112 if (pm->op_pmdynflags & PMdf_UTF8)
113 t = (char*)bytes_to_utf8((U8*)t, &len);
115 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
116 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
118 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
119 inside tie/overload accessors. */
123 #ifndef INCOMPLETE_TAINTS
126 pm->op_pmdynflags |= PMdf_TAINTED;
128 pm->op_pmdynflags &= ~PMdf_TAINTED;
132 if (!PM_GETRE(pm)->prelen && PL_curpm)
134 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
135 pm->op_pmflags |= PMf_WHITE;
137 pm->op_pmflags &= ~PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
162 rxres_restore(&cx->sb_rxres, rx);
163 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
165 if (cx->sb_iters++) {
166 I32 saviters = cx->sb_iters;
167 if (cx->sb_iters > cx->sb_maxiters)
168 DIE(aTHX_ "Substitution loop");
170 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
171 cx->sb_rxtainted |= 2;
172 sv_catsv(dstr, POPs);
175 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
176 s == m, cx->sb_targ, NULL,
177 ((cx->sb_rflags & REXEC_COPY_STR)
178 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
179 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
181 SV *targ = cx->sb_targ;
183 if (DO_UTF8(dstr) && !SvUTF8(targ))
184 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
186 sv_catpvn(dstr, s, cx->sb_strend - s);
187 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
189 #ifdef PERL_COPY_ON_WRITE
191 sv_force_normal_flags(targ, SV_COW_DROP_PV);
195 (void)SvOOK_off(targ);
197 Safefree(SvPVX(targ));
199 SvPVX(targ) = SvPVX(dstr);
200 SvCUR_set(targ, SvCUR(dstr));
201 SvLEN_set(targ, SvLEN(dstr));
207 TAINT_IF(cx->sb_rxtainted & 1);
208 PUSHs(sv_2mortal(newSViv(saviters - 1)));
210 (void)SvPOK_only_UTF8(targ);
211 TAINT_IF(cx->sb_rxtainted);
215 LEAVE_SCOPE(cx->sb_oldsave);
217 RETURNOP(pm->op_next);
219 cx->sb_iters = saviters;
221 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
224 cx->sb_orig = orig = rx->subbeg;
226 cx->sb_strend = s + (cx->sb_strend - m);
228 cx->sb_m = m = rx->startp[0] + orig;
230 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
231 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
233 sv_catpvn(dstr, s, m-s);
235 cx->sb_s = rx->endp[0] + orig;
236 { /* Update the pos() information. */
237 SV *sv = cx->sb_targ;
240 if (SvTYPE(sv) < SVt_PVMG)
241 (void)SvUPGRADE(sv, SVt_PVMG);
242 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
243 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
244 mg = mg_find(sv, PERL_MAGIC_regex_global);
251 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
252 rxres_save(&cx->sb_rxres, rx);
253 RETURNOP(pm->op_pmreplstart);
257 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
262 if (!p || p[1] < rx->nparens) {
263 #ifdef PERL_COPY_ON_WRITE
264 i = 7 + rx->nparens * 2;
266 i = 6 + rx->nparens * 2;
275 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
276 RX_MATCH_COPIED_off(rx);
278 #ifdef PERL_COPY_ON_WRITE
279 *p++ = PTR2UV(rx->saved_copy);
280 rx->saved_copy = Nullsv;
285 *p++ = PTR2UV(rx->subbeg);
286 *p++ = (UV)rx->sublen;
287 for (i = 0; i <= rx->nparens; ++i) {
288 *p++ = (UV)rx->startp[i];
289 *p++ = (UV)rx->endp[i];
294 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
299 RX_MATCH_COPY_FREE(rx);
300 RX_MATCH_COPIED_set(rx, *p);
303 #ifdef PERL_COPY_ON_WRITE
305 SvREFCNT_dec (rx->saved_copy);
306 rx->saved_copy = INT2PTR(SV*,*p);
312 rx->subbeg = INT2PTR(char*,*p++);
313 rx->sublen = (I32)(*p++);
314 for (i = 0; i <= rx->nparens; ++i) {
315 rx->startp[i] = (I32)(*p++);
316 rx->endp[i] = (I32)(*p++);
321 Perl_rxres_free(pTHX_ void **rsp)
326 Safefree(INT2PTR(char*,*p));
327 #ifdef PERL_COPY_ON_WRITE
329 SvREFCNT_dec (INT2PTR(SV*,p[1]));
339 dSP; dMARK; dORIGMARK;
340 register SV *tmpForm = *++MARK;
347 register SV *sv = Nullsv;
352 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
353 char *chophere = Nullch;
354 char *linemark = Nullch;
356 bool gotsome = FALSE;
358 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
359 bool item_is_utf8 = FALSE;
360 bool targ_is_utf8 = FALSE;
363 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
364 if (SvREADONLY(tmpForm)) {
365 SvREADONLY_off(tmpForm);
366 doparseform(tmpForm);
367 SvREADONLY_on(tmpForm);
370 doparseform(tmpForm);
372 SvPV_force(PL_formtarget, len);
373 if (DO_UTF8(PL_formtarget))
375 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
377 f = SvPV(tmpForm, len);
378 /* need to jump to the next word */
379 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
388 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
389 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
390 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
391 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
392 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
394 case FF_CHECKNL: name = "CHECKNL"; break;
395 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
396 case FF_SPACE: name = "SPACE"; break;
397 case FF_HALFSPACE: name = "HALFSPACE"; break;
398 case FF_ITEM: name = "ITEM"; break;
399 case FF_CHOP: name = "CHOP"; break;
400 case FF_LINEGLOB: name = "LINEGLOB"; break;
401 case FF_NEWLINE: name = "NEWLINE"; break;
402 case FF_MORE: name = "MORE"; break;
403 case FF_LINEMARK: name = "LINEMARK"; break;
404 case FF_END: name = "END"; break;
405 case FF_0DECIMAL: name = "0DECIMAL"; break;
408 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
410 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
421 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
422 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
424 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
425 t = SvEND(PL_formtarget);
428 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
429 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
431 sv_utf8_upgrade(PL_formtarget);
432 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
433 t = SvEND(PL_formtarget);
453 if (ckWARN(WARN_SYNTAX))
454 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
459 item = s = SvPV(sv, len);
462 itemsize = sv_len_utf8(sv);
463 if (itemsize != (I32)len) {
465 if (itemsize > fieldsize) {
466 itemsize = fieldsize;
467 itembytes = itemsize;
468 sv_pos_u2b(sv, &itembytes, 0);
472 send = chophere = s + itembytes;
482 sv_pos_b2u(sv, &itemsize);
486 item_is_utf8 = FALSE;
487 if (itemsize > fieldsize)
488 itemsize = fieldsize;
489 send = chophere = s + itemsize;
501 item = s = SvPV(sv, len);
504 itemsize = sv_len_utf8(sv);
505 if (itemsize != (I32)len) {
507 if (itemsize <= fieldsize) {
508 send = chophere = s + itemsize;
519 itemsize = fieldsize;
520 itembytes = itemsize;
521 sv_pos_u2b(sv, &itembytes, 0);
522 send = chophere = s + itembytes;
523 while (s < send || (s == send && isSPACE(*s))) {
533 if (strchr(PL_chopset, *s))
538 itemsize = chophere - item;
539 sv_pos_b2u(sv, &itemsize);
545 item_is_utf8 = FALSE;
546 if (itemsize <= fieldsize) {
547 send = chophere = s + itemsize;
558 itemsize = fieldsize;
559 send = chophere = s + itemsize;
560 while (s < send || (s == send && isSPACE(*s))) {
570 if (strchr(PL_chopset, *s))
575 itemsize = chophere - item;
580 arg = fieldsize - itemsize;
589 arg = fieldsize - itemsize;
603 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
605 sv_utf8_upgrade(PL_formtarget);
606 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
607 t = SvEND(PL_formtarget);
611 if (UTF8_IS_CONTINUED(*s)) {
612 STRLEN skip = UTF8SKIP(s);
629 if ( !((*t++ = *s++) & ~31) )
635 if (targ_is_utf8 && !item_is_utf8) {
636 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
638 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
639 for (; t < SvEND(PL_formtarget); t++) {
641 int ch = *t++ = *s++;
652 int ch = *t++ = *s++;
655 if ( !((*t++ = *s++) & ~31) )
664 while (*s && isSPACE(*s))
671 item = s = SvPV(sv, len);
673 if ((item_is_utf8 = DO_UTF8(sv)))
674 itemsize = sv_len_utf8(sv);
676 bool chopped = FALSE;
689 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
691 SvUTF8_on(PL_formtarget);
692 sv_catsv(PL_formtarget, sv);
694 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
695 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
696 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
703 /* If the field is marked with ^ and the value is undefined,
706 if ((arg & 512) && !SvOK(sv)) {
714 /* Formats aren't yet marked for locales, so assume "yes". */
716 STORE_NUMERIC_STANDARD_SET_LOCAL();
717 #if defined(USE_LONG_DOUBLE)
719 sprintf(t, "%#*.*" PERL_PRIfldbl,
720 (int) fieldsize, (int) arg & 255, value);
722 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
727 (int) fieldsize, (int) arg & 255, value);
730 (int) fieldsize, value);
733 RESTORE_NUMERIC_STANDARD();
739 /* If the field is marked with ^ and the value is undefined,
742 if ((arg & 512) && !SvOK(sv)) {
750 /* Formats aren't yet marked for locales, so assume "yes". */
752 STORE_NUMERIC_STANDARD_SET_LOCAL();
753 #if defined(USE_LONG_DOUBLE)
755 sprintf(t, "%#0*.*" PERL_PRIfldbl,
756 (int) fieldsize, (int) arg & 255, value);
757 /* is this legal? I don't have long doubles */
759 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
763 sprintf(t, "%#0*.*f",
764 (int) fieldsize, (int) arg & 255, value);
767 (int) fieldsize, value);
770 RESTORE_NUMERIC_STANDARD();
777 while (t-- > linemark && *t == ' ') ;
785 if (arg) { /* repeat until fields exhausted? */
787 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
788 lines += FmLINES(PL_formtarget);
791 if (strnEQ(linemark, linemark - arg, arg))
792 DIE(aTHX_ "Runaway format");
795 SvUTF8_on(PL_formtarget);
796 FmLINES(PL_formtarget) = lines;
798 RETURNOP(cLISTOP->op_first);
811 while (*s && isSPACE(*s) && s < send)
815 arg = fieldsize - itemsize;
822 if (strnEQ(s," ",3)) {
823 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
834 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
836 SvUTF8_on(PL_formtarget);
837 FmLINES(PL_formtarget) += lines;
849 if (PL_stack_base + *PL_markstack_ptr == SP) {
851 if (GIMME_V == G_SCALAR)
852 XPUSHs(sv_2mortal(newSViv(0)));
853 RETURNOP(PL_op->op_next->op_next);
855 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
856 pp_pushmark(); /* push dst */
857 pp_pushmark(); /* push src */
858 ENTER; /* enter outer scope */
861 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
863 ENTER; /* enter inner scope */
866 src = PL_stack_base[*PL_markstack_ptr];
871 if (PL_op->op_type == OP_MAPSTART)
872 pp_pushmark(); /* push top */
873 return ((LOGOP*)PL_op->op_next)->op_other;
878 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
884 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
890 /* first, move source pointer to the next item in the source list */
891 ++PL_markstack_ptr[-1];
893 /* if there are new items, push them into the destination list */
895 /* might need to make room back there first */
896 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
897 /* XXX this implementation is very pessimal because the stack
898 * is repeatedly extended for every set of items. Is possible
899 * to do this without any stack extension or copying at all
900 * by maintaining a separate list over which the map iterates
901 * (like foreach does). --gsar */
903 /* everything in the stack after the destination list moves
904 * towards the end the stack by the amount of room needed */
905 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
907 /* items to shift up (accounting for the moved source pointer) */
908 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
910 /* This optimization is by Ben Tilly and it does
911 * things differently from what Sarathy (gsar)
912 * is describing. The downside of this optimization is
913 * that leaves "holes" (uninitialized and hopefully unused areas)
914 * to the Perl stack, but on the other hand this
915 * shouldn't be a problem. If Sarathy's idea gets
916 * implemented, this optimization should become
917 * irrelevant. --jhi */
919 shift = count; /* Avoid shifting too often --Ben Tilly */
924 PL_markstack_ptr[-1] += shift;
925 *PL_markstack_ptr += shift;
929 /* copy the new items down to the destination list */
930 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
932 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
934 LEAVE; /* exit inner scope */
937 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
940 (void)POPMARK; /* pop top */
941 LEAVE; /* exit outer scope */
942 (void)POPMARK; /* pop src */
943 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
944 (void)POPMARK; /* pop dst */
945 SP = PL_stack_base + POPMARK; /* pop original mark */
946 if (gimme == G_SCALAR) {
950 else if (gimme == G_ARRAY)
957 ENTER; /* enter inner scope */
960 /* set $_ to the new source item */
961 src = PL_stack_base[PL_markstack_ptr[-1]];
965 RETURNOP(cLOGOP->op_other);
973 if (GIMME == G_ARRAY)
975 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
976 return cLOGOP->op_other;
985 if (GIMME == G_ARRAY) {
986 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
990 SV *targ = PAD_SV(PL_op->op_targ);
993 if (PL_op->op_private & OPpFLIP_LINENUM) {
994 if (GvIO(PL_last_in_gv)) {
995 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
998 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
999 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1005 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1006 if (PL_op->op_flags & OPf_SPECIAL) {
1014 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1027 if (GIMME == G_ARRAY) {
1033 if (SvGMAGICAL(left))
1035 if (SvGMAGICAL(right))
1038 /* This code tries to decide if "$left .. $right" should use the
1039 magical string increment, or if the range is numeric (we make
1040 an exception for .."0" [#18165]). AMS 20021031. */
1042 if (SvNIOKp(left) || !SvPOKp(left) ||
1043 SvNIOKp(right) || !SvPOKp(right) ||
1044 (looks_like_number(left) && *SvPVX(left) != '0' &&
1045 looks_like_number(right)))
1047 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1048 DIE(aTHX_ "Range iterator outside integer range");
1059 sv = sv_2mortal(newSViv(i++));
1064 SV *final = sv_mortalcopy(right);
1066 char *tmps = SvPV(final, len);
1068 sv = sv_mortalcopy(left);
1070 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1072 if (strEQ(SvPVX(sv),tmps))
1074 sv = sv_2mortal(newSVsv(sv));
1081 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1085 if (PL_op->op_private & OPpFLIP_LINENUM) {
1086 if (GvIO(PL_last_in_gv)) {
1087 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1090 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1091 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1099 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1100 sv_catpv(targ, "E0");
1110 static char *context_name[] = {
1121 S_dopoptolabel(pTHX_ char *label)
1124 register PERL_CONTEXT *cx;
1126 for (i = cxstack_ix; i >= 0; i--) {
1128 switch (CxTYPE(cx)) {
1134 if (ckWARN(WARN_EXITING))
1135 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1136 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1137 if (CxTYPE(cx) == CXt_NULL)
1141 if (!cx->blk_loop.label ||
1142 strNE(label, cx->blk_loop.label) ) {
1143 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1144 (long)i, cx->blk_loop.label));
1147 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1155 Perl_dowantarray(pTHX)
1157 I32 gimme = block_gimme();
1158 return (gimme == G_VOID) ? G_SCALAR : gimme;
1162 Perl_block_gimme(pTHX)
1166 cxix = dopoptosub(cxstack_ix);
1170 switch (cxstack[cxix].blk_gimme) {
1178 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1185 Perl_is_lvalue_sub(pTHX)
1189 cxix = dopoptosub(cxstack_ix);
1190 assert(cxix >= 0); /* We should only be called from inside subs */
1192 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1193 return cxstack[cxix].blk_sub.lval;
1199 S_dopoptosub(pTHX_ I32 startingblock)
1201 return dopoptosub_at(cxstack, startingblock);
1205 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1208 register PERL_CONTEXT *cx;
1209 for (i = startingblock; i >= 0; i--) {
1211 switch (CxTYPE(cx)) {
1217 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1225 S_dopoptoeval(pTHX_ I32 startingblock)
1228 register PERL_CONTEXT *cx;
1229 for (i = startingblock; i >= 0; i--) {
1231 switch (CxTYPE(cx)) {
1235 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1243 S_dopoptoloop(pTHX_ I32 startingblock)
1246 register PERL_CONTEXT *cx;
1247 for (i = startingblock; i >= 0; i--) {
1249 switch (CxTYPE(cx)) {
1255 if (ckWARN(WARN_EXITING))
1256 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1257 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1258 if ((CxTYPE(cx)) == CXt_NULL)
1262 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1270 Perl_dounwind(pTHX_ I32 cxix)
1272 register PERL_CONTEXT *cx;
1275 while (cxstack_ix > cxix) {
1277 cx = &cxstack[cxstack_ix];
1278 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1279 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1280 /* Note: we don't need to restore the base context info till the end. */
1281 switch (CxTYPE(cx)) {
1284 continue; /* not break */
1306 Perl_qerror(pTHX_ SV *err)
1309 sv_catsv(ERRSV, err);
1311 sv_catsv(PL_errors, err);
1313 Perl_warn(aTHX_ "%"SVf, err);
1318 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1326 register PERL_CONTEXT *cx;
1331 if (PL_in_eval & EVAL_KEEPERR) {
1332 static char prefix[] = "\t(in cleanup) ";
1337 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1340 if (*e != *message || strNE(e,message))
1344 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1345 sv_catpvn(err, prefix, sizeof(prefix)-1);
1346 sv_catpvn(err, message, msglen);
1347 if (ckWARN(WARN_MISC)) {
1348 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1349 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1354 sv_setpvn(ERRSV, message, msglen);
1358 message = SvPVx(ERRSV, msglen);
1360 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1361 && PL_curstackinfo->si_prev)
1370 if (cxix < cxstack_ix)
1373 POPBLOCK(cx,PL_curpm);
1374 if (CxTYPE(cx) != CXt_EVAL) {
1375 PerlIO_write(Perl_error_log, "panic: die ", 11);
1376 PerlIO_write(Perl_error_log, message, msglen);
1381 if (gimme == G_SCALAR)
1382 *++newsp = &PL_sv_undef;
1383 PL_stack_sp = newsp;
1387 /* LEAVE could clobber PL_curcop (see save_re_context())
1388 * XXX it might be better to find a way to avoid messing with
1389 * PL_curcop in save_re_context() instead, but this is a more
1390 * minimal fix --GSAR */
1391 PL_curcop = cx->blk_oldcop;
1393 if (optype == OP_REQUIRE) {
1394 char* msg = SvPVx(ERRSV, n_a);
1395 DIE(aTHX_ "%sCompilation failed in require",
1396 *msg ? msg : "Unknown error\n");
1398 return pop_return();
1402 message = SvPVx(ERRSV, msglen);
1404 /* if STDERR is tied, print to it instead */
1405 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1406 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1409 XPUSHs(SvTIED_obj((SV*)io, mg));
1410 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1412 call_method("PRINT", G_SCALAR);
1417 /* SFIO can really mess with your errno */
1420 PerlIO *serr = Perl_error_log;
1422 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1423 (void)PerlIO_flush(serr);
1436 if (SvTRUE(left) != SvTRUE(right))
1448 RETURNOP(cLOGOP->op_other);
1457 RETURNOP(cLOGOP->op_other);
1466 if (!sv || !SvANY(sv)) {
1467 RETURNOP(cLOGOP->op_other);
1470 switch (SvTYPE(sv)) {
1472 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1476 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1480 if (CvROOT(sv) || CvXSUB(sv))
1490 RETURNOP(cLOGOP->op_other);
1496 register I32 cxix = dopoptosub(cxstack_ix);
1497 register PERL_CONTEXT *cx;
1498 register PERL_CONTEXT *ccstack = cxstack;
1499 PERL_SI *top_si = PL_curstackinfo;
1510 /* we may be in a higher stacklevel, so dig down deeper */
1511 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1512 top_si = top_si->si_prev;
1513 ccstack = top_si->si_cxstack;
1514 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1517 if (GIMME != G_ARRAY) {
1523 if (PL_DBsub && cxix >= 0 &&
1524 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1528 cxix = dopoptosub_at(ccstack, cxix - 1);
1531 cx = &ccstack[cxix];
1532 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1533 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1534 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1535 field below is defined for any cx. */
1536 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1537 cx = &ccstack[dbcxix];
1540 stashname = CopSTASHPV(cx->blk_oldcop);
1541 if (GIMME != G_ARRAY) {
1544 PUSHs(&PL_sv_undef);
1547 sv_setpv(TARG, stashname);
1556 PUSHs(&PL_sv_undef);
1558 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1559 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1560 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1563 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1564 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1565 /* So is ccstack[dbcxix]. */
1568 gv_efullname3(sv, cvgv, Nullch);
1569 PUSHs(sv_2mortal(sv));
1570 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1573 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1574 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1578 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1579 PUSHs(sv_2mortal(newSViv(0)));
1581 gimme = (I32)cx->blk_gimme;
1582 if (gimme == G_VOID)
1583 PUSHs(&PL_sv_undef);
1585 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1586 if (CxTYPE(cx) == CXt_EVAL) {
1588 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1589 PUSHs(cx->blk_eval.cur_text);
1593 else if (cx->blk_eval.old_namesv) {
1594 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1597 /* eval BLOCK (try blocks have old_namesv == 0) */
1599 PUSHs(&PL_sv_undef);
1600 PUSHs(&PL_sv_undef);
1604 PUSHs(&PL_sv_undef);
1605 PUSHs(&PL_sv_undef);
1607 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1608 && CopSTASH_eq(PL_curcop, PL_debstash))
1610 AV *ary = cx->blk_sub.argarray;
1611 int off = AvARRAY(ary) - AvALLOC(ary);
1615 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1618 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1621 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1622 av_extend(PL_dbargs, AvFILLp(ary) + off);
1623 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1624 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1626 /* XXX only hints propagated via op_private are currently
1627 * visible (others are not easily accessible, since they
1628 * use the global PL_hints) */
1629 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1630 HINT_PRIVATE_MASK)));
1633 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1635 if (old_warnings == pWARN_NONE ||
1636 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1637 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1638 else if (old_warnings == pWARN_ALL ||
1639 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1640 /* Get the bit mask for $warnings::Bits{all}, because
1641 * it could have been extended by warnings::register */
1643 HV *bits = get_hv("warnings::Bits", FALSE);
1644 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1645 mask = newSVsv(*bits_all);
1648 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1652 mask = newSVsv(old_warnings);
1653 PUSHs(sv_2mortal(mask));
1668 sv_reset(tmps, CopSTASH(PL_curcop));
1678 /* like pp_nextstate, but used instead when the debugger is active */
1682 PL_curcop = (COP*)PL_op;
1683 TAINT_NOT; /* Each statement is presumed innocent */
1684 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1687 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1688 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1692 register PERL_CONTEXT *cx;
1693 I32 gimme = G_ARRAY;
1700 DIE(aTHX_ "No DB::DB routine defined");
1702 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1703 /* don't do recursive DB::DB call */
1715 push_return(PL_op->op_next);
1716 PUSHBLOCK(cx, CXt_SUB, SP);
1719 (void)SvREFCNT_inc(cv);
1720 PAD_SET_CUR(CvPADLIST(cv),1);
1721 RETURNOP(CvSTART(cv));
1735 register PERL_CONTEXT *cx;
1736 I32 gimme = GIMME_V;
1738 U32 cxtype = CXt_LOOP;
1746 if (PL_op->op_targ) {
1747 #ifndef USE_ITHREADS
1748 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1751 SAVEPADSV(PL_op->op_targ);
1752 iterdata = INT2PTR(void*, PL_op->op_targ);
1753 cxtype |= CXp_PADVAR;
1758 svp = &GvSV(gv); /* symbol table variable */
1759 SAVEGENERICSV(*svp);
1762 iterdata = (void*)gv;
1768 PUSHBLOCK(cx, cxtype, SP);
1770 PUSHLOOP(cx, iterdata, MARK);
1772 PUSHLOOP(cx, svp, MARK);
1774 if (PL_op->op_flags & OPf_STACKED) {
1775 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1776 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1778 /* See comment in pp_flop() */
1779 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1780 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1781 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1782 looks_like_number((SV*)cx->blk_loop.iterary)))
1784 if (SvNV(sv) < IV_MIN ||
1785 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1786 DIE(aTHX_ "Range iterator outside integer range");
1787 cx->blk_loop.iterix = SvIV(sv);
1788 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1791 cx->blk_loop.iterlval = newSVsv(sv);
1795 cx->blk_loop.iterary = PL_curstack;
1796 AvFILLp(PL_curstack) = SP - PL_stack_base;
1797 cx->blk_loop.iterix = MARK - PL_stack_base;
1806 register PERL_CONTEXT *cx;
1807 I32 gimme = GIMME_V;
1813 PUSHBLOCK(cx, CXt_LOOP, SP);
1814 PUSHLOOP(cx, 0, SP);
1822 register PERL_CONTEXT *cx;
1830 newsp = PL_stack_base + cx->blk_loop.resetsp;
1833 if (gimme == G_VOID)
1835 else if (gimme == G_SCALAR) {
1837 *++newsp = sv_mortalcopy(*SP);
1839 *++newsp = &PL_sv_undef;
1843 *++newsp = sv_mortalcopy(*++mark);
1844 TAINT_NOT; /* Each item is independent */
1850 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1851 PL_curpm = newpm; /* ... and pop $1 et al */
1863 register PERL_CONTEXT *cx;
1864 bool popsub2 = FALSE;
1865 bool clear_errsv = FALSE;
1872 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1873 if (cxstack_ix == PL_sortcxix
1874 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1876 if (cxstack_ix > PL_sortcxix)
1877 dounwind(PL_sortcxix);
1878 AvARRAY(PL_curstack)[1] = *SP;
1879 PL_stack_sp = PL_stack_base + 1;
1884 cxix = dopoptosub(cxstack_ix);
1886 DIE(aTHX_ "Can't return outside a subroutine");
1887 if (cxix < cxstack_ix)
1891 switch (CxTYPE(cx)) {
1896 if (!(PL_in_eval & EVAL_KEEPERR))
1902 if (optype == OP_REQUIRE &&
1903 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1905 /* Unassume the success we assumed earlier. */
1906 SV *nsv = cx->blk_eval.old_namesv;
1907 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1908 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1915 DIE(aTHX_ "panic: return");
1919 if (gimme == G_SCALAR) {
1922 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1924 *++newsp = SvREFCNT_inc(*SP);
1929 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1931 *++newsp = sv_mortalcopy(sv);
1936 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1939 *++newsp = sv_mortalcopy(*SP);
1942 *++newsp = &PL_sv_undef;
1944 else if (gimme == G_ARRAY) {
1945 while (++MARK <= SP) {
1946 *++newsp = (popsub2 && SvTEMP(*MARK))
1947 ? *MARK : sv_mortalcopy(*MARK);
1948 TAINT_NOT; /* Each item is independent */
1951 PL_stack_sp = newsp;
1954 /* Stack values are safe: */
1956 POPSUB(cx,sv); /* release CV and @_ ... */
1960 PL_curpm = newpm; /* ... and pop $1 et al */
1965 return pop_return();
1972 register PERL_CONTEXT *cx;
1982 if (PL_op->op_flags & OPf_SPECIAL) {
1983 cxix = dopoptoloop(cxstack_ix);
1985 DIE(aTHX_ "Can't \"last\" outside a loop block");
1988 cxix = dopoptolabel(cPVOP->op_pv);
1990 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1992 if (cxix < cxstack_ix)
1997 switch (CxTYPE(cx)) {
2000 newsp = PL_stack_base + cx->blk_loop.resetsp;
2001 nextop = cx->blk_loop.last_op->op_next;
2005 nextop = pop_return();
2009 nextop = pop_return();
2013 nextop = pop_return();
2016 DIE(aTHX_ "panic: last");
2020 if (gimme == G_SCALAR) {
2022 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2023 ? *SP : sv_mortalcopy(*SP);
2025 *++newsp = &PL_sv_undef;
2027 else if (gimme == G_ARRAY) {
2028 while (++MARK <= SP) {
2029 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2030 ? *MARK : sv_mortalcopy(*MARK);
2031 TAINT_NOT; /* Each item is independent */
2038 /* Stack values are safe: */
2041 POPLOOP(cx); /* release loop vars ... */
2045 POPSUB(cx,sv); /* release CV and @_ ... */
2048 PL_curpm = newpm; /* ... and pop $1 et al */
2057 register PERL_CONTEXT *cx;
2060 if (PL_op->op_flags & OPf_SPECIAL) {
2061 cxix = dopoptoloop(cxstack_ix);
2063 DIE(aTHX_ "Can't \"next\" outside a loop block");
2066 cxix = dopoptolabel(cPVOP->op_pv);
2068 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2070 if (cxix < cxstack_ix)
2073 /* clear off anything above the scope we're re-entering, but
2074 * save the rest until after a possible continue block */
2075 inner = PL_scopestack_ix;
2077 if (PL_scopestack_ix < inner)
2078 leave_scope(PL_scopestack[PL_scopestack_ix]);
2079 return cx->blk_loop.next_op;
2085 register PERL_CONTEXT *cx;
2088 if (PL_op->op_flags & OPf_SPECIAL) {
2089 cxix = dopoptoloop(cxstack_ix);
2091 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2094 cxix = dopoptolabel(cPVOP->op_pv);
2096 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2098 if (cxix < cxstack_ix)
2102 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2103 LEAVE_SCOPE(oldsave);
2104 return cx->blk_loop.redo_op;
2108 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2112 static char too_deep[] = "Target of goto is too deeply nested";
2115 Perl_croak(aTHX_ too_deep);
2116 if (o->op_type == OP_LEAVE ||
2117 o->op_type == OP_SCOPE ||
2118 o->op_type == OP_LEAVELOOP ||
2119 o->op_type == OP_LEAVESUB ||
2120 o->op_type == OP_LEAVETRY)
2122 *ops++ = cUNOPo->op_first;
2124 Perl_croak(aTHX_ too_deep);
2127 if (o->op_flags & OPf_KIDS) {
2128 /* First try all the kids at this level, since that's likeliest. */
2129 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2130 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2131 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2134 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2135 if (kid == PL_lastgotoprobe)
2137 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2140 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2141 ops[-1]->op_type == OP_DBSTATE)
2146 if ((o = dofindlabel(kid, label, ops, oplimit)))
2165 register PERL_CONTEXT *cx;
2166 #define GOTO_DEPTH 64
2167 OP *enterops[GOTO_DEPTH];
2169 int do_dump = (PL_op->op_type == OP_DUMP);
2170 static char must_have_label[] = "goto must have label";
2173 if (PL_op->op_flags & OPf_STACKED) {
2177 /* This egregious kludge implements goto &subroutine */
2178 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2180 register PERL_CONTEXT *cx;
2181 CV* cv = (CV*)SvRV(sv);
2187 if (!CvROOT(cv) && !CvXSUB(cv)) {
2192 /* autoloaded stub? */
2193 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2195 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2196 GvNAMELEN(gv), FALSE);
2197 if (autogv && (cv = GvCV(autogv)))
2199 tmpstr = sv_newmortal();
2200 gv_efullname3(tmpstr, gv, Nullch);
2201 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2203 DIE(aTHX_ "Goto undefined subroutine");
2206 /* First do some returnish stuff. */
2207 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2209 cxix = dopoptosub(cxstack_ix);
2211 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2212 if (cxix < cxstack_ix)
2216 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2218 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2219 /* put @_ back onto stack */
2220 AV* av = cx->blk_sub.argarray;
2222 items = AvFILLp(av) + 1;
2224 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2225 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2226 PL_stack_sp += items;
2227 SvREFCNT_dec(GvAV(PL_defgv));
2228 GvAV(PL_defgv) = cx->blk_sub.savearray;
2229 /* abandon @_ if it got reified */
2231 (void)sv_2mortal((SV*)av); /* delay until return */
2233 av_extend(av, items-1);
2234 AvFLAGS(av) = AVf_REIFY;
2235 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2238 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2240 av = GvAV(PL_defgv);
2241 items = AvFILLp(av) + 1;
2243 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2244 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2245 PL_stack_sp += items;
2247 if (CxTYPE(cx) == CXt_SUB &&
2248 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2249 SvREFCNT_dec(cx->blk_sub.cv);
2250 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2251 LEAVE_SCOPE(oldsave);
2253 /* Now do some callish stuff. */
2255 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2257 #ifdef PERL_XSUB_OLDSTYLE
2258 if (CvOLDSTYLE(cv)) {
2259 I32 (*fp3)(int,int,int);
2264 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2265 items = (*fp3)(CvXSUBANY(cv).any_i32,
2266 mark - PL_stack_base + 1,
2268 SP = PL_stack_base + items;
2271 #endif /* PERL_XSUB_OLDSTYLE */
2276 PL_stack_sp--; /* There is no cv arg. */
2277 /* Push a mark for the start of arglist */
2279 (void)(*CvXSUB(cv))(aTHX_ cv);
2280 /* Pop the current context like a decent sub should */
2281 POPBLOCK(cx, PL_curpm);
2282 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2285 return pop_return();
2288 AV* padlist = CvPADLIST(cv);
2289 if (CxTYPE(cx) == CXt_EVAL) {
2290 PL_in_eval = cx->blk_eval.old_in_eval;
2291 PL_eval_root = cx->blk_eval.old_eval_root;
2292 cx->cx_type = CXt_SUB;
2293 cx->blk_sub.hasargs = 0;
2295 cx->blk_sub.cv = cv;
2296 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2299 if (CvDEPTH(cv) < 2)
2300 (void)SvREFCNT_inc(cv);
2302 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2303 sub_crush_depth(cv);
2304 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2306 PAD_SET_CUR(padlist, CvDEPTH(cv));
2307 if (cx->blk_sub.hasargs)
2309 AV* av = (AV*)PAD_SVl(0);
2312 cx->blk_sub.savearray = GvAV(PL_defgv);
2313 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2314 CX_CURPAD_SAVE(cx->blk_sub);
2315 cx->blk_sub.argarray = av;
2318 if (items >= AvMAX(av) + 1) {
2320 if (AvARRAY(av) != ary) {
2321 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2322 SvPVX(av) = (char*)ary;
2324 if (items >= AvMAX(av) + 1) {
2325 AvMAX(av) = items - 1;
2326 Renew(ary,items+1,SV*);
2328 SvPVX(av) = (char*)ary;
2331 Copy(mark,AvARRAY(av),items,SV*);
2332 AvFILLp(av) = items - 1;
2333 assert(!AvREAL(av));
2340 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2342 * We do not care about using sv to call CV;
2343 * it's for informational purposes only.
2345 SV *sv = GvSV(PL_DBsub);
2348 if (PERLDB_SUB_NN) {
2349 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2352 gv_efullname3(sv, CvGV(cv), Nullch);
2355 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2356 PUSHMARK( PL_stack_sp );
2357 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2361 RETURNOP(CvSTART(cv));
2365 label = SvPV(sv,n_a);
2366 if (!(do_dump || *label))
2367 DIE(aTHX_ must_have_label);
2370 else if (PL_op->op_flags & OPf_SPECIAL) {
2372 DIE(aTHX_ must_have_label);
2375 label = cPVOP->op_pv;
2377 if (label && *label) {
2379 bool leaving_eval = FALSE;
2380 bool in_block = FALSE;
2381 PERL_CONTEXT *last_eval_cx = 0;
2385 PL_lastgotoprobe = 0;
2387 for (ix = cxstack_ix; ix >= 0; ix--) {
2389 switch (CxTYPE(cx)) {
2391 leaving_eval = TRUE;
2392 if (CxREALEVAL(cx)) {
2393 gotoprobe = (last_eval_cx ?
2394 last_eval_cx->blk_eval.old_eval_root :
2399 /* else fall through */
2401 gotoprobe = cx->blk_oldcop->op_sibling;
2407 gotoprobe = cx->blk_oldcop->op_sibling;
2410 gotoprobe = PL_main_root;
2413 if (CvDEPTH(cx->blk_sub.cv)) {
2414 gotoprobe = CvROOT(cx->blk_sub.cv);
2420 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2423 DIE(aTHX_ "panic: goto");
2424 gotoprobe = PL_main_root;
2428 retop = dofindlabel(gotoprobe, label,
2429 enterops, enterops + GOTO_DEPTH);
2433 PL_lastgotoprobe = gotoprobe;
2436 DIE(aTHX_ "Can't find label %s", label);
2438 /* if we're leaving an eval, check before we pop any frames
2439 that we're not going to punt, otherwise the error
2442 if (leaving_eval && *enterops && enterops[1]) {
2444 for (i = 1; enterops[i]; i++)
2445 if (enterops[i]->op_type == OP_ENTERITER)
2446 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2449 /* pop unwanted frames */
2451 if (ix < cxstack_ix) {
2458 oldsave = PL_scopestack[PL_scopestack_ix];
2459 LEAVE_SCOPE(oldsave);
2462 /* push wanted frames */
2464 if (*enterops && enterops[1]) {
2466 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2467 for (; enterops[ix]; ix++) {
2468 PL_op = enterops[ix];
2469 /* Eventually we may want to stack the needed arguments
2470 * for each op. For now, we punt on the hard ones. */
2471 if (PL_op->op_type == OP_ENTERITER)
2472 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2473 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2481 if (!retop) retop = PL_main_start;
2483 PL_restartop = retop;
2484 PL_do_undump = TRUE;
2488 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2489 PL_do_undump = FALSE;
2505 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2507 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2510 PL_exit_flags |= PERL_EXIT_EXPECTED;
2512 PUSHs(&PL_sv_undef);
2520 NV value = SvNVx(GvSV(cCOP->cop_gv));
2521 register I32 match = I_32(value);
2524 if (((NV)match) > value)
2525 --match; /* was fractional--truncate other way */
2527 match -= cCOP->uop.scop.scop_offset;
2530 else if (match > cCOP->uop.scop.scop_max)
2531 match = cCOP->uop.scop.scop_max;
2532 PL_op = cCOP->uop.scop.scop_next[match];
2542 PL_op = PL_op->op_next; /* can't assume anything */
2545 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2546 match -= cCOP->uop.scop.scop_offset;
2549 else if (match > cCOP->uop.scop.scop_max)
2550 match = cCOP->uop.scop.scop_max;
2551 PL_op = cCOP->uop.scop.scop_next[match];
2560 S_save_lines(pTHX_ AV *array, SV *sv)
2562 register char *s = SvPVX(sv);
2563 register char *send = SvPVX(sv) + SvCUR(sv);
2565 register I32 line = 1;
2567 while (s && s < send) {
2568 SV *tmpstr = NEWSV(85,0);
2570 sv_upgrade(tmpstr, SVt_PVMG);
2571 t = strchr(s, '\n');
2577 sv_setpvn(tmpstr, s, t - s);
2578 av_store(array, line++, tmpstr);
2583 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2585 S_docatch_body(pTHX_ va_list args)
2587 return docatch_body();
2592 S_docatch_body(pTHX)
2599 S_docatch(pTHX_ OP *o)
2604 volatile PERL_SI *cursi = PL_curstackinfo;
2608 assert(CATCH_GET == TRUE);
2612 /* Normally, the leavetry at the end of this block of ops will
2613 * pop an op off the return stack and continue there. By setting
2614 * the op to Nullop, we force an exit from the inner runops()
2617 retop = pop_return();
2618 push_return(Nullop);
2620 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2622 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2628 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2634 /* die caught by an inner eval - continue inner loop */
2635 if (PL_restartop && cursi == PL_curstackinfo) {
2636 PL_op = PL_restartop;
2640 /* a die in this eval - continue in outer loop */
2656 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2657 /* sv Text to convert to OP tree. */
2658 /* startop op_free() this to undo. */
2659 /* code Short string id of the caller. */
2661 dSP; /* Make POPBLOCK work. */
2664 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2668 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2669 char *tmpbuf = tbuf;
2672 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2677 /* switch to eval mode */
2679 if (PL_curcop == &PL_compiling) {
2680 SAVECOPSTASH_FREE(&PL_compiling);
2681 CopSTASH_set(&PL_compiling, PL_curstash);
2683 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2684 SV *sv = sv_newmortal();
2685 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2686 code, (unsigned long)++PL_evalseq,
2687 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2691 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2692 SAVECOPFILE_FREE(&PL_compiling);
2693 CopFILE_set(&PL_compiling, tmpbuf+2);
2694 SAVECOPLINE(&PL_compiling);
2695 CopLINE_set(&PL_compiling, 1);
2696 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2697 deleting the eval's FILEGV from the stash before gv_check() runs
2698 (i.e. before run-time proper). To work around the coredump that
2699 ensues, we always turn GvMULTI_on for any globals that were
2700 introduced within evals. See force_ident(). GSAR 96-10-12 */
2701 safestr = savepv(tmpbuf);
2702 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2704 #ifdef OP_IN_REGISTER
2709 PL_hints &= HINT_UTF8;
2711 /* we get here either during compilation, or via pp_regcomp at runtime */
2712 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2714 runcv = find_runcv(NULL);
2717 PL_op->op_type = OP_ENTEREVAL;
2718 PL_op->op_flags = 0; /* Avoid uninit warning. */
2719 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2720 PUSHEVAL(cx, 0, Nullgv);
2723 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2725 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2726 POPBLOCK(cx,PL_curpm);
2729 (*startop)->op_type = OP_NULL;
2730 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2732 /* XXX DAPM do this properly one year */
2733 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2735 if (PL_curcop == &PL_compiling)
2736 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2737 #ifdef OP_IN_REGISTER
2745 =for apidoc find_runcv
2747 Locate the CV corresponding to the currently executing sub or eval.
2748 If db_seqp is non_null, skip CVs that are in the DB package and populate
2749 *db_seqp with the cop sequence number at the point that the DB:: code was
2750 entered. (allows debuggers to eval in the scope of the breakpoint rather
2751 than in in the scope of the debuger itself).
2757 Perl_find_runcv(pTHX_ U32 *db_seqp)
2764 *db_seqp = PL_curcop->cop_seq;
2765 for (si = PL_curstackinfo; si; si = si->si_prev) {
2766 for (ix = si->si_cxix; ix >= 0; ix--) {
2767 cx = &(si->si_cxstack[ix]);
2768 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2769 CV *cv = cx->blk_sub.cv;
2770 /* skip DB:: code */
2771 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2772 *db_seqp = cx->blk_oldcop->cop_seq;
2777 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2785 /* Compile a require/do, an eval '', or a /(?{...})/.
2786 * In the last case, startop is non-null, and contains the address of
2787 * a pointer that should be set to the just-compiled code.
2788 * outside is the lexically enclosing CV (if any) that invoked us.
2791 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2793 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2798 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2799 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2804 SAVESPTR(PL_compcv);
2805 PL_compcv = (CV*)NEWSV(1104,0);
2806 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2807 CvEVAL_on(PL_compcv);
2808 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2809 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2811 CvOUTSIDE_SEQ(PL_compcv) = seq;
2812 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2814 /* set up a scratch pad */
2816 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2819 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2821 /* make sure we compile in the right package */
2823 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2824 SAVESPTR(PL_curstash);
2825 PL_curstash = CopSTASH(PL_curcop);
2827 SAVESPTR(PL_beginav);
2828 PL_beginav = newAV();
2829 SAVEFREESV(PL_beginav);
2830 SAVEI32(PL_error_count);
2832 /* try to compile it */
2834 PL_eval_root = Nullop;
2836 PL_curcop = &PL_compiling;
2837 PL_curcop->cop_arybase = 0;
2838 if (saveop && saveop->op_flags & OPf_SPECIAL)
2839 PL_in_eval |= EVAL_KEEPERR;
2842 if (yyparse() || PL_error_count || !PL_eval_root) {
2846 I32 optype = 0; /* Might be reset by POPEVAL. */
2851 op_free(PL_eval_root);
2852 PL_eval_root = Nullop;
2854 SP = PL_stack_base + POPMARK; /* pop original mark */
2856 POPBLOCK(cx,PL_curpm);
2862 if (optype == OP_REQUIRE) {
2863 char* msg = SvPVx(ERRSV, n_a);
2864 DIE(aTHX_ "%sCompilation failed in require",
2865 *msg ? msg : "Unknown error\n");
2868 char* msg = SvPVx(ERRSV, n_a);
2870 POPBLOCK(cx,PL_curpm);
2872 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2873 (*msg ? msg : "Unknown error\n"));
2876 char* msg = SvPVx(ERRSV, n_a);
2878 sv_setpv(ERRSV, "Compilation error");
2883 CopLINE_set(&PL_compiling, 0);
2885 *startop = PL_eval_root;
2887 SAVEFREEOP(PL_eval_root);
2888 if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE)
2890 * EVAL_INREQUIRE (the code is being required) is special-cased :
2891 * in this case we want scalar context to be forced, instead
2892 * of void context, so a proper return value is returned from
2893 * C<require> via this leaveeval op.
2895 scalarvoid(PL_eval_root);
2896 else if (gimme & G_ARRAY)
2899 scalar(PL_eval_root);
2901 DEBUG_x(dump_eval());
2903 /* Register with debugger: */
2904 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2905 CV *cv = get_cv("DB::postponed", FALSE);
2909 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2911 call_sv((SV*)cv, G_DISCARD);
2915 /* compiled okay, so do it */
2917 CvDEPTH(PL_compcv) = 1;
2918 SP = PL_stack_base + POPMARK; /* pop original mark */
2919 PL_op = saveop; /* The caller may need it. */
2920 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2922 RETURNOP(PL_eval_start);
2926 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2928 STRLEN namelen = strlen(name);
2931 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2932 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2933 char *pmc = SvPV_nolen(pmcsv);
2936 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2937 fp = PerlIO_open(name, mode);
2940 if (PerlLIO_stat(name, &pmstat) < 0 ||
2941 pmstat.st_mtime < pmcstat.st_mtime)
2943 fp = PerlIO_open(pmc, mode);
2946 fp = PerlIO_open(name, mode);
2949 SvREFCNT_dec(pmcsv);
2952 fp = PerlIO_open(name, mode);
2960 register PERL_CONTEXT *cx;
2964 char *tryname = Nullch;
2965 SV *namesv = Nullsv;
2967 I32 gimme = GIMME_V;
2968 PerlIO *tryrsfp = 0;
2970 int filter_has_file = 0;
2971 GV *filter_child_proc = 0;
2972 SV *filter_state = 0;
2979 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2980 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2981 UV rev = 0, ver = 0, sver = 0;
2983 U8 *s = (U8*)SvPVX(sv);
2984 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2986 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2989 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2992 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2995 if (PERL_REVISION < rev
2996 || (PERL_REVISION == rev
2997 && (PERL_VERSION < ver
2998 || (PERL_VERSION == ver
2999 && PERL_SUBVERSION < sver))))
3001 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3002 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3003 PERL_VERSION, PERL_SUBVERSION);
3005 if (ckWARN(WARN_PORTABLE))
3006 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3007 "v-string in use/require non-portable");
3010 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3011 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3012 + ((NV)PERL_SUBVERSION/(NV)1000000)
3013 + 0.00000099 < SvNV(sv))
3017 NV nver = (nrev - rev) * 1000;
3018 UV ver = (UV)(nver + 0.0009);
3019 NV nsver = (nver - ver) * 1000;
3020 UV sver = (UV)(nsver + 0.0009);
3022 /* help out with the "use 5.6" confusion */
3023 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3024 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3025 " (did you mean v%"UVuf".%03"UVuf"?)--"
3026 "this is only v%d.%d.%d, stopped",
3027 rev, ver, sver, rev, ver/100,
3028 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3031 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3032 "this is only v%d.%d.%d, stopped",
3033 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3040 name = SvPV(sv, len);
3041 if (!(name && len > 0 && *name))
3042 DIE(aTHX_ "Null filename used");
3043 TAINT_PROPER("require");
3044 if (PL_op->op_type == OP_REQUIRE &&
3045 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3046 *svp != &PL_sv_undef)
3049 /* prepare to compile file */
3051 if (path_is_absolute(name)) {
3053 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3055 #ifdef MACOS_TRADITIONAL
3059 MacPerl_CanonDir(name, newname, 1);
3060 if (path_is_absolute(newname)) {
3062 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3067 AV *ar = GvAVn(PL_incgv);
3071 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3074 namesv = NEWSV(806, 0);
3075 for (i = 0; i <= AvFILL(ar); i++) {
3076 SV *dirsv = *av_fetch(ar, i, TRUE);
3082 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3083 && !sv_isobject(loader))
3085 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3088 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3089 PTR2UV(SvRV(dirsv)), name);
3090 tryname = SvPVX(namesv);
3101 if (sv_isobject(loader))
3102 count = call_method("INC", G_ARRAY);
3104 count = call_sv(loader, G_ARRAY);
3114 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3118 if (SvTYPE(arg) == SVt_PVGV) {
3119 IO *io = GvIO((GV *)arg);
3124 tryrsfp = IoIFP(io);
3125 if (IoTYPE(io) == IoTYPE_PIPE) {
3126 /* reading from a child process doesn't
3127 nest -- when returning from reading
3128 the inner module, the outer one is
3129 unreadable (closed?) I've tried to
3130 save the gv to manage the lifespan of
3131 the pipe, but this didn't help. XXX */
3132 filter_child_proc = (GV *)arg;
3133 (void)SvREFCNT_inc(filter_child_proc);
3136 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3137 PerlIO_close(IoOFP(io));
3149 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3151 (void)SvREFCNT_inc(filter_sub);
3154 filter_state = SP[i];
3155 (void)SvREFCNT_inc(filter_state);
3159 tryrsfp = PerlIO_open("/dev/null",
3174 filter_has_file = 0;
3175 if (filter_child_proc) {
3176 SvREFCNT_dec(filter_child_proc);
3177 filter_child_proc = 0;
3180 SvREFCNT_dec(filter_state);
3184 SvREFCNT_dec(filter_sub);
3189 if (!path_is_absolute(name)
3190 #ifdef MACOS_TRADITIONAL
3191 /* We consider paths of the form :a:b ambiguous and interpret them first
3192 as global then as local
3194 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3197 char *dir = SvPVx(dirsv, n_a);
3198 #ifdef MACOS_TRADITIONAL
3202 MacPerl_CanonDir(name, buf2, 1);
3203 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3207 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3209 sv_setpv(namesv, unixdir);
3210 sv_catpv(namesv, unixname);
3212 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3215 TAINT_PROPER("require");
3216 tryname = SvPVX(namesv);
3217 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3219 if (tryname[0] == '.' && tryname[1] == '/')
3228 SAVECOPFILE_FREE(&PL_compiling);
3229 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3230 SvREFCNT_dec(namesv);
3232 if (PL_op->op_type == OP_REQUIRE) {
3233 char *msgstr = name;
3234 if (namesv) { /* did we lookup @INC? */
3235 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3236 SV *dirmsgsv = NEWSV(0, 0);
3237 AV *ar = GvAVn(PL_incgv);
3239 sv_catpvn(msg, " in @INC", 8);
3240 if (instr(SvPVX(msg), ".h "))
3241 sv_catpv(msg, " (change .h to .ph maybe?)");
3242 if (instr(SvPVX(msg), ".ph "))
3243 sv_catpv(msg, " (did you run h2ph?)");
3244 sv_catpv(msg, " (@INC contains:");
3245 for (i = 0; i <= AvFILL(ar); i++) {
3246 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3247 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3248 sv_catsv(msg, dirmsgsv);
3250 sv_catpvn(msg, ")", 1);
3251 SvREFCNT_dec(dirmsgsv);
3252 msgstr = SvPV_nolen(msg);
3254 DIE(aTHX_ "Can't locate %s", msgstr);
3260 SETERRNO(0, SS_NORMAL);
3262 /* Assume success here to prevent recursive requirement. */
3264 /* Check whether a hook in @INC has already filled %INC */
3265 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3266 (void)hv_store(GvHVn(PL_incgv), name, len,
3267 (hook_sv ? SvREFCNT_inc(hook_sv)
3268 : newSVpv(CopFILE(&PL_compiling), 0)),
3274 lex_start(sv_2mortal(newSVpvn("",0)));
3275 SAVEGENERICSV(PL_rsfp_filters);
3276 PL_rsfp_filters = Nullav;
3281 SAVESPTR(PL_compiling.cop_warnings);
3282 if (PL_dowarn & G_WARN_ALL_ON)
3283 PL_compiling.cop_warnings = pWARN_ALL ;
3284 else if (PL_dowarn & G_WARN_ALL_OFF)
3285 PL_compiling.cop_warnings = pWARN_NONE ;
3286 else if (PL_taint_warn)
3287 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3289 PL_compiling.cop_warnings = pWARN_STD ;
3290 SAVESPTR(PL_compiling.cop_io);
3291 PL_compiling.cop_io = Nullsv;
3293 if (filter_sub || filter_child_proc) {
3294 SV *datasv = filter_add(run_user_filter, Nullsv);
3295 IoLINES(datasv) = filter_has_file;
3296 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3297 IoTOP_GV(datasv) = (GV *)filter_state;
3298 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3301 /* switch to eval mode */
3302 push_return(PL_op->op_next);
3303 PUSHBLOCK(cx, CXt_EVAL, SP);
3304 PUSHEVAL(cx, name, Nullgv);
3306 SAVECOPLINE(&PL_compiling);
3307 CopLINE_set(&PL_compiling, 0);
3311 /* Store and reset encoding. */
3312 encoding = PL_encoding;
3313 PL_encoding = Nullsv;
3315 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3317 /* Restore encoding. */
3318 PL_encoding = encoding;
3325 return pp_require();
3331 register PERL_CONTEXT *cx;
3333 I32 gimme = GIMME_V, was = PL_sub_generation;
3334 char tbuf[TYPE_DIGITS(long) + 12];
3335 char *tmpbuf = tbuf;
3344 TAINT_PROPER("eval");
3350 /* switch to eval mode */
3352 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3353 SV *sv = sv_newmortal();
3354 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3355 (unsigned long)++PL_evalseq,
3356 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3360 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3361 SAVECOPFILE_FREE(&PL_compiling);
3362 CopFILE_set(&PL_compiling, tmpbuf+2);
3363 SAVECOPLINE(&PL_compiling);
3364 CopLINE_set(&PL_compiling, 1);
3365 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3366 deleting the eval's FILEGV from the stash before gv_check() runs
3367 (i.e. before run-time proper). To work around the coredump that
3368 ensues, we always turn GvMULTI_on for any globals that were
3369 introduced within evals. See force_ident(). GSAR 96-10-12 */
3370 safestr = savepv(tmpbuf);
3371 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3373 PL_hints = PL_op->op_targ;
3374 SAVESPTR(PL_compiling.cop_warnings);
3375 if (specialWARN(PL_curcop->cop_warnings))
3376 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3378 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3379 SAVEFREESV(PL_compiling.cop_warnings);
3381 SAVESPTR(PL_compiling.cop_io);
3382 if (specialCopIO(PL_curcop->cop_io))
3383 PL_compiling.cop_io = PL_curcop->cop_io;
3385 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3386 SAVEFREESV(PL_compiling.cop_io);
3388 /* special case: an eval '' executed within the DB package gets lexically
3389 * placed in the first non-DB CV rather than the current CV - this
3390 * allows the debugger to execute code, find lexicals etc, in the
3391 * scope of the code being debugged. Passing &seq gets find_runcv
3392 * to do the dirty work for us */
3393 runcv = find_runcv(&seq);
3395 push_return(PL_op->op_next);
3396 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3397 PUSHEVAL(cx, 0, Nullgv);
3399 /* prepare to compile string */
3401 if (PERLDB_LINE && PL_curstash != PL_debstash)
3402 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3404 ret = doeval(gimme, NULL, runcv, seq);
3405 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3406 && ret != PL_op->op_next) { /* Successive compilation. */
3407 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3409 return DOCATCH(ret);
3419 register PERL_CONTEXT *cx;
3421 U8 save_flags = PL_op -> op_flags;
3426 retop = pop_return();
3429 if (gimme == G_VOID)
3431 else if (gimme == G_SCALAR) {
3434 if (SvFLAGS(TOPs) & SVs_TEMP)
3437 *MARK = sv_mortalcopy(TOPs);
3441 *MARK = &PL_sv_undef;
3446 /* in case LEAVE wipes old return values */
3447 for (mark = newsp + 1; mark <= SP; mark++) {
3448 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3449 *mark = sv_mortalcopy(*mark);
3450 TAINT_NOT; /* Each item is independent */
3454 PL_curpm = newpm; /* Don't pop $1 et al till now */
3457 assert(CvDEPTH(PL_compcv) == 1);
3459 CvDEPTH(PL_compcv) = 0;
3462 if (optype == OP_REQUIRE &&
3463 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3465 /* Unassume the success we assumed earlier. */
3466 SV *nsv = cx->blk_eval.old_namesv;
3467 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3468 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3469 /* die_where() did LEAVE, or we won't be here */
3473 if (!(save_flags & OPf_SPECIAL))
3483 register PERL_CONTEXT *cx;
3484 I32 gimme = GIMME_V;
3489 push_return(cLOGOP->op_other->op_next);
3490 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3493 PL_in_eval = EVAL_INEVAL;
3496 return DOCATCH(PL_op->op_next);
3507 register PERL_CONTEXT *cx;
3512 retop = pop_return();
3515 if (gimme == G_VOID)
3517 else if (gimme == G_SCALAR) {
3520 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3523 *MARK = sv_mortalcopy(TOPs);
3527 *MARK = &PL_sv_undef;
3532 /* in case LEAVE wipes old return values */
3533 for (mark = newsp + 1; mark <= SP; mark++) {
3534 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3535 *mark = sv_mortalcopy(*mark);
3536 TAINT_NOT; /* Each item is independent */
3540 PL_curpm = newpm; /* Don't pop $1 et al till now */
3548 S_doparseform(pTHX_ SV *sv)
3551 register char *s = SvPV_force(sv, len);
3552 register char *send = s + len;
3553 register char *base = Nullch;
3554 register I32 skipspaces = 0;
3555 bool noblank = FALSE;
3556 bool repeat = FALSE;
3557 bool postspace = FALSE;
3565 Perl_croak(aTHX_ "Null picture in formline");
3567 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3572 *fpc++ = FF_LINEMARK;
3573 noblank = repeat = FALSE;
3591 case ' ': case '\t':
3602 *fpc++ = FF_LITERAL;
3610 *fpc++ = (U16)skipspaces;
3614 *fpc++ = FF_NEWLINE;
3618 arg = fpc - linepc + 1;
3625 *fpc++ = FF_LINEMARK;
3626 noblank = repeat = FALSE;
3635 ischop = s[-1] == '^';
3641 arg = (s - base) - 1;
3643 *fpc++ = FF_LITERAL;
3652 *fpc++ = FF_LINEGLOB;
3654 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3655 arg = ischop ? 512 : 0;
3665 arg |= 256 + (s - f);
3667 *fpc++ = s - base; /* fieldsize for FETCH */
3668 *fpc++ = FF_DECIMAL;
3671 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3672 arg = ischop ? 512 : 0;
3674 s++; /* skip the '0' first */
3683 arg |= 256 + (s - f);
3685 *fpc++ = s - base; /* fieldsize for FETCH */
3686 *fpc++ = FF_0DECIMAL;
3691 bool ismore = FALSE;
3694 while (*++s == '>') ;
3695 prespace = FF_SPACE;
3697 else if (*s == '|') {
3698 while (*++s == '|') ;
3699 prespace = FF_HALFSPACE;
3704 while (*++s == '<') ;
3707 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3711 *fpc++ = s - base; /* fieldsize for FETCH */
3713 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3716 *fpc++ = (U16)prespace;
3731 { /* need to jump to the next word */
3733 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3734 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3735 s = SvPVX(sv) + SvCUR(sv) + z;
3737 Copy(fops, s, arg, U16);
3739 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3744 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3746 SV *datasv = FILTER_DATA(idx);
3747 int filter_has_file = IoLINES(datasv);
3748 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3749 SV *filter_state = (SV *)IoTOP_GV(datasv);
3750 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3753 /* I was having segfault trouble under Linux 2.2.5 after a
3754 parse error occured. (Had to hack around it with a test
3755 for PL_error_count == 0.) Solaris doesn't segfault --
3756 not sure where the trouble is yet. XXX */
3758 if (filter_has_file) {
3759 len = FILTER_READ(idx+1, buf_sv, maxlen);
3762 if (filter_sub && len >= 0) {
3773 PUSHs(sv_2mortal(newSViv(maxlen)));
3775 PUSHs(filter_state);
3778 count = call_sv(filter_sub, G_SCALAR);
3794 IoLINES(datasv) = 0;
3795 if (filter_child_proc) {
3796 SvREFCNT_dec(filter_child_proc);
3797 IoFMT_GV(datasv) = Nullgv;
3800 SvREFCNT_dec(filter_state);
3801 IoTOP_GV(datasv) = Nullgv;
3804 SvREFCNT_dec(filter_sub);
3805 IoBOTTOM_GV(datasv) = Nullgv;
3807 filter_del(run_user_filter);
3813 /* perhaps someone can come up with a better name for
3814 this? it is not really "absolute", per se ... */
3816 S_path_is_absolute(pTHX_ char *name)
3818 if (PERL_FILE_IS_ABSOLUTE(name)
3819 #ifdef MACOS_TRADITIONAL
3822 || (*name == '.' && (name[1] == '/' ||
3823 (name[1] == '.' && name[2] == '/'))))