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;
163 REGEXP *old = PM_GETRE(pm);
171 rxres_restore(&cx->sb_rxres, rx);
172 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
174 if (cx->sb_iters++) {
175 I32 saviters = cx->sb_iters;
176 if (cx->sb_iters > cx->sb_maxiters)
177 DIE(aTHX_ "Substitution loop");
179 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
180 cx->sb_rxtainted |= 2;
181 sv_catsv(dstr, POPs);
184 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
185 s == m, cx->sb_targ, NULL,
186 ((cx->sb_rflags & REXEC_COPY_STR)
187 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
188 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
190 SV *targ = cx->sb_targ;
192 if (DO_UTF8(dstr) && !SvUTF8(targ))
193 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
195 sv_catpvn(dstr, s, cx->sb_strend - s);
196 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
198 #ifdef PERL_COPY_ON_WRITE
200 sv_force_normal_flags(targ, SV_COW_DROP_PV);
204 (void)SvOOK_off(targ);
206 Safefree(SvPVX(targ));
208 SvPVX(targ) = SvPVX(dstr);
209 SvCUR_set(targ, SvCUR(dstr));
210 SvLEN_set(targ, SvLEN(dstr));
216 TAINT_IF(cx->sb_rxtainted & 1);
217 PUSHs(sv_2mortal(newSViv(saviters - 1)));
219 (void)SvPOK_only_UTF8(targ);
220 TAINT_IF(cx->sb_rxtainted);
224 LEAVE_SCOPE(cx->sb_oldsave);
227 RETURNOP(pm->op_next);
229 cx->sb_iters = saviters;
231 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
234 cx->sb_orig = orig = rx->subbeg;
236 cx->sb_strend = s + (cx->sb_strend - m);
238 cx->sb_m = m = rx->startp[0] + orig;
240 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
241 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
243 sv_catpvn(dstr, s, m-s);
245 cx->sb_s = rx->endp[0] + orig;
246 { /* Update the pos() information. */
247 SV *sv = cx->sb_targ;
250 if (SvTYPE(sv) < SVt_PVMG)
251 (void)SvUPGRADE(sv, SVt_PVMG);
252 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
253 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
254 mg = mg_find(sv, PERL_MAGIC_regex_global);
262 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
263 rxres_save(&cx->sb_rxres, rx);
264 RETURNOP(pm->op_pmreplstart);
268 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
273 if (!p || p[1] < rx->nparens) {
274 #ifdef PERL_COPY_ON_WRITE
275 i = 7 + rx->nparens * 2;
277 i = 6 + rx->nparens * 2;
286 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
287 RX_MATCH_COPIED_off(rx);
289 #ifdef PERL_COPY_ON_WRITE
290 *p++ = PTR2UV(rx->saved_copy);
291 rx->saved_copy = Nullsv;
296 *p++ = PTR2UV(rx->subbeg);
297 *p++ = (UV)rx->sublen;
298 for (i = 0; i <= rx->nparens; ++i) {
299 *p++ = (UV)rx->startp[i];
300 *p++ = (UV)rx->endp[i];
305 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
310 RX_MATCH_COPY_FREE(rx);
311 RX_MATCH_COPIED_set(rx, *p);
314 #ifdef PERL_COPY_ON_WRITE
316 SvREFCNT_dec (rx->saved_copy);
317 rx->saved_copy = INT2PTR(SV*,*p);
323 rx->subbeg = INT2PTR(char*,*p++);
324 rx->sublen = (I32)(*p++);
325 for (i = 0; i <= rx->nparens; ++i) {
326 rx->startp[i] = (I32)(*p++);
327 rx->endp[i] = (I32)(*p++);
332 Perl_rxres_free(pTHX_ void **rsp)
337 Safefree(INT2PTR(char*,*p));
338 #ifdef PERL_COPY_ON_WRITE
340 SvREFCNT_dec (INT2PTR(SV*,p[1]));
350 dSP; dMARK; dORIGMARK;
351 register SV *tmpForm = *++MARK;
358 register SV *sv = Nullsv;
363 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
364 char *chophere = Nullch;
365 char *linemark = Nullch;
367 bool gotsome = FALSE;
369 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
370 bool item_is_utf8 = FALSE;
371 bool targ_is_utf8 = FALSE;
374 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
375 if (SvREADONLY(tmpForm)) {
376 SvREADONLY_off(tmpForm);
377 doparseform(tmpForm);
378 SvREADONLY_on(tmpForm);
381 doparseform(tmpForm);
383 SvPV_force(PL_formtarget, len);
384 if (DO_UTF8(PL_formtarget))
386 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
388 f = SvPV(tmpForm, len);
389 /* need to jump to the next word */
390 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
399 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
400 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
401 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
402 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
403 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
405 case FF_CHECKNL: name = "CHECKNL"; break;
406 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
407 case FF_SPACE: name = "SPACE"; break;
408 case FF_HALFSPACE: name = "HALFSPACE"; break;
409 case FF_ITEM: name = "ITEM"; break;
410 case FF_CHOP: name = "CHOP"; break;
411 case FF_LINEGLOB: name = "LINEGLOB"; break;
412 case FF_NEWLINE: name = "NEWLINE"; break;
413 case FF_MORE: name = "MORE"; break;
414 case FF_LINEMARK: name = "LINEMARK"; break;
415 case FF_END: name = "END"; break;
416 case FF_0DECIMAL: name = "0DECIMAL"; break;
419 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
421 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
432 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
433 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
435 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
436 t = SvEND(PL_formtarget);
439 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
440 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
442 sv_utf8_upgrade(PL_formtarget);
443 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
444 t = SvEND(PL_formtarget);
464 if (ckWARN(WARN_SYNTAX))
465 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
470 item = s = SvPV(sv, len);
473 itemsize = sv_len_utf8(sv);
474 if (itemsize != (I32)len) {
476 if (itemsize > fieldsize) {
477 itemsize = fieldsize;
478 itembytes = itemsize;
479 sv_pos_u2b(sv, &itembytes, 0);
483 send = chophere = s + itembytes;
493 sv_pos_b2u(sv, &itemsize);
497 item_is_utf8 = FALSE;
498 if (itemsize > fieldsize)
499 itemsize = fieldsize;
500 send = chophere = s + itemsize;
512 item = s = SvPV(sv, len);
515 itemsize = sv_len_utf8(sv);
516 if (itemsize != (I32)len) {
518 if (itemsize <= fieldsize) {
519 send = chophere = s + itemsize;
530 itemsize = fieldsize;
531 itembytes = itemsize;
532 sv_pos_u2b(sv, &itembytes, 0);
533 send = chophere = s + itembytes;
534 while (s < send || (s == send && isSPACE(*s))) {
544 if (strchr(PL_chopset, *s))
549 itemsize = chophere - item;
550 sv_pos_b2u(sv, &itemsize);
556 item_is_utf8 = FALSE;
557 if (itemsize <= fieldsize) {
558 send = chophere = s + itemsize;
569 itemsize = fieldsize;
570 send = chophere = s + itemsize;
571 while (s < send || (s == send && isSPACE(*s))) {
581 if (strchr(PL_chopset, *s))
586 itemsize = chophere - item;
591 arg = fieldsize - itemsize;
600 arg = fieldsize - itemsize;
614 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
616 sv_utf8_upgrade(PL_formtarget);
617 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
618 t = SvEND(PL_formtarget);
622 if (UTF8_IS_CONTINUED(*s)) {
623 STRLEN skip = UTF8SKIP(s);
640 if ( !((*t++ = *s++) & ~31) )
646 if (targ_is_utf8 && !item_is_utf8) {
647 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
649 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
650 for (; t < SvEND(PL_formtarget); t++) {
652 int ch = *t++ = *s++;
663 int ch = *t++ = *s++;
666 if ( !((*t++ = *s++) & ~31) )
675 while (*s && isSPACE(*s))
682 item = s = SvPV(sv, len);
684 if ((item_is_utf8 = DO_UTF8(sv)))
685 itemsize = sv_len_utf8(sv);
687 bool chopped = FALSE;
700 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
702 SvUTF8_on(PL_formtarget);
703 sv_catsv(PL_formtarget, sv);
705 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
706 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
707 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
714 /* If the field is marked with ^ and the value is undefined,
717 if ((arg & 512) && !SvOK(sv)) {
725 /* Formats aren't yet marked for locales, so assume "yes". */
727 STORE_NUMERIC_STANDARD_SET_LOCAL();
728 #if defined(USE_LONG_DOUBLE)
730 sprintf(t, "%#*.*" PERL_PRIfldbl,
731 (int) fieldsize, (int) arg & 255, value);
733 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
738 (int) fieldsize, (int) arg & 255, value);
741 (int) fieldsize, value);
744 RESTORE_NUMERIC_STANDARD();
750 /* If the field is marked with ^ and the value is undefined,
753 if ((arg & 512) && !SvOK(sv)) {
761 /* Formats aren't yet marked for locales, so assume "yes". */
763 STORE_NUMERIC_STANDARD_SET_LOCAL();
764 #if defined(USE_LONG_DOUBLE)
766 sprintf(t, "%#0*.*" PERL_PRIfldbl,
767 (int) fieldsize, (int) arg & 255, value);
768 /* is this legal? I don't have long doubles */
770 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
774 sprintf(t, "%#0*.*f",
775 (int) fieldsize, (int) arg & 255, value);
778 (int) fieldsize, value);
781 RESTORE_NUMERIC_STANDARD();
788 while (t-- > linemark && *t == ' ') ;
796 if (arg) { /* repeat until fields exhausted? */
798 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
799 lines += FmLINES(PL_formtarget);
802 if (strnEQ(linemark, linemark - arg, arg))
803 DIE(aTHX_ "Runaway format");
806 SvUTF8_on(PL_formtarget);
807 FmLINES(PL_formtarget) = lines;
809 RETURNOP(cLISTOP->op_first);
822 while (*s && isSPACE(*s) && s < send)
826 arg = fieldsize - itemsize;
833 if (strnEQ(s," ",3)) {
834 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
845 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
847 SvUTF8_on(PL_formtarget);
848 FmLINES(PL_formtarget) += lines;
860 if (PL_stack_base + *PL_markstack_ptr == SP) {
862 if (GIMME_V == G_SCALAR)
863 XPUSHs(sv_2mortal(newSViv(0)));
864 RETURNOP(PL_op->op_next->op_next);
866 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
867 pp_pushmark(); /* push dst */
868 pp_pushmark(); /* push src */
869 ENTER; /* enter outer scope */
872 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
874 ENTER; /* enter inner scope */
877 src = PL_stack_base[*PL_markstack_ptr];
882 if (PL_op->op_type == OP_MAPSTART)
883 pp_pushmark(); /* push top */
884 return ((LOGOP*)PL_op->op_next)->op_other;
889 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
895 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
901 /* first, move source pointer to the next item in the source list */
902 ++PL_markstack_ptr[-1];
904 /* if there are new items, push them into the destination list */
906 /* might need to make room back there first */
907 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
908 /* XXX this implementation is very pessimal because the stack
909 * is repeatedly extended for every set of items. Is possible
910 * to do this without any stack extension or copying at all
911 * by maintaining a separate list over which the map iterates
912 * (like foreach does). --gsar */
914 /* everything in the stack after the destination list moves
915 * towards the end the stack by the amount of room needed */
916 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
918 /* items to shift up (accounting for the moved source pointer) */
919 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
921 /* This optimization is by Ben Tilly and it does
922 * things differently from what Sarathy (gsar)
923 * is describing. The downside of this optimization is
924 * that leaves "holes" (uninitialized and hopefully unused areas)
925 * to the Perl stack, but on the other hand this
926 * shouldn't be a problem. If Sarathy's idea gets
927 * implemented, this optimization should become
928 * irrelevant. --jhi */
930 shift = count; /* Avoid shifting too often --Ben Tilly */
935 PL_markstack_ptr[-1] += shift;
936 *PL_markstack_ptr += shift;
940 /* copy the new items down to the destination list */
941 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
943 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
945 LEAVE; /* exit inner scope */
948 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
951 (void)POPMARK; /* pop top */
952 LEAVE; /* exit outer scope */
953 (void)POPMARK; /* pop src */
954 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
955 (void)POPMARK; /* pop dst */
956 SP = PL_stack_base + POPMARK; /* pop original mark */
957 if (gimme == G_SCALAR) {
961 else if (gimme == G_ARRAY)
968 ENTER; /* enter inner scope */
971 /* set $_ to the new source item */
972 src = PL_stack_base[PL_markstack_ptr[-1]];
976 RETURNOP(cLOGOP->op_other);
984 if (GIMME == G_ARRAY)
986 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
987 return cLOGOP->op_other;
996 if (GIMME == G_ARRAY) {
997 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1001 SV *targ = PAD_SV(PL_op->op_targ);
1004 if (PL_op->op_private & OPpFLIP_LINENUM) {
1005 if (GvIO(PL_last_in_gv)) {
1006 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1009 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1010 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1016 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1017 if (PL_op->op_flags & OPf_SPECIAL) {
1025 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1038 if (GIMME == G_ARRAY) {
1044 if (SvGMAGICAL(left))
1046 if (SvGMAGICAL(right))
1049 /* This code tries to decide if "$left .. $right" should use the
1050 magical string increment, or if the range is numeric (we make
1051 an exception for .."0" [#18165]). AMS 20021031. */
1053 if (SvNIOKp(left) || !SvPOKp(left) ||
1054 SvNIOKp(right) || !SvPOKp(right) ||
1055 (looks_like_number(left) && *SvPVX(left) != '0' &&
1056 looks_like_number(right)))
1058 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1059 DIE(aTHX_ "Range iterator outside integer range");
1070 sv = sv_2mortal(newSViv(i++));
1075 SV *final = sv_mortalcopy(right);
1077 char *tmps = SvPV(final, len);
1079 sv = sv_mortalcopy(left);
1081 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1083 if (strEQ(SvPVX(sv),tmps))
1085 sv = sv_2mortal(newSVsv(sv));
1092 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1096 if (PL_op->op_private & OPpFLIP_LINENUM) {
1097 if (GvIO(PL_last_in_gv)) {
1098 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1101 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1102 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1110 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1111 sv_catpv(targ, "E0");
1121 static char *context_name[] = {
1132 S_dopoptolabel(pTHX_ char *label)
1135 register PERL_CONTEXT *cx;
1137 for (i = cxstack_ix; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1145 if (ckWARN(WARN_EXITING))
1146 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1147 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1148 if (CxTYPE(cx) == CXt_NULL)
1152 if (!cx->blk_loop.label ||
1153 strNE(label, cx->blk_loop.label) ) {
1154 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1155 (long)i, cx->blk_loop.label));
1158 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1166 Perl_dowantarray(pTHX)
1168 I32 gimme = block_gimme();
1169 return (gimme == G_VOID) ? G_SCALAR : gimme;
1173 Perl_block_gimme(pTHX)
1177 cxix = dopoptosub(cxstack_ix);
1181 switch (cxstack[cxix].blk_gimme) {
1189 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1196 Perl_is_lvalue_sub(pTHX)
1200 cxix = dopoptosub(cxstack_ix);
1201 assert(cxix >= 0); /* We should only be called from inside subs */
1203 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1204 return cxstack[cxix].blk_sub.lval;
1210 S_dopoptosub(pTHX_ I32 startingblock)
1212 return dopoptosub_at(cxstack, startingblock);
1216 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1219 register PERL_CONTEXT *cx;
1220 for (i = startingblock; i >= 0; i--) {
1222 switch (CxTYPE(cx)) {
1228 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1236 S_dopoptoeval(pTHX_ I32 startingblock)
1239 register PERL_CONTEXT *cx;
1240 for (i = startingblock; i >= 0; i--) {
1242 switch (CxTYPE(cx)) {
1246 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1254 S_dopoptoloop(pTHX_ I32 startingblock)
1257 register PERL_CONTEXT *cx;
1258 for (i = startingblock; i >= 0; i--) {
1260 switch (CxTYPE(cx)) {
1266 if (ckWARN(WARN_EXITING))
1267 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1268 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1269 if ((CxTYPE(cx)) == CXt_NULL)
1273 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1281 Perl_dounwind(pTHX_ I32 cxix)
1283 register PERL_CONTEXT *cx;
1286 while (cxstack_ix > cxix) {
1288 cx = &cxstack[cxstack_ix];
1289 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1290 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1291 /* Note: we don't need to restore the base context info till the end. */
1292 switch (CxTYPE(cx)) {
1295 continue; /* not break */
1317 Perl_qerror(pTHX_ SV *err)
1320 sv_catsv(ERRSV, err);
1322 sv_catsv(PL_errors, err);
1324 Perl_warn(aTHX_ "%"SVf, err);
1329 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1337 register PERL_CONTEXT *cx;
1342 if (PL_in_eval & EVAL_KEEPERR) {
1343 static char prefix[] = "\t(in cleanup) ";
1348 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1351 if (*e != *message || strNE(e,message))
1355 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1356 sv_catpvn(err, prefix, sizeof(prefix)-1);
1357 sv_catpvn(err, message, msglen);
1358 if (ckWARN(WARN_MISC)) {
1359 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1360 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1365 sv_setpvn(ERRSV, message, msglen);
1369 message = SvPVx(ERRSV, msglen);
1371 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1372 && PL_curstackinfo->si_prev)
1381 if (cxix < cxstack_ix)
1384 POPBLOCK(cx,PL_curpm);
1385 if (CxTYPE(cx) != CXt_EVAL) {
1386 PerlIO_write(Perl_error_log, "panic: die ", 11);
1387 PerlIO_write(Perl_error_log, message, msglen);
1392 if (gimme == G_SCALAR)
1393 *++newsp = &PL_sv_undef;
1394 PL_stack_sp = newsp;
1398 /* LEAVE could clobber PL_curcop (see save_re_context())
1399 * XXX it might be better to find a way to avoid messing with
1400 * PL_curcop in save_re_context() instead, but this is a more
1401 * minimal fix --GSAR */
1402 PL_curcop = cx->blk_oldcop;
1404 if (optype == OP_REQUIRE) {
1405 char* msg = SvPVx(ERRSV, n_a);
1406 DIE(aTHX_ "%sCompilation failed in require",
1407 *msg ? msg : "Unknown error\n");
1409 return pop_return();
1413 message = SvPVx(ERRSV, msglen);
1415 /* if STDERR is tied, print to it instead */
1416 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1417 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1420 XPUSHs(SvTIED_obj((SV*)io, mg));
1421 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1423 call_method("PRINT", G_SCALAR);
1428 /* SFIO can really mess with your errno */
1431 PerlIO *serr = Perl_error_log;
1433 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1434 (void)PerlIO_flush(serr);
1447 if (SvTRUE(left) != SvTRUE(right))
1459 RETURNOP(cLOGOP->op_other);
1468 RETURNOP(cLOGOP->op_other);
1477 if (!sv || !SvANY(sv)) {
1478 RETURNOP(cLOGOP->op_other);
1481 switch (SvTYPE(sv)) {
1483 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1487 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1491 if (CvROOT(sv) || CvXSUB(sv))
1501 RETURNOP(cLOGOP->op_other);
1507 register I32 cxix = dopoptosub(cxstack_ix);
1508 register PERL_CONTEXT *cx;
1509 register PERL_CONTEXT *ccstack = cxstack;
1510 PERL_SI *top_si = PL_curstackinfo;
1521 /* we may be in a higher stacklevel, so dig down deeper */
1522 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1523 top_si = top_si->si_prev;
1524 ccstack = top_si->si_cxstack;
1525 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1528 if (GIMME != G_ARRAY) {
1534 if (PL_DBsub && cxix >= 0 &&
1535 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1539 cxix = dopoptosub_at(ccstack, cxix - 1);
1542 cx = &ccstack[cxix];
1543 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1544 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1545 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1546 field below is defined for any cx. */
1547 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1548 cx = &ccstack[dbcxix];
1551 stashname = CopSTASHPV(cx->blk_oldcop);
1552 if (GIMME != G_ARRAY) {
1555 PUSHs(&PL_sv_undef);
1558 sv_setpv(TARG, stashname);
1567 PUSHs(&PL_sv_undef);
1569 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1570 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1571 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1574 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1575 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1576 /* So is ccstack[dbcxix]. */
1579 gv_efullname3(sv, cvgv, Nullch);
1580 PUSHs(sv_2mortal(sv));
1581 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1584 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1585 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1589 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1590 PUSHs(sv_2mortal(newSViv(0)));
1592 gimme = (I32)cx->blk_gimme;
1593 if (gimme == G_VOID)
1594 PUSHs(&PL_sv_undef);
1596 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1597 if (CxTYPE(cx) == CXt_EVAL) {
1599 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1600 PUSHs(cx->blk_eval.cur_text);
1604 else if (cx->blk_eval.old_namesv) {
1605 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1608 /* eval BLOCK (try blocks have old_namesv == 0) */
1610 PUSHs(&PL_sv_undef);
1611 PUSHs(&PL_sv_undef);
1615 PUSHs(&PL_sv_undef);
1616 PUSHs(&PL_sv_undef);
1618 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1619 && CopSTASH_eq(PL_curcop, PL_debstash))
1621 AV *ary = cx->blk_sub.argarray;
1622 int off = AvARRAY(ary) - AvALLOC(ary);
1626 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1629 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1632 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1633 av_extend(PL_dbargs, AvFILLp(ary) + off);
1634 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1635 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1637 /* XXX only hints propagated via op_private are currently
1638 * visible (others are not easily accessible, since they
1639 * use the global PL_hints) */
1640 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1641 HINT_PRIVATE_MASK)));
1644 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1646 if (old_warnings == pWARN_NONE ||
1647 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1648 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1649 else if (old_warnings == pWARN_ALL ||
1650 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1651 /* Get the bit mask for $warnings::Bits{all}, because
1652 * it could have been extended by warnings::register */
1654 HV *bits = get_hv("warnings::Bits", FALSE);
1655 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1656 mask = newSVsv(*bits_all);
1659 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1663 mask = newSVsv(old_warnings);
1664 PUSHs(sv_2mortal(mask));
1679 sv_reset(tmps, CopSTASH(PL_curcop));
1689 /* like pp_nextstate, but used instead when the debugger is active */
1693 PL_curcop = (COP*)PL_op;
1694 TAINT_NOT; /* Each statement is presumed innocent */
1695 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1698 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1699 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1703 register PERL_CONTEXT *cx;
1704 I32 gimme = G_ARRAY;
1711 DIE(aTHX_ "No DB::DB routine defined");
1713 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1714 /* don't do recursive DB::DB call */
1726 push_return(PL_op->op_next);
1727 PUSHBLOCK(cx, CXt_SUB, SP);
1730 (void)SvREFCNT_inc(cv);
1731 PAD_SET_CUR(CvPADLIST(cv),1);
1732 RETURNOP(CvSTART(cv));
1746 register PERL_CONTEXT *cx;
1747 I32 gimme = GIMME_V;
1749 U32 cxtype = CXt_LOOP;
1757 if (PL_op->op_targ) {
1758 #ifndef USE_ITHREADS
1759 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1762 SAVEPADSV(PL_op->op_targ);
1763 iterdata = INT2PTR(void*, PL_op->op_targ);
1764 cxtype |= CXp_PADVAR;
1769 svp = &GvSV(gv); /* symbol table variable */
1770 SAVEGENERICSV(*svp);
1773 iterdata = (void*)gv;
1779 PUSHBLOCK(cx, cxtype, SP);
1781 PUSHLOOP(cx, iterdata, MARK);
1783 PUSHLOOP(cx, svp, MARK);
1785 if (PL_op->op_flags & OPf_STACKED) {
1786 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1787 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1789 /* See comment in pp_flop() */
1790 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1791 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1792 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1793 looks_like_number((SV*)cx->blk_loop.iterary)))
1795 if (SvNV(sv) < IV_MIN ||
1796 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1797 DIE(aTHX_ "Range iterator outside integer range");
1798 cx->blk_loop.iterix = SvIV(sv);
1799 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1802 cx->blk_loop.iterlval = newSVsv(sv);
1806 cx->blk_loop.iterary = PL_curstack;
1807 AvFILLp(PL_curstack) = SP - PL_stack_base;
1808 cx->blk_loop.iterix = MARK - PL_stack_base;
1817 register PERL_CONTEXT *cx;
1818 I32 gimme = GIMME_V;
1824 PUSHBLOCK(cx, CXt_LOOP, SP);
1825 PUSHLOOP(cx, 0, SP);
1833 register PERL_CONTEXT *cx;
1841 newsp = PL_stack_base + cx->blk_loop.resetsp;
1844 if (gimme == G_VOID)
1846 else if (gimme == G_SCALAR) {
1848 *++newsp = sv_mortalcopy(*SP);
1850 *++newsp = &PL_sv_undef;
1854 *++newsp = sv_mortalcopy(*++mark);
1855 TAINT_NOT; /* Each item is independent */
1861 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1862 PL_curpm = newpm; /* ... and pop $1 et al */
1874 register PERL_CONTEXT *cx;
1875 bool popsub2 = FALSE;
1876 bool clear_errsv = FALSE;
1883 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1884 if (cxstack_ix == PL_sortcxix
1885 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1887 if (cxstack_ix > PL_sortcxix)
1888 dounwind(PL_sortcxix);
1889 AvARRAY(PL_curstack)[1] = *SP;
1890 PL_stack_sp = PL_stack_base + 1;
1895 cxix = dopoptosub(cxstack_ix);
1897 DIE(aTHX_ "Can't return outside a subroutine");
1898 if (cxix < cxstack_ix)
1902 switch (CxTYPE(cx)) {
1907 if (!(PL_in_eval & EVAL_KEEPERR))
1913 if (optype == OP_REQUIRE &&
1914 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1916 /* Unassume the success we assumed earlier. */
1917 SV *nsv = cx->blk_eval.old_namesv;
1918 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1919 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1926 DIE(aTHX_ "panic: return");
1930 if (gimme == G_SCALAR) {
1933 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1935 *++newsp = SvREFCNT_inc(*SP);
1940 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1942 *++newsp = sv_mortalcopy(sv);
1947 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1950 *++newsp = sv_mortalcopy(*SP);
1953 *++newsp = &PL_sv_undef;
1955 else if (gimme == G_ARRAY) {
1956 while (++MARK <= SP) {
1957 *++newsp = (popsub2 && SvTEMP(*MARK))
1958 ? *MARK : sv_mortalcopy(*MARK);
1959 TAINT_NOT; /* Each item is independent */
1962 PL_stack_sp = newsp;
1965 /* Stack values are safe: */
1967 POPSUB(cx,sv); /* release CV and @_ ... */
1971 PL_curpm = newpm; /* ... and pop $1 et al */
1976 return pop_return();
1983 register PERL_CONTEXT *cx;
1993 if (PL_op->op_flags & OPf_SPECIAL) {
1994 cxix = dopoptoloop(cxstack_ix);
1996 DIE(aTHX_ "Can't \"last\" outside a loop block");
1999 cxix = dopoptolabel(cPVOP->op_pv);
2001 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2003 if (cxix < cxstack_ix)
2008 switch (CxTYPE(cx)) {
2011 newsp = PL_stack_base + cx->blk_loop.resetsp;
2012 nextop = cx->blk_loop.last_op->op_next;
2016 nextop = pop_return();
2020 nextop = pop_return();
2024 nextop = pop_return();
2027 DIE(aTHX_ "panic: last");
2031 if (gimme == G_SCALAR) {
2033 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2034 ? *SP : sv_mortalcopy(*SP);
2036 *++newsp = &PL_sv_undef;
2038 else if (gimme == G_ARRAY) {
2039 while (++MARK <= SP) {
2040 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2041 ? *MARK : sv_mortalcopy(*MARK);
2042 TAINT_NOT; /* Each item is independent */
2049 /* Stack values are safe: */
2052 POPLOOP(cx); /* release loop vars ... */
2056 POPSUB(cx,sv); /* release CV and @_ ... */
2059 PL_curpm = newpm; /* ... and pop $1 et al */
2068 register PERL_CONTEXT *cx;
2071 if (PL_op->op_flags & OPf_SPECIAL) {
2072 cxix = dopoptoloop(cxstack_ix);
2074 DIE(aTHX_ "Can't \"next\" outside a loop block");
2077 cxix = dopoptolabel(cPVOP->op_pv);
2079 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2081 if (cxix < cxstack_ix)
2084 /* clear off anything above the scope we're re-entering, but
2085 * save the rest until after a possible continue block */
2086 inner = PL_scopestack_ix;
2088 if (PL_scopestack_ix < inner)
2089 leave_scope(PL_scopestack[PL_scopestack_ix]);
2090 return cx->blk_loop.next_op;
2096 register PERL_CONTEXT *cx;
2099 if (PL_op->op_flags & OPf_SPECIAL) {
2100 cxix = dopoptoloop(cxstack_ix);
2102 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2105 cxix = dopoptolabel(cPVOP->op_pv);
2107 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2109 if (cxix < cxstack_ix)
2113 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2114 LEAVE_SCOPE(oldsave);
2115 return cx->blk_loop.redo_op;
2119 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2123 static char too_deep[] = "Target of goto is too deeply nested";
2126 Perl_croak(aTHX_ too_deep);
2127 if (o->op_type == OP_LEAVE ||
2128 o->op_type == OP_SCOPE ||
2129 o->op_type == OP_LEAVELOOP ||
2130 o->op_type == OP_LEAVESUB ||
2131 o->op_type == OP_LEAVETRY)
2133 *ops++ = cUNOPo->op_first;
2135 Perl_croak(aTHX_ too_deep);
2138 if (o->op_flags & OPf_KIDS) {
2139 /* First try all the kids at this level, since that's likeliest. */
2140 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2141 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2142 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2145 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2146 if (kid == PL_lastgotoprobe)
2148 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2151 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2152 ops[-1]->op_type == OP_DBSTATE)
2157 if ((o = dofindlabel(kid, label, ops, oplimit)))
2176 register PERL_CONTEXT *cx;
2177 #define GOTO_DEPTH 64
2178 OP *enterops[GOTO_DEPTH];
2180 int do_dump = (PL_op->op_type == OP_DUMP);
2181 static char must_have_label[] = "goto must have label";
2184 if (PL_op->op_flags & OPf_STACKED) {
2188 /* This egregious kludge implements goto &subroutine */
2189 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2191 register PERL_CONTEXT *cx;
2192 CV* cv = (CV*)SvRV(sv);
2198 if (!CvROOT(cv) && !CvXSUB(cv)) {
2203 /* autoloaded stub? */
2204 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2206 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2207 GvNAMELEN(gv), FALSE);
2208 if (autogv && (cv = GvCV(autogv)))
2210 tmpstr = sv_newmortal();
2211 gv_efullname3(tmpstr, gv, Nullch);
2212 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2214 DIE(aTHX_ "Goto undefined subroutine");
2217 /* First do some returnish stuff. */
2218 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2220 cxix = dopoptosub(cxstack_ix);
2222 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2223 if (cxix < cxstack_ix)
2227 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2229 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2230 /* put @_ back onto stack */
2231 AV* av = cx->blk_sub.argarray;
2233 items = AvFILLp(av) + 1;
2235 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2236 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2237 PL_stack_sp += items;
2238 SvREFCNT_dec(GvAV(PL_defgv));
2239 GvAV(PL_defgv) = cx->blk_sub.savearray;
2240 /* abandon @_ if it got reified */
2242 (void)sv_2mortal((SV*)av); /* delay until return */
2244 av_extend(av, items-1);
2245 AvFLAGS(av) = AVf_REIFY;
2246 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2251 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2253 av = GvAV(PL_defgv);
2254 items = AvFILLp(av) + 1;
2256 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2257 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2258 PL_stack_sp += items;
2260 if (CxTYPE(cx) == CXt_SUB &&
2261 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2262 SvREFCNT_dec(cx->blk_sub.cv);
2263 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2264 LEAVE_SCOPE(oldsave);
2266 /* Now do some callish stuff. */
2268 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2270 #ifdef PERL_XSUB_OLDSTYLE
2271 if (CvOLDSTYLE(cv)) {
2272 I32 (*fp3)(int,int,int);
2277 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2278 items = (*fp3)(CvXSUBANY(cv).any_i32,
2279 mark - PL_stack_base + 1,
2281 SP = PL_stack_base + items;
2284 #endif /* PERL_XSUB_OLDSTYLE */
2289 PL_stack_sp--; /* There is no cv arg. */
2290 /* Push a mark for the start of arglist */
2292 (void)(*CvXSUB(cv))(aTHX_ cv);
2293 /* Pop the current context like a decent sub should */
2294 POPBLOCK(cx, PL_curpm);
2295 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2298 return pop_return();
2301 AV* padlist = CvPADLIST(cv);
2302 if (CxTYPE(cx) == CXt_EVAL) {
2303 PL_in_eval = cx->blk_eval.old_in_eval;
2304 PL_eval_root = cx->blk_eval.old_eval_root;
2305 cx->cx_type = CXt_SUB;
2306 cx->blk_sub.hasargs = 0;
2308 cx->blk_sub.cv = cv;
2309 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2312 if (CvDEPTH(cv) < 2)
2313 (void)SvREFCNT_inc(cv);
2315 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2316 sub_crush_depth(cv);
2317 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2319 PAD_SET_CUR(padlist, CvDEPTH(cv));
2320 if (cx->blk_sub.hasargs)
2322 AV* av = (AV*)PAD_SVl(0);
2325 cx->blk_sub.savearray = GvAV(PL_defgv);
2326 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2327 CX_CURPAD_SAVE(cx->blk_sub);
2328 cx->blk_sub.argarray = av;
2331 if (items >= AvMAX(av) + 1) {
2333 if (AvARRAY(av) != ary) {
2334 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2335 SvPVX(av) = (char*)ary;
2337 if (items >= AvMAX(av) + 1) {
2338 AvMAX(av) = items - 1;
2339 Renew(ary,items+1,SV*);
2341 SvPVX(av) = (char*)ary;
2344 Copy(mark,AvARRAY(av),items,SV*);
2345 AvFILLp(av) = items - 1;
2346 assert(!AvREAL(av));
2353 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2355 * We do not care about using sv to call CV;
2356 * it's for informational purposes only.
2358 SV *sv = GvSV(PL_DBsub);
2361 if (PERLDB_SUB_NN) {
2362 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2365 gv_efullname3(sv, CvGV(cv), Nullch);
2368 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2369 PUSHMARK( PL_stack_sp );
2370 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2374 RETURNOP(CvSTART(cv));
2378 label = SvPV(sv,n_a);
2379 if (!(do_dump || *label))
2380 DIE(aTHX_ must_have_label);
2383 else if (PL_op->op_flags & OPf_SPECIAL) {
2385 DIE(aTHX_ must_have_label);
2388 label = cPVOP->op_pv;
2390 if (label && *label) {
2392 bool leaving_eval = FALSE;
2393 bool in_block = FALSE;
2394 PERL_CONTEXT *last_eval_cx = 0;
2398 PL_lastgotoprobe = 0;
2400 for (ix = cxstack_ix; ix >= 0; ix--) {
2402 switch (CxTYPE(cx)) {
2404 leaving_eval = TRUE;
2405 if (CxREALEVAL(cx)) {
2406 gotoprobe = (last_eval_cx ?
2407 last_eval_cx->blk_eval.old_eval_root :
2412 /* else fall through */
2414 gotoprobe = cx->blk_oldcop->op_sibling;
2420 gotoprobe = cx->blk_oldcop->op_sibling;
2423 gotoprobe = PL_main_root;
2426 if (CvDEPTH(cx->blk_sub.cv)) {
2427 gotoprobe = CvROOT(cx->blk_sub.cv);
2433 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2436 DIE(aTHX_ "panic: goto");
2437 gotoprobe = PL_main_root;
2441 retop = dofindlabel(gotoprobe, label,
2442 enterops, enterops + GOTO_DEPTH);
2446 PL_lastgotoprobe = gotoprobe;
2449 DIE(aTHX_ "Can't find label %s", label);
2451 /* if we're leaving an eval, check before we pop any frames
2452 that we're not going to punt, otherwise the error
2455 if (leaving_eval && *enterops && enterops[1]) {
2457 for (i = 1; enterops[i]; i++)
2458 if (enterops[i]->op_type == OP_ENTERITER)
2459 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2462 /* pop unwanted frames */
2464 if (ix < cxstack_ix) {
2471 oldsave = PL_scopestack[PL_scopestack_ix];
2472 LEAVE_SCOPE(oldsave);
2475 /* push wanted frames */
2477 if (*enterops && enterops[1]) {
2479 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2480 for (; enterops[ix]; ix++) {
2481 PL_op = enterops[ix];
2482 /* Eventually we may want to stack the needed arguments
2483 * for each op. For now, we punt on the hard ones. */
2484 if (PL_op->op_type == OP_ENTERITER)
2485 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2486 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2494 if (!retop) retop = PL_main_start;
2496 PL_restartop = retop;
2497 PL_do_undump = TRUE;
2501 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2502 PL_do_undump = FALSE;
2518 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2520 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2523 PL_exit_flags |= PERL_EXIT_EXPECTED;
2525 PUSHs(&PL_sv_undef);
2533 NV value = SvNVx(GvSV(cCOP->cop_gv));
2534 register I32 match = I_32(value);
2537 if (((NV)match) > value)
2538 --match; /* was fractional--truncate other way */
2540 match -= cCOP->uop.scop.scop_offset;
2543 else if (match > cCOP->uop.scop.scop_max)
2544 match = cCOP->uop.scop.scop_max;
2545 PL_op = cCOP->uop.scop.scop_next[match];
2555 PL_op = PL_op->op_next; /* can't assume anything */
2558 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2559 match -= cCOP->uop.scop.scop_offset;
2562 else if (match > cCOP->uop.scop.scop_max)
2563 match = cCOP->uop.scop.scop_max;
2564 PL_op = cCOP->uop.scop.scop_next[match];
2573 S_save_lines(pTHX_ AV *array, SV *sv)
2575 register char *s = SvPVX(sv);
2576 register char *send = SvPVX(sv) + SvCUR(sv);
2578 register I32 line = 1;
2580 while (s && s < send) {
2581 SV *tmpstr = NEWSV(85,0);
2583 sv_upgrade(tmpstr, SVt_PVMG);
2584 t = strchr(s, '\n');
2590 sv_setpvn(tmpstr, s, t - s);
2591 av_store(array, line++, tmpstr);
2596 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2598 S_docatch_body(pTHX_ va_list args)
2600 return docatch_body();
2605 S_docatch_body(pTHX)
2612 S_docatch(pTHX_ OP *o)
2617 volatile PERL_SI *cursi = PL_curstackinfo;
2621 assert(CATCH_GET == TRUE);
2625 /* Normally, the leavetry at the end of this block of ops will
2626 * pop an op off the return stack and continue there. By setting
2627 * the op to Nullop, we force an exit from the inner runops()
2630 retop = pop_return();
2631 push_return(Nullop);
2633 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2635 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2641 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2647 /* die caught by an inner eval - continue inner loop */
2648 if (PL_restartop && cursi == PL_curstackinfo) {
2649 PL_op = PL_restartop;
2653 /* a die in this eval - continue in outer loop */
2669 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2670 /* sv Text to convert to OP tree. */
2671 /* startop op_free() this to undo. */
2672 /* code Short string id of the caller. */
2674 dSP; /* Make POPBLOCK work. */
2677 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2681 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2682 char *tmpbuf = tbuf;
2685 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2690 /* switch to eval mode */
2692 if (PL_curcop == &PL_compiling) {
2693 SAVECOPSTASH_FREE(&PL_compiling);
2694 CopSTASH_set(&PL_compiling, PL_curstash);
2696 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2697 SV *sv = sv_newmortal();
2698 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2699 code, (unsigned long)++PL_evalseq,
2700 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2704 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2705 SAVECOPFILE_FREE(&PL_compiling);
2706 CopFILE_set(&PL_compiling, tmpbuf+2);
2707 SAVECOPLINE(&PL_compiling);
2708 CopLINE_set(&PL_compiling, 1);
2709 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2710 deleting the eval's FILEGV from the stash before gv_check() runs
2711 (i.e. before run-time proper). To work around the coredump that
2712 ensues, we always turn GvMULTI_on for any globals that were
2713 introduced within evals. See force_ident(). GSAR 96-10-12 */
2714 safestr = savepv(tmpbuf);
2715 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2717 #ifdef OP_IN_REGISTER
2722 PL_hints &= HINT_UTF8;
2724 /* we get here either during compilation, or via pp_regcomp at runtime */
2725 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2727 runcv = find_runcv(NULL);
2730 PL_op->op_type = OP_ENTEREVAL;
2731 PL_op->op_flags = 0; /* Avoid uninit warning. */
2732 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2733 PUSHEVAL(cx, 0, Nullgv);
2736 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2738 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2739 POPBLOCK(cx,PL_curpm);
2742 (*startop)->op_type = OP_NULL;
2743 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2745 /* XXX DAPM do this properly one year */
2746 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2748 if (PL_curcop == &PL_compiling)
2749 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2750 #ifdef OP_IN_REGISTER
2758 =for apidoc find_runcv
2760 Locate the CV corresponding to the currently executing sub or eval.
2761 If db_seqp is non_null, skip CVs that are in the DB package and populate
2762 *db_seqp with the cop sequence number at the point that the DB:: code was
2763 entered. (allows debuggers to eval in the scope of the breakpoint rather
2764 than in in the scope of the debuger itself).
2770 Perl_find_runcv(pTHX_ U32 *db_seqp)
2777 *db_seqp = PL_curcop->cop_seq;
2778 for (si = PL_curstackinfo; si; si = si->si_prev) {
2779 for (ix = si->si_cxix; ix >= 0; ix--) {
2780 cx = &(si->si_cxstack[ix]);
2781 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2782 CV *cv = cx->blk_sub.cv;
2783 /* skip DB:: code */
2784 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2785 *db_seqp = cx->blk_oldcop->cop_seq;
2790 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2798 /* Compile a require/do, an eval '', or a /(?{...})/.
2799 * In the last case, startop is non-null, and contains the address of
2800 * a pointer that should be set to the just-compiled code.
2801 * outside is the lexically enclosing CV (if any) that invoked us.
2804 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2806 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2811 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2812 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2817 SAVESPTR(PL_compcv);
2818 PL_compcv = (CV*)NEWSV(1104,0);
2819 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2820 CvEVAL_on(PL_compcv);
2821 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2822 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2824 CvOUTSIDE_SEQ(PL_compcv) = seq;
2825 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2827 /* set up a scratch pad */
2829 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2832 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2834 /* make sure we compile in the right package */
2836 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2837 SAVESPTR(PL_curstash);
2838 PL_curstash = CopSTASH(PL_curcop);
2840 SAVESPTR(PL_beginav);
2841 PL_beginav = newAV();
2842 SAVEFREESV(PL_beginav);
2843 SAVEI32(PL_error_count);
2845 /* try to compile it */
2847 PL_eval_root = Nullop;
2849 PL_curcop = &PL_compiling;
2850 PL_curcop->cop_arybase = 0;
2851 if (saveop && saveop->op_flags & OPf_SPECIAL)
2852 PL_in_eval |= EVAL_KEEPERR;
2855 if (yyparse() || PL_error_count || !PL_eval_root) {
2859 I32 optype = 0; /* Might be reset by POPEVAL. */
2864 op_free(PL_eval_root);
2865 PL_eval_root = Nullop;
2867 SP = PL_stack_base + POPMARK; /* pop original mark */
2869 POPBLOCK(cx,PL_curpm);
2875 if (optype == OP_REQUIRE) {
2876 char* msg = SvPVx(ERRSV, n_a);
2877 DIE(aTHX_ "%sCompilation failed in require",
2878 *msg ? msg : "Unknown error\n");
2881 char* msg = SvPVx(ERRSV, n_a);
2883 POPBLOCK(cx,PL_curpm);
2885 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2886 (*msg ? msg : "Unknown error\n"));
2889 char* msg = SvPVx(ERRSV, n_a);
2891 sv_setpv(ERRSV, "Compilation error");
2896 CopLINE_set(&PL_compiling, 0);
2898 *startop = PL_eval_root;
2900 SAVEFREEOP(PL_eval_root);
2901 if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE)
2903 * EVAL_INREQUIRE (the code is being required) is special-cased :
2904 * in this case we want scalar context to be forced, instead
2905 * of void context, so a proper return value is returned from
2906 * C<require> via this leaveeval op.
2908 scalarvoid(PL_eval_root);
2909 else if (gimme & G_ARRAY)
2912 scalar(PL_eval_root);
2914 DEBUG_x(dump_eval());
2916 /* Register with debugger: */
2917 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2918 CV *cv = get_cv("DB::postponed", FALSE);
2922 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2924 call_sv((SV*)cv, G_DISCARD);
2928 /* compiled okay, so do it */
2930 CvDEPTH(PL_compcv) = 1;
2931 SP = PL_stack_base + POPMARK; /* pop original mark */
2932 PL_op = saveop; /* The caller may need it. */
2933 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2935 RETURNOP(PL_eval_start);
2939 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2941 STRLEN namelen = strlen(name);
2944 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2945 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2946 char *pmc = SvPV_nolen(pmcsv);
2949 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2950 fp = PerlIO_open(name, mode);
2953 if (PerlLIO_stat(name, &pmstat) < 0 ||
2954 pmstat.st_mtime < pmcstat.st_mtime)
2956 fp = PerlIO_open(pmc, mode);
2959 fp = PerlIO_open(name, mode);
2962 SvREFCNT_dec(pmcsv);
2965 fp = PerlIO_open(name, mode);
2973 register PERL_CONTEXT *cx;
2977 char *tryname = Nullch;
2978 SV *namesv = Nullsv;
2980 I32 gimme = GIMME_V;
2981 PerlIO *tryrsfp = 0;
2983 int filter_has_file = 0;
2984 GV *filter_child_proc = 0;
2985 SV *filter_state = 0;
2992 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2993 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2994 UV rev = 0, ver = 0, sver = 0;
2996 U8 *s = (U8*)SvPVX(sv);
2997 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2999 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3002 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3005 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3008 if (PERL_REVISION < rev
3009 || (PERL_REVISION == rev
3010 && (PERL_VERSION < ver
3011 || (PERL_VERSION == ver
3012 && PERL_SUBVERSION < sver))))
3014 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3015 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3016 PERL_VERSION, PERL_SUBVERSION);
3018 if (ckWARN(WARN_PORTABLE))
3019 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3020 "v-string in use/require non-portable");
3023 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3024 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3025 + ((NV)PERL_SUBVERSION/(NV)1000000)
3026 + 0.00000099 < SvNV(sv))
3030 NV nver = (nrev - rev) * 1000;
3031 UV ver = (UV)(nver + 0.0009);
3032 NV nsver = (nver - ver) * 1000;
3033 UV sver = (UV)(nsver + 0.0009);
3035 /* help out with the "use 5.6" confusion */
3036 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3037 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3038 " (did you mean v%"UVuf".%03"UVuf"?)--"
3039 "this is only v%d.%d.%d, stopped",
3040 rev, ver, sver, rev, ver/100,
3041 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3044 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3045 "this is only v%d.%d.%d, stopped",
3046 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3053 name = SvPV(sv, len);
3054 if (!(name && len > 0 && *name))
3055 DIE(aTHX_ "Null filename used");
3056 TAINT_PROPER("require");
3057 if (PL_op->op_type == OP_REQUIRE &&
3058 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3059 *svp != &PL_sv_undef)
3062 /* prepare to compile file */
3064 if (path_is_absolute(name)) {
3066 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3068 #ifdef MACOS_TRADITIONAL
3072 MacPerl_CanonDir(name, newname, 1);
3073 if (path_is_absolute(newname)) {
3075 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3080 AV *ar = GvAVn(PL_incgv);
3084 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3087 namesv = NEWSV(806, 0);
3088 for (i = 0; i <= AvFILL(ar); i++) {
3089 SV *dirsv = *av_fetch(ar, i, TRUE);
3095 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3096 && !sv_isobject(loader))
3098 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3101 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3102 PTR2UV(SvRV(dirsv)), name);
3103 tryname = SvPVX(namesv);
3114 if (sv_isobject(loader))
3115 count = call_method("INC", G_ARRAY);
3117 count = call_sv(loader, G_ARRAY);
3127 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3131 if (SvTYPE(arg) == SVt_PVGV) {
3132 IO *io = GvIO((GV *)arg);
3137 tryrsfp = IoIFP(io);
3138 if (IoTYPE(io) == IoTYPE_PIPE) {
3139 /* reading from a child process doesn't
3140 nest -- when returning from reading
3141 the inner module, the outer one is
3142 unreadable (closed?) I've tried to
3143 save the gv to manage the lifespan of
3144 the pipe, but this didn't help. XXX */
3145 filter_child_proc = (GV *)arg;
3146 (void)SvREFCNT_inc(filter_child_proc);
3149 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3150 PerlIO_close(IoOFP(io));
3162 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3164 (void)SvREFCNT_inc(filter_sub);
3167 filter_state = SP[i];
3168 (void)SvREFCNT_inc(filter_state);
3172 tryrsfp = PerlIO_open("/dev/null",
3187 filter_has_file = 0;
3188 if (filter_child_proc) {
3189 SvREFCNT_dec(filter_child_proc);
3190 filter_child_proc = 0;
3193 SvREFCNT_dec(filter_state);
3197 SvREFCNT_dec(filter_sub);
3202 if (!path_is_absolute(name)
3203 #ifdef MACOS_TRADITIONAL
3204 /* We consider paths of the form :a:b ambiguous and interpret them first
3205 as global then as local
3207 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3210 char *dir = SvPVx(dirsv, n_a);
3211 #ifdef MACOS_TRADITIONAL
3215 MacPerl_CanonDir(name, buf2, 1);
3216 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3220 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3222 sv_setpv(namesv, unixdir);
3223 sv_catpv(namesv, unixname);
3225 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3228 TAINT_PROPER("require");
3229 tryname = SvPVX(namesv);
3230 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3232 if (tryname[0] == '.' && tryname[1] == '/')
3241 SAVECOPFILE_FREE(&PL_compiling);
3242 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3243 SvREFCNT_dec(namesv);
3245 if (PL_op->op_type == OP_REQUIRE) {
3246 char *msgstr = name;
3247 if (namesv) { /* did we lookup @INC? */
3248 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3249 SV *dirmsgsv = NEWSV(0, 0);
3250 AV *ar = GvAVn(PL_incgv);
3252 sv_catpvn(msg, " in @INC", 8);
3253 if (instr(SvPVX(msg), ".h "))
3254 sv_catpv(msg, " (change .h to .ph maybe?)");
3255 if (instr(SvPVX(msg), ".ph "))
3256 sv_catpv(msg, " (did you run h2ph?)");
3257 sv_catpv(msg, " (@INC contains:");
3258 for (i = 0; i <= AvFILL(ar); i++) {
3259 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3260 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3261 sv_catsv(msg, dirmsgsv);
3263 sv_catpvn(msg, ")", 1);
3264 SvREFCNT_dec(dirmsgsv);
3265 msgstr = SvPV_nolen(msg);
3267 DIE(aTHX_ "Can't locate %s", msgstr);
3273 SETERRNO(0, SS_NORMAL);
3275 /* Assume success here to prevent recursive requirement. */
3277 /* Check whether a hook in @INC has already filled %INC */
3278 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3279 (void)hv_store(GvHVn(PL_incgv), name, len,
3280 (hook_sv ? SvREFCNT_inc(hook_sv)
3281 : newSVpv(CopFILE(&PL_compiling), 0)),
3287 lex_start(sv_2mortal(newSVpvn("",0)));
3288 SAVEGENERICSV(PL_rsfp_filters);
3289 PL_rsfp_filters = Nullav;
3294 SAVESPTR(PL_compiling.cop_warnings);
3295 if (PL_dowarn & G_WARN_ALL_ON)
3296 PL_compiling.cop_warnings = pWARN_ALL ;
3297 else if (PL_dowarn & G_WARN_ALL_OFF)
3298 PL_compiling.cop_warnings = pWARN_NONE ;
3299 else if (PL_taint_warn)
3300 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3302 PL_compiling.cop_warnings = pWARN_STD ;
3303 SAVESPTR(PL_compiling.cop_io);
3304 PL_compiling.cop_io = Nullsv;
3306 if (filter_sub || filter_child_proc) {
3307 SV *datasv = filter_add(run_user_filter, Nullsv);
3308 IoLINES(datasv) = filter_has_file;
3309 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3310 IoTOP_GV(datasv) = (GV *)filter_state;
3311 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3314 /* switch to eval mode */
3315 push_return(PL_op->op_next);
3316 PUSHBLOCK(cx, CXt_EVAL, SP);
3317 PUSHEVAL(cx, name, Nullgv);
3319 SAVECOPLINE(&PL_compiling);
3320 CopLINE_set(&PL_compiling, 0);
3324 /* Store and reset encoding. */
3325 encoding = PL_encoding;
3326 PL_encoding = Nullsv;
3328 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3330 /* Restore encoding. */
3331 PL_encoding = encoding;
3338 return pp_require();
3344 register PERL_CONTEXT *cx;
3346 I32 gimme = GIMME_V, was = PL_sub_generation;
3347 char tbuf[TYPE_DIGITS(long) + 12];
3348 char *tmpbuf = tbuf;
3357 TAINT_PROPER("eval");
3363 /* switch to eval mode */
3365 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3366 SV *sv = sv_newmortal();
3367 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3368 (unsigned long)++PL_evalseq,
3369 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3373 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3374 SAVECOPFILE_FREE(&PL_compiling);
3375 CopFILE_set(&PL_compiling, tmpbuf+2);
3376 SAVECOPLINE(&PL_compiling);
3377 CopLINE_set(&PL_compiling, 1);
3378 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3379 deleting the eval's FILEGV from the stash before gv_check() runs
3380 (i.e. before run-time proper). To work around the coredump that
3381 ensues, we always turn GvMULTI_on for any globals that were
3382 introduced within evals. See force_ident(). GSAR 96-10-12 */
3383 safestr = savepv(tmpbuf);
3384 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3386 PL_hints = PL_op->op_targ;
3387 SAVESPTR(PL_compiling.cop_warnings);
3388 if (specialWARN(PL_curcop->cop_warnings))
3389 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3391 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3392 SAVEFREESV(PL_compiling.cop_warnings);
3394 SAVESPTR(PL_compiling.cop_io);
3395 if (specialCopIO(PL_curcop->cop_io))
3396 PL_compiling.cop_io = PL_curcop->cop_io;
3398 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3399 SAVEFREESV(PL_compiling.cop_io);
3401 /* special case: an eval '' executed within the DB package gets lexically
3402 * placed in the first non-DB CV rather than the current CV - this
3403 * allows the debugger to execute code, find lexicals etc, in the
3404 * scope of the code being debugged. Passing &seq gets find_runcv
3405 * to do the dirty work for us */
3406 runcv = find_runcv(&seq);
3408 push_return(PL_op->op_next);
3409 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3410 PUSHEVAL(cx, 0, Nullgv);
3412 /* prepare to compile string */
3414 if (PERLDB_LINE && PL_curstash != PL_debstash)
3415 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3417 ret = doeval(gimme, NULL, runcv, seq);
3418 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3419 && ret != PL_op->op_next) { /* Successive compilation. */
3420 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3422 return DOCATCH(ret);
3432 register PERL_CONTEXT *cx;
3434 U8 save_flags = PL_op -> op_flags;
3439 retop = pop_return();
3442 if (gimme == G_VOID)
3444 else if (gimme == G_SCALAR) {
3447 if (SvFLAGS(TOPs) & SVs_TEMP)
3450 *MARK = sv_mortalcopy(TOPs);
3454 *MARK = &PL_sv_undef;
3459 /* in case LEAVE wipes old return values */
3460 for (mark = newsp + 1; mark <= SP; mark++) {
3461 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3462 *mark = sv_mortalcopy(*mark);
3463 TAINT_NOT; /* Each item is independent */
3467 PL_curpm = newpm; /* Don't pop $1 et al till now */
3470 assert(CvDEPTH(PL_compcv) == 1);
3472 CvDEPTH(PL_compcv) = 0;
3475 if (optype == OP_REQUIRE &&
3476 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3478 /* Unassume the success we assumed earlier. */
3479 SV *nsv = cx->blk_eval.old_namesv;
3480 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3481 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3482 /* die_where() did LEAVE, or we won't be here */
3486 if (!(save_flags & OPf_SPECIAL))
3496 register PERL_CONTEXT *cx;
3497 I32 gimme = GIMME_V;
3502 push_return(cLOGOP->op_other->op_next);
3503 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3506 PL_in_eval = EVAL_INEVAL;
3509 return DOCATCH(PL_op->op_next);
3520 register PERL_CONTEXT *cx;
3525 retop = pop_return();
3528 if (gimme == G_VOID)
3530 else if (gimme == G_SCALAR) {
3533 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3536 *MARK = sv_mortalcopy(TOPs);
3540 *MARK = &PL_sv_undef;
3545 /* in case LEAVE wipes old return values */
3546 for (mark = newsp + 1; mark <= SP; mark++) {
3547 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3548 *mark = sv_mortalcopy(*mark);
3549 TAINT_NOT; /* Each item is independent */
3553 PL_curpm = newpm; /* Don't pop $1 et al till now */
3561 S_doparseform(pTHX_ SV *sv)
3564 register char *s = SvPV_force(sv, len);
3565 register char *send = s + len;
3566 register char *base = Nullch;
3567 register I32 skipspaces = 0;
3568 bool noblank = FALSE;
3569 bool repeat = FALSE;
3570 bool postspace = FALSE;
3576 int maxops = 2; /* FF_LINEMARK + FF_END) */
3579 Perl_croak(aTHX_ "Null picture in formline");
3581 /* estimate the buffer size needed */
3582 for (base = s; s <= send; s++) {
3583 if (*s == '\n' || *s == '@' || *s == '^')
3589 New(804, fops, maxops, U16);
3594 *fpc++ = FF_LINEMARK;
3595 noblank = repeat = FALSE;
3613 case ' ': case '\t':
3624 *fpc++ = FF_LITERAL;
3632 *fpc++ = (U16)skipspaces;
3636 *fpc++ = FF_NEWLINE;
3640 arg = fpc - linepc + 1;
3647 *fpc++ = FF_LINEMARK;
3648 noblank = repeat = FALSE;
3657 ischop = s[-1] == '^';
3663 arg = (s - base) - 1;
3665 *fpc++ = FF_LITERAL;
3674 *fpc++ = FF_LINEGLOB;
3676 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3677 arg = ischop ? 512 : 0;
3687 arg |= 256 + (s - f);
3689 *fpc++ = s - base; /* fieldsize for FETCH */
3690 *fpc++ = FF_DECIMAL;
3693 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3694 arg = ischop ? 512 : 0;
3696 s++; /* skip the '0' first */
3705 arg |= 256 + (s - f);
3707 *fpc++ = s - base; /* fieldsize for FETCH */
3708 *fpc++ = FF_0DECIMAL;
3713 bool ismore = FALSE;
3716 while (*++s == '>') ;
3717 prespace = FF_SPACE;
3719 else if (*s == '|') {
3720 while (*++s == '|') ;
3721 prespace = FF_HALFSPACE;
3726 while (*++s == '<') ;
3729 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3733 *fpc++ = s - base; /* fieldsize for FETCH */
3735 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3738 *fpc++ = (U16)prespace;
3752 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3754 { /* need to jump to the next word */
3756 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3757 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3758 s = SvPVX(sv) + SvCUR(sv) + z;
3760 Copy(fops, s, arg, U16);
3762 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3767 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3769 SV *datasv = FILTER_DATA(idx);
3770 int filter_has_file = IoLINES(datasv);
3771 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3772 SV *filter_state = (SV *)IoTOP_GV(datasv);
3773 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3776 /* I was having segfault trouble under Linux 2.2.5 after a
3777 parse error occured. (Had to hack around it with a test
3778 for PL_error_count == 0.) Solaris doesn't segfault --
3779 not sure where the trouble is yet. XXX */
3781 if (filter_has_file) {
3782 len = FILTER_READ(idx+1, buf_sv, maxlen);
3785 if (filter_sub && len >= 0) {
3796 PUSHs(sv_2mortal(newSViv(maxlen)));
3798 PUSHs(filter_state);
3801 count = call_sv(filter_sub, G_SCALAR);
3817 IoLINES(datasv) = 0;
3818 if (filter_child_proc) {
3819 SvREFCNT_dec(filter_child_proc);
3820 IoFMT_GV(datasv) = Nullgv;
3823 SvREFCNT_dec(filter_state);
3824 IoTOP_GV(datasv) = Nullgv;
3827 SvREFCNT_dec(filter_sub);
3828 IoBOTTOM_GV(datasv) = Nullgv;
3830 filter_del(run_user_filter);
3836 /* perhaps someone can come up with a better name for
3837 this? it is not really "absolute", per se ... */
3839 S_path_is_absolute(pTHX_ char *name)
3841 if (PERL_FILE_IS_ABSOLUTE(name)
3842 #ifdef MACOS_TRADITIONAL
3845 || (*name == '.' && (name[1] == '/' ||
3846 (name[1] == '.' && name[2] == '/'))))