3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
20 #define PERL_IN_PP_CTL_C
24 #define WORD_ALIGN sizeof(U16)
27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
37 cxix = dopoptosub(cxstack_ix);
41 switch (cxstack[cxix].blk_gimme) {
58 /* XXXX Should store the old value to allow for tie/overload - and
59 restore in regcomp, where marked with XXXX. */
67 register PMOP *pm = (PMOP*)cLOGOP->op_other;
71 MAGIC *mg = Null(MAGIC*);
75 /* prevent recompiling under /o and ithreads. */
76 #if defined(USE_ITHREADS)
77 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
82 SV *sv = SvRV(tmpstr);
84 mg = mg_find(sv, PERL_MAGIC_qr);
87 regexp *re = (regexp *)mg->mg_obj;
88 ReREFCNT_dec(PM_GETRE(pm));
89 PM_SETRE(pm, ReREFCNT_inc(re));
92 t = SvPV(tmpstr, len);
94 /* Check against the last compiled regexp. */
95 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
96 PM_GETRE(pm)->prelen != (I32)len ||
97 memNE(PM_GETRE(pm)->precomp, t, len))
100 ReREFCNT_dec(PM_GETRE(pm));
101 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
103 if (PL_op->op_flags & OPf_SPECIAL)
104 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
106 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
108 pm->op_pmdynflags |= PMdf_DYN_UTF8;
110 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
111 if (pm->op_pmdynflags & PMdf_UTF8)
112 t = (char*)bytes_to_utf8((U8*)t, &len);
114 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
115 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
117 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
118 inside tie/overload accessors. */
122 #ifndef INCOMPLETE_TAINTS
125 pm->op_pmdynflags |= PMdf_TAINTED;
127 pm->op_pmdynflags &= ~PMdf_TAINTED;
131 if (!PM_GETRE(pm)->prelen && PL_curpm)
133 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
134 pm->op_pmflags |= PMf_WHITE;
136 pm->op_pmflags &= ~PMf_WHITE;
138 /* XXX runtime compiled output needs to move to the pad */
139 if (pm->op_pmflags & PMf_KEEP) {
140 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
141 #if !defined(USE_ITHREADS)
142 /* XXX can't change the optree at runtime either */
143 cLOGOP->op_first->op_next = PL_op->op_next;
152 register PMOP *pm = (PMOP*) cLOGOP->op_other;
153 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
154 register SV *dstr = cx->sb_dstr;
155 register char *s = cx->sb_s;
156 register char *m = cx->sb_m;
157 char *orig = cx->sb_orig;
158 register REGEXP *rx = cx->sb_rx;
161 rxres_restore(&cx->sb_rxres, rx);
162 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
164 if (cx->sb_iters++) {
165 I32 saviters = cx->sb_iters;
166 if (cx->sb_iters > cx->sb_maxiters)
167 DIE(aTHX_ "Substitution loop");
169 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
170 cx->sb_rxtainted |= 2;
171 sv_catsv(dstr, POPs);
174 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
175 s == m, cx->sb_targ, NULL,
176 ((cx->sb_rflags & REXEC_COPY_STR)
177 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
178 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
180 SV *targ = cx->sb_targ;
182 if (DO_UTF8(dstr) && !SvUTF8(targ))
183 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
185 sv_catpvn(dstr, s, cx->sb_strend - s);
186 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
188 #ifdef PERL_COPY_ON_WRITE
190 sv_force_normal_flags(targ, SV_COW_DROP_PV);
194 (void)SvOOK_off(targ);
196 Safefree(SvPVX(targ));
198 SvPVX(targ) = SvPVX(dstr);
199 SvCUR_set(targ, SvCUR(dstr));
200 SvLEN_set(targ, SvLEN(dstr));
206 TAINT_IF(cx->sb_rxtainted & 1);
207 PUSHs(sv_2mortal(newSViv(saviters - 1)));
209 (void)SvPOK_only_UTF8(targ);
210 TAINT_IF(cx->sb_rxtainted);
214 LEAVE_SCOPE(cx->sb_oldsave);
216 RETURNOP(pm->op_next);
218 cx->sb_iters = saviters;
220 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
223 cx->sb_orig = orig = rx->subbeg;
225 cx->sb_strend = s + (cx->sb_strend - m);
227 cx->sb_m = m = rx->startp[0] + orig;
229 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
230 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
232 sv_catpvn(dstr, s, m-s);
234 cx->sb_s = rx->endp[0] + orig;
235 { /* Update the pos() information. */
236 SV *sv = cx->sb_targ;
239 if (SvTYPE(sv) < SVt_PVMG)
240 (void)SvUPGRADE(sv, SVt_PVMG);
241 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
242 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
243 mg = mg_find(sv, PERL_MAGIC_regex_global);
250 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
251 rxres_save(&cx->sb_rxres, rx);
252 RETURNOP(pm->op_pmreplstart);
256 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
261 if (!p || p[1] < rx->nparens) {
262 #ifdef PERL_COPY_ON_WRITE
263 i = 7 + rx->nparens * 2;
265 i = 6 + rx->nparens * 2;
274 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
275 RX_MATCH_COPIED_off(rx);
277 #ifdef PERL_COPY_ON_WRITE
278 *p++ = PTR2UV(rx->saved_copy);
279 rx->saved_copy = Nullsv;
284 *p++ = PTR2UV(rx->subbeg);
285 *p++ = (UV)rx->sublen;
286 for (i = 0; i <= rx->nparens; ++i) {
287 *p++ = (UV)rx->startp[i];
288 *p++ = (UV)rx->endp[i];
293 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
298 RX_MATCH_COPY_FREE(rx);
299 RX_MATCH_COPIED_set(rx, *p);
302 #ifdef PERL_COPY_ON_WRITE
304 SvREFCNT_dec (rx->saved_copy);
305 rx->saved_copy = INT2PTR(SV*,*p);
311 rx->subbeg = INT2PTR(char*,*p++);
312 rx->sublen = (I32)(*p++);
313 for (i = 0; i <= rx->nparens; ++i) {
314 rx->startp[i] = (I32)(*p++);
315 rx->endp[i] = (I32)(*p++);
320 Perl_rxres_free(pTHX_ void **rsp)
325 Safefree(INT2PTR(char*,*p));
326 #ifdef PERL_COPY_ON_WRITE
328 SvREFCNT_dec (INT2PTR(SV*,p[1]));
338 dSP; dMARK; dORIGMARK;
339 register SV *tmpForm = *++MARK;
346 register SV *sv = Nullsv;
351 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
352 char *chophere = Nullch;
353 char *linemark = Nullch;
355 bool gotsome = FALSE;
357 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
358 bool item_is_utf8 = FALSE;
359 bool targ_is_utf8 = FALSE;
362 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
363 if (SvREADONLY(tmpForm)) {
364 SvREADONLY_off(tmpForm);
365 doparseform(tmpForm);
366 SvREADONLY_on(tmpForm);
369 doparseform(tmpForm);
371 SvPV_force(PL_formtarget, len);
372 if (DO_UTF8(PL_formtarget))
374 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
376 f = SvPV(tmpForm, len);
377 /* need to jump to the next word */
378 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
387 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
388 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
389 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
390 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
391 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
393 case FF_CHECKNL: name = "CHECKNL"; break;
394 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
395 case FF_SPACE: name = "SPACE"; break;
396 case FF_HALFSPACE: name = "HALFSPACE"; break;
397 case FF_ITEM: name = "ITEM"; break;
398 case FF_CHOP: name = "CHOP"; break;
399 case FF_LINEGLOB: name = "LINEGLOB"; break;
400 case FF_NEWLINE: name = "NEWLINE"; break;
401 case FF_MORE: name = "MORE"; break;
402 case FF_LINEMARK: name = "LINEMARK"; break;
403 case FF_END: name = "END"; break;
404 case FF_0DECIMAL: name = "0DECIMAL"; break;
407 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
409 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
420 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
421 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
423 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
424 t = SvEND(PL_formtarget);
427 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
428 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
430 sv_utf8_upgrade(PL_formtarget);
431 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
432 t = SvEND(PL_formtarget);
452 if (ckWARN(WARN_SYNTAX))
453 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
458 item = s = SvPV(sv, len);
461 itemsize = sv_len_utf8(sv);
462 if (itemsize != (I32)len) {
464 if (itemsize > fieldsize) {
465 itemsize = fieldsize;
466 itembytes = itemsize;
467 sv_pos_u2b(sv, &itembytes, 0);
471 send = chophere = s + itembytes;
481 sv_pos_b2u(sv, &itemsize);
485 item_is_utf8 = FALSE;
486 if (itemsize > fieldsize)
487 itemsize = fieldsize;
488 send = chophere = s + itemsize;
500 item = s = SvPV(sv, len);
503 itemsize = sv_len_utf8(sv);
504 if (itemsize != (I32)len) {
506 if (itemsize <= fieldsize) {
507 send = chophere = s + itemsize;
518 itemsize = fieldsize;
519 itembytes = itemsize;
520 sv_pos_u2b(sv, &itembytes, 0);
521 send = chophere = s + itembytes;
522 while (s < send || (s == send && isSPACE(*s))) {
532 if (strchr(PL_chopset, *s))
537 itemsize = chophere - item;
538 sv_pos_b2u(sv, &itemsize);
544 item_is_utf8 = FALSE;
545 if (itemsize <= fieldsize) {
546 send = chophere = s + itemsize;
557 itemsize = fieldsize;
558 send = chophere = s + itemsize;
559 while (s < send || (s == send && isSPACE(*s))) {
569 if (strchr(PL_chopset, *s))
574 itemsize = chophere - item;
579 arg = fieldsize - itemsize;
588 arg = fieldsize - itemsize;
602 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
604 sv_utf8_upgrade(PL_formtarget);
605 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
606 t = SvEND(PL_formtarget);
610 if (UTF8_IS_CONTINUED(*s)) {
611 STRLEN skip = UTF8SKIP(s);
628 if ( !((*t++ = *s++) & ~31) )
634 if (targ_is_utf8 && !item_is_utf8) {
635 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
637 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
638 for (; t < SvEND(PL_formtarget); t++) {
640 int ch = *t++ = *s++;
651 int ch = *t++ = *s++;
654 if ( !((*t++ = *s++) & ~31) )
663 while (*s && isSPACE(*s))
670 item = s = SvPV(sv, len);
672 if ((item_is_utf8 = DO_UTF8(sv)))
673 itemsize = sv_len_utf8(sv);
675 bool chopped = FALSE;
688 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
690 SvUTF8_on(PL_formtarget);
691 sv_catsv(PL_formtarget, sv);
693 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
694 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
695 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
702 /* If the field is marked with ^ and the value is undefined,
705 if ((arg & 512) && !SvOK(sv)) {
713 /* Formats aren't yet marked for locales, so assume "yes". */
715 STORE_NUMERIC_STANDARD_SET_LOCAL();
716 #if defined(USE_LONG_DOUBLE)
718 sprintf(t, "%#*.*" PERL_PRIfldbl,
719 (int) fieldsize, (int) arg & 255, value);
721 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
726 (int) fieldsize, (int) arg & 255, value);
729 (int) fieldsize, value);
732 RESTORE_NUMERIC_STANDARD();
738 /* If the field is marked with ^ and the value is undefined,
741 if ((arg & 512) && !SvOK(sv)) {
749 /* Formats aren't yet marked for locales, so assume "yes". */
751 STORE_NUMERIC_STANDARD_SET_LOCAL();
752 #if defined(USE_LONG_DOUBLE)
754 sprintf(t, "%#0*.*" PERL_PRIfldbl,
755 (int) fieldsize, (int) arg & 255, value);
756 /* is this legal? I don't have long doubles */
758 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
762 sprintf(t, "%#0*.*f",
763 (int) fieldsize, (int) arg & 255, value);
766 (int) fieldsize, value);
769 RESTORE_NUMERIC_STANDARD();
776 while (t-- > linemark && *t == ' ') ;
784 if (arg) { /* repeat until fields exhausted? */
786 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
787 lines += FmLINES(PL_formtarget);
790 if (strnEQ(linemark, linemark - arg, arg))
791 DIE(aTHX_ "Runaway format");
794 SvUTF8_on(PL_formtarget);
795 FmLINES(PL_formtarget) = lines;
797 RETURNOP(cLISTOP->op_first);
810 while (*s && isSPACE(*s) && s < send)
814 arg = fieldsize - itemsize;
821 if (strnEQ(s," ",3)) {
822 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
833 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
835 SvUTF8_on(PL_formtarget);
836 FmLINES(PL_formtarget) += lines;
848 if (PL_stack_base + *PL_markstack_ptr == SP) {
850 if (GIMME_V == G_SCALAR)
851 XPUSHs(sv_2mortal(newSViv(0)));
852 RETURNOP(PL_op->op_next->op_next);
854 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
855 pp_pushmark(); /* push dst */
856 pp_pushmark(); /* push src */
857 ENTER; /* enter outer scope */
860 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
862 ENTER; /* enter inner scope */
865 src = PL_stack_base[*PL_markstack_ptr];
870 if (PL_op->op_type == OP_MAPSTART)
871 pp_pushmark(); /* push top */
872 return ((LOGOP*)PL_op->op_next)->op_other;
877 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
883 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
889 /* first, move source pointer to the next item in the source list */
890 ++PL_markstack_ptr[-1];
892 /* if there are new items, push them into the destination list */
894 /* might need to make room back there first */
895 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
896 /* XXX this implementation is very pessimal because the stack
897 * is repeatedly extended for every set of items. Is possible
898 * to do this without any stack extension or copying at all
899 * by maintaining a separate list over which the map iterates
900 * (like foreach does). --gsar */
902 /* everything in the stack after the destination list moves
903 * towards the end the stack by the amount of room needed */
904 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
906 /* items to shift up (accounting for the moved source pointer) */
907 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
909 /* This optimization is by Ben Tilly and it does
910 * things differently from what Sarathy (gsar)
911 * is describing. The downside of this optimization is
912 * that leaves "holes" (uninitialized and hopefully unused areas)
913 * to the Perl stack, but on the other hand this
914 * shouldn't be a problem. If Sarathy's idea gets
915 * implemented, this optimization should become
916 * irrelevant. --jhi */
918 shift = count; /* Avoid shifting too often --Ben Tilly */
923 PL_markstack_ptr[-1] += shift;
924 *PL_markstack_ptr += shift;
928 /* copy the new items down to the destination list */
929 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
931 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
933 LEAVE; /* exit inner scope */
936 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
939 (void)POPMARK; /* pop top */
940 LEAVE; /* exit outer scope */
941 (void)POPMARK; /* pop src */
942 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
943 (void)POPMARK; /* pop dst */
944 SP = PL_stack_base + POPMARK; /* pop original mark */
945 if (gimme == G_SCALAR) {
949 else if (gimme == G_ARRAY)
956 ENTER; /* enter inner scope */
959 /* set $_ to the new source item */
960 src = PL_stack_base[PL_markstack_ptr[-1]];
964 RETURNOP(cLOGOP->op_other);
972 if (GIMME == G_ARRAY)
974 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
975 return cLOGOP->op_other;
984 if (GIMME == G_ARRAY) {
985 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
989 SV *targ = PAD_SV(PL_op->op_targ);
992 if (PL_op->op_private & OPpFLIP_LINENUM) {
993 if (GvIO(PL_last_in_gv)) {
994 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
997 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
998 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1004 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1005 if (PL_op->op_flags & OPf_SPECIAL) {
1013 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1026 if (GIMME == G_ARRAY) {
1032 if (SvGMAGICAL(left))
1034 if (SvGMAGICAL(right))
1037 /* This code tries to decide if "$left .. $right" should use the
1038 magical string increment, or if the range is numeric (we make
1039 an exception for .."0" [#18165]). AMS 20021031. */
1041 if (SvNIOKp(left) || !SvPOKp(left) ||
1042 SvNIOKp(right) || !SvPOKp(right) ||
1043 (looks_like_number(left) && *SvPVX(left) != '0' &&
1044 looks_like_number(right)))
1046 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1047 DIE(aTHX_ "Range iterator outside integer range");
1058 sv = sv_2mortal(newSViv(i++));
1063 SV *final = sv_mortalcopy(right);
1065 char *tmps = SvPV(final, len);
1067 sv = sv_mortalcopy(left);
1069 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1071 if (strEQ(SvPVX(sv),tmps))
1073 sv = sv_2mortal(newSVsv(sv));
1080 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1084 if (PL_op->op_private & OPpFLIP_LINENUM) {
1085 if (GvIO(PL_last_in_gv)) {
1086 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1089 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1090 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1098 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1099 sv_catpv(targ, "E0");
1109 static char *context_name[] = {
1120 S_dopoptolabel(pTHX_ char *label)
1123 register PERL_CONTEXT *cx;
1125 for (i = cxstack_ix; i >= 0; i--) {
1127 switch (CxTYPE(cx)) {
1133 if (ckWARN(WARN_EXITING))
1134 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1135 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1136 if (CxTYPE(cx) == CXt_NULL)
1140 if (!cx->blk_loop.label ||
1141 strNE(label, cx->blk_loop.label) ) {
1142 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1143 (long)i, cx->blk_loop.label));
1146 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1154 Perl_dowantarray(pTHX)
1156 I32 gimme = block_gimme();
1157 return (gimme == G_VOID) ? G_SCALAR : gimme;
1161 Perl_block_gimme(pTHX)
1165 cxix = dopoptosub(cxstack_ix);
1169 switch (cxstack[cxix].blk_gimme) {
1177 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1184 Perl_is_lvalue_sub(pTHX)
1188 cxix = dopoptosub(cxstack_ix);
1189 assert(cxix >= 0); /* We should only be called from inside subs */
1191 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1192 return cxstack[cxix].blk_sub.lval;
1198 S_dopoptosub(pTHX_ I32 startingblock)
1200 return dopoptosub_at(cxstack, startingblock);
1204 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1207 register PERL_CONTEXT *cx;
1208 for (i = startingblock; i >= 0; i--) {
1210 switch (CxTYPE(cx)) {
1216 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1224 S_dopoptoeval(pTHX_ I32 startingblock)
1227 register PERL_CONTEXT *cx;
1228 for (i = startingblock; i >= 0; i--) {
1230 switch (CxTYPE(cx)) {
1234 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1242 S_dopoptoloop(pTHX_ I32 startingblock)
1245 register PERL_CONTEXT *cx;
1246 for (i = startingblock; i >= 0; i--) {
1248 switch (CxTYPE(cx)) {
1254 if (ckWARN(WARN_EXITING))
1255 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1256 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1257 if ((CxTYPE(cx)) == CXt_NULL)
1261 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1269 Perl_dounwind(pTHX_ I32 cxix)
1271 register PERL_CONTEXT *cx;
1274 while (cxstack_ix > cxix) {
1276 cx = &cxstack[cxstack_ix];
1277 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1278 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1279 /* Note: we don't need to restore the base context info till the end. */
1280 switch (CxTYPE(cx)) {
1283 continue; /* not break */
1305 Perl_qerror(pTHX_ SV *err)
1308 sv_catsv(ERRSV, err);
1310 sv_catsv(PL_errors, err);
1312 Perl_warn(aTHX_ "%"SVf, err);
1317 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1325 register PERL_CONTEXT *cx;
1330 if (PL_in_eval & EVAL_KEEPERR) {
1331 static char prefix[] = "\t(in cleanup) ";
1336 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1339 if (*e != *message || strNE(e,message))
1343 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1344 sv_catpvn(err, prefix, sizeof(prefix)-1);
1345 sv_catpvn(err, message, msglen);
1346 if (ckWARN(WARN_MISC)) {
1347 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1348 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1353 sv_setpvn(ERRSV, message, msglen);
1357 message = SvPVx(ERRSV, msglen);
1359 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1360 && PL_curstackinfo->si_prev)
1369 if (cxix < cxstack_ix)
1372 POPBLOCK(cx,PL_curpm);
1373 if (CxTYPE(cx) != CXt_EVAL) {
1374 PerlIO_write(Perl_error_log, "panic: die ", 11);
1375 PerlIO_write(Perl_error_log, message, msglen);
1380 if (gimme == G_SCALAR)
1381 *++newsp = &PL_sv_undef;
1382 PL_stack_sp = newsp;
1386 /* LEAVE could clobber PL_curcop (see save_re_context())
1387 * XXX it might be better to find a way to avoid messing with
1388 * PL_curcop in save_re_context() instead, but this is a more
1389 * minimal fix --GSAR */
1390 PL_curcop = cx->blk_oldcop;
1392 if (optype == OP_REQUIRE) {
1393 char* msg = SvPVx(ERRSV, n_a);
1394 DIE(aTHX_ "%sCompilation failed in require",
1395 *msg ? msg : "Unknown error\n");
1397 return pop_return();
1401 message = SvPVx(ERRSV, msglen);
1403 /* if STDERR is tied, print to it instead */
1404 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1405 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1408 XPUSHs(SvTIED_obj((SV*)io, mg));
1409 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1411 call_method("PRINT", G_SCALAR);
1416 /* SFIO can really mess with your errno */
1419 PerlIO *serr = Perl_error_log;
1421 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1422 (void)PerlIO_flush(serr);
1435 if (SvTRUE(left) != SvTRUE(right))
1447 RETURNOP(cLOGOP->op_other);
1456 RETURNOP(cLOGOP->op_other);
1465 if (!sv || !SvANY(sv)) {
1466 RETURNOP(cLOGOP->op_other);
1469 switch (SvTYPE(sv)) {
1471 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1475 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1479 if (CvROOT(sv) || CvXSUB(sv))
1489 RETURNOP(cLOGOP->op_other);
1495 register I32 cxix = dopoptosub(cxstack_ix);
1496 register PERL_CONTEXT *cx;
1497 register PERL_CONTEXT *ccstack = cxstack;
1498 PERL_SI *top_si = PL_curstackinfo;
1509 /* we may be in a higher stacklevel, so dig down deeper */
1510 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1511 top_si = top_si->si_prev;
1512 ccstack = top_si->si_cxstack;
1513 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1516 if (GIMME != G_ARRAY) {
1522 if (PL_DBsub && cxix >= 0 &&
1523 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1527 cxix = dopoptosub_at(ccstack, cxix - 1);
1530 cx = &ccstack[cxix];
1531 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1532 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1533 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1534 field below is defined for any cx. */
1535 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1536 cx = &ccstack[dbcxix];
1539 stashname = CopSTASHPV(cx->blk_oldcop);
1540 if (GIMME != G_ARRAY) {
1543 PUSHs(&PL_sv_undef);
1546 sv_setpv(TARG, stashname);
1555 PUSHs(&PL_sv_undef);
1557 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1558 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1559 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1562 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1563 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1564 /* So is ccstack[dbcxix]. */
1567 gv_efullname3(sv, cvgv, Nullch);
1568 PUSHs(sv_2mortal(sv));
1569 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1572 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1573 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1577 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1578 PUSHs(sv_2mortal(newSViv(0)));
1580 gimme = (I32)cx->blk_gimme;
1581 if (gimme == G_VOID)
1582 PUSHs(&PL_sv_undef);
1584 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1585 if (CxTYPE(cx) == CXt_EVAL) {
1587 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1588 PUSHs(cx->blk_eval.cur_text);
1592 else if (cx->blk_eval.old_namesv) {
1593 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1596 /* eval BLOCK (try blocks have old_namesv == 0) */
1598 PUSHs(&PL_sv_undef);
1599 PUSHs(&PL_sv_undef);
1603 PUSHs(&PL_sv_undef);
1604 PUSHs(&PL_sv_undef);
1606 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1607 && CopSTASH_eq(PL_curcop, PL_debstash))
1609 AV *ary = cx->blk_sub.argarray;
1610 int off = AvARRAY(ary) - AvALLOC(ary);
1614 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1617 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1620 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1621 av_extend(PL_dbargs, AvFILLp(ary) + off);
1622 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1623 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1625 /* XXX only hints propagated via op_private are currently
1626 * visible (others are not easily accessible, since they
1627 * use the global PL_hints) */
1628 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1629 HINT_PRIVATE_MASK)));
1632 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1634 if (old_warnings == pWARN_NONE ||
1635 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1636 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1637 else if (old_warnings == pWARN_ALL ||
1638 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1639 /* Get the bit mask for $warnings::Bits{all}, because
1640 * it could have been extended by warnings::register */
1642 HV *bits = get_hv("warnings::Bits", FALSE);
1643 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1644 mask = newSVsv(*bits_all);
1647 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1651 mask = newSVsv(old_warnings);
1652 PUSHs(sv_2mortal(mask));
1667 sv_reset(tmps, CopSTASH(PL_curcop));
1677 /* like pp_nextstate, but used instead when the debugger is active */
1681 PL_curcop = (COP*)PL_op;
1682 TAINT_NOT; /* Each statement is presumed innocent */
1683 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1686 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1687 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1691 register PERL_CONTEXT *cx;
1692 I32 gimme = G_ARRAY;
1699 DIE(aTHX_ "No DB::DB routine defined");
1701 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1702 /* don't do recursive DB::DB call */
1714 push_return(PL_op->op_next);
1715 PUSHBLOCK(cx, CXt_SUB, SP);
1718 (void)SvREFCNT_inc(cv);
1719 PAD_SET_CUR(CvPADLIST(cv),1);
1720 RETURNOP(CvSTART(cv));
1734 register PERL_CONTEXT *cx;
1735 I32 gimme = GIMME_V;
1737 U32 cxtype = CXt_LOOP;
1745 if (PL_op->op_targ) {
1746 #ifndef USE_ITHREADS
1747 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1750 SAVEPADSV(PL_op->op_targ);
1751 iterdata = INT2PTR(void*, PL_op->op_targ);
1752 cxtype |= CXp_PADVAR;
1757 svp = &GvSV(gv); /* symbol table variable */
1758 SAVEGENERICSV(*svp);
1761 iterdata = (void*)gv;
1767 PUSHBLOCK(cx, cxtype, SP);
1769 PUSHLOOP(cx, iterdata, MARK);
1771 PUSHLOOP(cx, svp, MARK);
1773 if (PL_op->op_flags & OPf_STACKED) {
1774 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1775 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1777 /* See comment in pp_flop() */
1778 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1779 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1780 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1781 looks_like_number((SV*)cx->blk_loop.iterary)))
1783 if (SvNV(sv) < IV_MIN ||
1784 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1785 DIE(aTHX_ "Range iterator outside integer range");
1786 cx->blk_loop.iterix = SvIV(sv);
1787 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1790 cx->blk_loop.iterlval = newSVsv(sv);
1794 cx->blk_loop.iterary = PL_curstack;
1795 AvFILLp(PL_curstack) = SP - PL_stack_base;
1796 cx->blk_loop.iterix = MARK - PL_stack_base;
1805 register PERL_CONTEXT *cx;
1806 I32 gimme = GIMME_V;
1812 PUSHBLOCK(cx, CXt_LOOP, SP);
1813 PUSHLOOP(cx, 0, SP);
1821 register PERL_CONTEXT *cx;
1829 newsp = PL_stack_base + cx->blk_loop.resetsp;
1832 if (gimme == G_VOID)
1834 else if (gimme == G_SCALAR) {
1836 *++newsp = sv_mortalcopy(*SP);
1838 *++newsp = &PL_sv_undef;
1842 *++newsp = sv_mortalcopy(*++mark);
1843 TAINT_NOT; /* Each item is independent */
1849 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1850 PL_curpm = newpm; /* ... and pop $1 et al */
1862 register PERL_CONTEXT *cx;
1863 bool popsub2 = FALSE;
1864 bool clear_errsv = FALSE;
1871 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1872 if (cxstack_ix == PL_sortcxix
1873 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1875 if (cxstack_ix > PL_sortcxix)
1876 dounwind(PL_sortcxix);
1877 AvARRAY(PL_curstack)[1] = *SP;
1878 PL_stack_sp = PL_stack_base + 1;
1883 cxix = dopoptosub(cxstack_ix);
1885 DIE(aTHX_ "Can't return outside a subroutine");
1886 if (cxix < cxstack_ix)
1890 switch (CxTYPE(cx)) {
1895 if (!(PL_in_eval & EVAL_KEEPERR))
1901 if (optype == OP_REQUIRE &&
1902 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1904 /* Unassume the success we assumed earlier. */
1905 SV *nsv = cx->blk_eval.old_namesv;
1906 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1907 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1914 DIE(aTHX_ "panic: return");
1918 if (gimme == G_SCALAR) {
1921 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1923 *++newsp = SvREFCNT_inc(*SP);
1928 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1930 *++newsp = sv_mortalcopy(sv);
1935 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1938 *++newsp = sv_mortalcopy(*SP);
1941 *++newsp = &PL_sv_undef;
1943 else if (gimme == G_ARRAY) {
1944 while (++MARK <= SP) {
1945 *++newsp = (popsub2 && SvTEMP(*MARK))
1946 ? *MARK : sv_mortalcopy(*MARK);
1947 TAINT_NOT; /* Each item is independent */
1950 PL_stack_sp = newsp;
1952 /* Stack values are safe: */
1954 POPSUB(cx,sv); /* release CV and @_ ... */
1958 PL_curpm = newpm; /* ... and pop $1 et al */
1964 return pop_return();
1971 register PERL_CONTEXT *cx;
1981 if (PL_op->op_flags & OPf_SPECIAL) {
1982 cxix = dopoptoloop(cxstack_ix);
1984 DIE(aTHX_ "Can't \"last\" outside a loop block");
1987 cxix = dopoptolabel(cPVOP->op_pv);
1989 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1991 if (cxix < cxstack_ix)
1996 switch (CxTYPE(cx)) {
1999 newsp = PL_stack_base + cx->blk_loop.resetsp;
2000 nextop = cx->blk_loop.last_op->op_next;
2004 nextop = pop_return();
2008 nextop = pop_return();
2012 nextop = pop_return();
2015 DIE(aTHX_ "panic: last");
2019 if (gimme == G_SCALAR) {
2021 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2022 ? *SP : sv_mortalcopy(*SP);
2024 *++newsp = &PL_sv_undef;
2026 else if (gimme == G_ARRAY) {
2027 while (++MARK <= SP) {
2028 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2029 ? *MARK : sv_mortalcopy(*MARK);
2030 TAINT_NOT; /* Each item is independent */
2036 /* Stack values are safe: */
2039 POPLOOP(cx); /* release loop vars ... */
2043 POPSUB(cx,sv); /* release CV and @_ ... */
2046 PL_curpm = newpm; /* ... and pop $1 et al */
2056 register PERL_CONTEXT *cx;
2059 if (PL_op->op_flags & OPf_SPECIAL) {
2060 cxix = dopoptoloop(cxstack_ix);
2062 DIE(aTHX_ "Can't \"next\" outside a loop block");
2065 cxix = dopoptolabel(cPVOP->op_pv);
2067 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2069 if (cxix < cxstack_ix)
2072 /* clear off anything above the scope we're re-entering, but
2073 * save the rest until after a possible continue block */
2074 inner = PL_scopestack_ix;
2076 if (PL_scopestack_ix < inner)
2077 leave_scope(PL_scopestack[PL_scopestack_ix]);
2078 return cx->blk_loop.next_op;
2084 register PERL_CONTEXT *cx;
2087 if (PL_op->op_flags & OPf_SPECIAL) {
2088 cxix = dopoptoloop(cxstack_ix);
2090 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2093 cxix = dopoptolabel(cPVOP->op_pv);
2095 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2097 if (cxix < cxstack_ix)
2101 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2102 LEAVE_SCOPE(oldsave);
2103 return cx->blk_loop.redo_op;
2107 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2111 static char too_deep[] = "Target of goto is too deeply nested";
2114 Perl_croak(aTHX_ too_deep);
2115 if (o->op_type == OP_LEAVE ||
2116 o->op_type == OP_SCOPE ||
2117 o->op_type == OP_LEAVELOOP ||
2118 o->op_type == OP_LEAVESUB ||
2119 o->op_type == OP_LEAVETRY)
2121 *ops++ = cUNOPo->op_first;
2123 Perl_croak(aTHX_ too_deep);
2126 if (o->op_flags & OPf_KIDS) {
2127 /* First try all the kids at this level, since that's likeliest. */
2128 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2129 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2130 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2133 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2134 if (kid == PL_lastgotoprobe)
2136 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2139 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2140 ops[-1]->op_type == OP_DBSTATE)
2145 if ((o = dofindlabel(kid, label, ops, oplimit)))
2164 register PERL_CONTEXT *cx;
2165 #define GOTO_DEPTH 64
2166 OP *enterops[GOTO_DEPTH];
2168 int do_dump = (PL_op->op_type == OP_DUMP);
2169 static char must_have_label[] = "goto must have label";
2172 if (PL_op->op_flags & OPf_STACKED) {
2176 /* This egregious kludge implements goto &subroutine */
2177 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2179 register PERL_CONTEXT *cx;
2180 CV* cv = (CV*)SvRV(sv);
2186 if (!CvROOT(cv) && !CvXSUB(cv)) {
2191 /* autoloaded stub? */
2192 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2194 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2195 GvNAMELEN(gv), FALSE);
2196 if (autogv && (cv = GvCV(autogv)))
2198 tmpstr = sv_newmortal();
2199 gv_efullname3(tmpstr, gv, Nullch);
2200 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2202 DIE(aTHX_ "Goto undefined subroutine");
2205 /* First do some returnish stuff. */
2206 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2208 cxix = dopoptosub(cxstack_ix);
2210 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2211 if (cxix < cxstack_ix)
2215 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2217 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2218 /* put @_ back onto stack */
2219 AV* av = cx->blk_sub.argarray;
2221 items = AvFILLp(av) + 1;
2223 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2224 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2225 PL_stack_sp += items;
2226 SvREFCNT_dec(GvAV(PL_defgv));
2227 GvAV(PL_defgv) = cx->blk_sub.savearray;
2228 /* abandon @_ if it got reified */
2230 (void)sv_2mortal((SV*)av); /* delay until return */
2232 av_extend(av, items-1);
2233 AvFLAGS(av) = AVf_REIFY;
2234 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2237 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2239 av = GvAV(PL_defgv);
2240 items = AvFILLp(av) + 1;
2242 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2243 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2244 PL_stack_sp += items;
2246 if (CxTYPE(cx) == CXt_SUB &&
2247 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2248 SvREFCNT_dec(cx->blk_sub.cv);
2249 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2250 LEAVE_SCOPE(oldsave);
2252 /* Now do some callish stuff. */
2254 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2256 #ifdef PERL_XSUB_OLDSTYLE
2257 if (CvOLDSTYLE(cv)) {
2258 I32 (*fp3)(int,int,int);
2263 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2264 items = (*fp3)(CvXSUBANY(cv).any_i32,
2265 mark - PL_stack_base + 1,
2267 SP = PL_stack_base + items;
2270 #endif /* PERL_XSUB_OLDSTYLE */
2275 PL_stack_sp--; /* There is no cv arg. */
2276 /* Push a mark for the start of arglist */
2278 (void)(*CvXSUB(cv))(aTHX_ cv);
2279 /* Pop the current context like a decent sub should */
2280 POPBLOCK(cx, PL_curpm);
2281 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2284 return pop_return();
2287 AV* padlist = CvPADLIST(cv);
2288 if (CxTYPE(cx) == CXt_EVAL) {
2289 PL_in_eval = cx->blk_eval.old_in_eval;
2290 PL_eval_root = cx->blk_eval.old_eval_root;
2291 cx->cx_type = CXt_SUB;
2292 cx->blk_sub.hasargs = 0;
2294 cx->blk_sub.cv = cv;
2295 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2298 if (CvDEPTH(cv) < 2)
2299 (void)SvREFCNT_inc(cv);
2301 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2302 sub_crush_depth(cv);
2303 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2305 PAD_SET_CUR(padlist, CvDEPTH(cv));
2306 if (cx->blk_sub.hasargs)
2308 AV* av = (AV*)PAD_SVl(0);
2311 cx->blk_sub.savearray = GvAV(PL_defgv);
2312 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2313 CX_CURPAD_SAVE(cx->blk_sub);
2314 cx->blk_sub.argarray = av;
2317 if (items >= AvMAX(av) + 1) {
2319 if (AvARRAY(av) != ary) {
2320 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2321 SvPVX(av) = (char*)ary;
2323 if (items >= AvMAX(av) + 1) {
2324 AvMAX(av) = items - 1;
2325 Renew(ary,items+1,SV*);
2327 SvPVX(av) = (char*)ary;
2330 Copy(mark,AvARRAY(av),items,SV*);
2331 AvFILLp(av) = items - 1;
2332 assert(!AvREAL(av));
2339 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2341 * We do not care about using sv to call CV;
2342 * it's for informational purposes only.
2344 SV *sv = GvSV(PL_DBsub);
2347 if (PERLDB_SUB_NN) {
2348 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2351 gv_efullname3(sv, CvGV(cv), Nullch);
2354 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2355 PUSHMARK( PL_stack_sp );
2356 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2360 RETURNOP(CvSTART(cv));
2364 label = SvPV(sv,n_a);
2365 if (!(do_dump || *label))
2366 DIE(aTHX_ must_have_label);
2369 else if (PL_op->op_flags & OPf_SPECIAL) {
2371 DIE(aTHX_ must_have_label);
2374 label = cPVOP->op_pv;
2376 if (label && *label) {
2378 bool leaving_eval = FALSE;
2379 bool in_block = FALSE;
2380 PERL_CONTEXT *last_eval_cx = 0;
2384 PL_lastgotoprobe = 0;
2386 for (ix = cxstack_ix; ix >= 0; ix--) {
2388 switch (CxTYPE(cx)) {
2390 leaving_eval = TRUE;
2391 if (CxREALEVAL(cx)) {
2392 gotoprobe = (last_eval_cx ?
2393 last_eval_cx->blk_eval.old_eval_root :
2398 /* else fall through */
2400 gotoprobe = cx->blk_oldcop->op_sibling;
2406 gotoprobe = cx->blk_oldcop->op_sibling;
2409 gotoprobe = PL_main_root;
2412 if (CvDEPTH(cx->blk_sub.cv)) {
2413 gotoprobe = CvROOT(cx->blk_sub.cv);
2419 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2422 DIE(aTHX_ "panic: goto");
2423 gotoprobe = PL_main_root;
2427 retop = dofindlabel(gotoprobe, label,
2428 enterops, enterops + GOTO_DEPTH);
2432 PL_lastgotoprobe = gotoprobe;
2435 DIE(aTHX_ "Can't find label %s", label);
2437 /* if we're leaving an eval, check before we pop any frames
2438 that we're not going to punt, otherwise the error
2441 if (leaving_eval && *enterops && enterops[1]) {
2443 for (i = 1; enterops[i]; i++)
2444 if (enterops[i]->op_type == OP_ENTERITER)
2445 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2448 /* pop unwanted frames */
2450 if (ix < cxstack_ix) {
2457 oldsave = PL_scopestack[PL_scopestack_ix];
2458 LEAVE_SCOPE(oldsave);
2461 /* push wanted frames */
2463 if (*enterops && enterops[1]) {
2465 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2466 for (; enterops[ix]; ix++) {
2467 PL_op = enterops[ix];
2468 /* Eventually we may want to stack the needed arguments
2469 * for each op. For now, we punt on the hard ones. */
2470 if (PL_op->op_type == OP_ENTERITER)
2471 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2472 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2480 if (!retop) retop = PL_main_start;
2482 PL_restartop = retop;
2483 PL_do_undump = TRUE;
2487 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2488 PL_do_undump = FALSE;
2504 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2506 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2509 PL_exit_flags |= PERL_EXIT_EXPECTED;
2511 PUSHs(&PL_sv_undef);
2519 NV value = SvNVx(GvSV(cCOP->cop_gv));
2520 register I32 match = I_32(value);
2523 if (((NV)match) > value)
2524 --match; /* was fractional--truncate other way */
2526 match -= cCOP->uop.scop.scop_offset;
2529 else if (match > cCOP->uop.scop.scop_max)
2530 match = cCOP->uop.scop.scop_max;
2531 PL_op = cCOP->uop.scop.scop_next[match];
2541 PL_op = PL_op->op_next; /* can't assume anything */
2544 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2545 match -= cCOP->uop.scop.scop_offset;
2548 else if (match > cCOP->uop.scop.scop_max)
2549 match = cCOP->uop.scop.scop_max;
2550 PL_op = cCOP->uop.scop.scop_next[match];
2559 S_save_lines(pTHX_ AV *array, SV *sv)
2561 register char *s = SvPVX(sv);
2562 register char *send = SvPVX(sv) + SvCUR(sv);
2564 register I32 line = 1;
2566 while (s && s < send) {
2567 SV *tmpstr = NEWSV(85,0);
2569 sv_upgrade(tmpstr, SVt_PVMG);
2570 t = strchr(s, '\n');
2576 sv_setpvn(tmpstr, s, t - s);
2577 av_store(array, line++, tmpstr);
2582 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2584 S_docatch_body(pTHX_ va_list args)
2586 return docatch_body();
2591 S_docatch_body(pTHX)
2598 S_docatch(pTHX_ OP *o)
2603 volatile PERL_SI *cursi = PL_curstackinfo;
2607 assert(CATCH_GET == TRUE);
2611 /* Normally, the leavetry at the end of this block of ops will
2612 * pop an op off the return stack and continue there. By setting
2613 * the op to Nullop, we force an exit from the inner runops()
2616 retop = pop_return();
2617 push_return(Nullop);
2619 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2621 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2627 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2633 /* die caught by an inner eval - continue inner loop */
2634 if (PL_restartop && cursi == PL_curstackinfo) {
2635 PL_op = PL_restartop;
2639 /* a die in this eval - continue in outer loop */
2655 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2656 /* sv Text to convert to OP tree. */
2657 /* startop op_free() this to undo. */
2658 /* code Short string id of the caller. */
2660 dSP; /* Make POPBLOCK work. */
2663 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2667 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2668 char *tmpbuf = tbuf;
2671 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2676 /* switch to eval mode */
2678 if (PL_curcop == &PL_compiling) {
2679 SAVECOPSTASH_FREE(&PL_compiling);
2680 CopSTASH_set(&PL_compiling, PL_curstash);
2682 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2683 SV *sv = sv_newmortal();
2684 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2685 code, (unsigned long)++PL_evalseq,
2686 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2690 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2691 SAVECOPFILE_FREE(&PL_compiling);
2692 CopFILE_set(&PL_compiling, tmpbuf+2);
2693 SAVECOPLINE(&PL_compiling);
2694 CopLINE_set(&PL_compiling, 1);
2695 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2696 deleting the eval's FILEGV from the stash before gv_check() runs
2697 (i.e. before run-time proper). To work around the coredump that
2698 ensues, we always turn GvMULTI_on for any globals that were
2699 introduced within evals. See force_ident(). GSAR 96-10-12 */
2700 safestr = savepv(tmpbuf);
2701 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2703 #ifdef OP_IN_REGISTER
2708 PL_hints &= HINT_UTF8;
2710 /* we get here either during compilation, or via pp_regcomp at runtime */
2711 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2713 runcv = find_runcv(NULL);
2716 PL_op->op_type = OP_ENTEREVAL;
2717 PL_op->op_flags = 0; /* Avoid uninit warning. */
2718 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2719 PUSHEVAL(cx, 0, Nullgv);
2722 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2724 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2725 POPBLOCK(cx,PL_curpm);
2728 (*startop)->op_type = OP_NULL;
2729 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2731 /* XXX DAPM do this properly one year */
2732 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2734 if (PL_curcop == &PL_compiling)
2735 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2736 #ifdef OP_IN_REGISTER
2744 =for apidoc find_runcv
2746 Locate the CV corresponding to the currently executing sub or eval.
2747 If db_seqp is non_null, skip CVs that are in the DB package and populate
2748 *db_seqp with the cop sequence number at the point that the DB:: code was
2749 entered. (allows debuggers to eval in the scope of the breakpoint rather
2750 than in in the scope of the debuger itself).
2756 Perl_find_runcv(pTHX_ U32 *db_seqp)
2763 *db_seqp = PL_curcop->cop_seq;
2764 for (si = PL_curstackinfo; si; si = si->si_prev) {
2765 for (ix = si->si_cxix; ix >= 0; ix--) {
2766 cx = &(si->si_cxstack[ix]);
2767 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2768 CV *cv = cx->blk_sub.cv;
2769 /* skip DB:: code */
2770 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2771 *db_seqp = cx->blk_oldcop->cop_seq;
2776 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2784 /* Compile a require/do, an eval '', or a /(?{...})/.
2785 * In the last case, startop is non-null, and contains the address of
2786 * a pointer that should be set to the just-compiled code.
2787 * outside is the lexically enclosing CV (if any) that invoked us.
2790 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2792 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2797 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2798 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2803 SAVESPTR(PL_compcv);
2804 PL_compcv = (CV*)NEWSV(1104,0);
2805 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2806 CvEVAL_on(PL_compcv);
2807 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2808 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2810 CvOUTSIDE_SEQ(PL_compcv) = seq;
2811 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2813 /* set up a scratch pad */
2815 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2818 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2820 /* make sure we compile in the right package */
2822 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2823 SAVESPTR(PL_curstash);
2824 PL_curstash = CopSTASH(PL_curcop);
2826 SAVESPTR(PL_beginav);
2827 PL_beginav = newAV();
2828 SAVEFREESV(PL_beginav);
2829 SAVEI32(PL_error_count);
2831 /* try to compile it */
2833 PL_eval_root = Nullop;
2835 PL_curcop = &PL_compiling;
2836 PL_curcop->cop_arybase = 0;
2837 if (saveop && saveop->op_flags & OPf_SPECIAL)
2838 PL_in_eval |= EVAL_KEEPERR;
2841 if (yyparse() || PL_error_count || !PL_eval_root) {
2845 I32 optype = 0; /* Might be reset by POPEVAL. */
2850 op_free(PL_eval_root);
2851 PL_eval_root = Nullop;
2853 SP = PL_stack_base + POPMARK; /* pop original mark */
2855 POPBLOCK(cx,PL_curpm);
2861 if (optype == OP_REQUIRE) {
2862 char* msg = SvPVx(ERRSV, n_a);
2863 DIE(aTHX_ "%sCompilation failed in require",
2864 *msg ? msg : "Unknown error\n");
2867 char* msg = SvPVx(ERRSV, n_a);
2869 POPBLOCK(cx,PL_curpm);
2871 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2872 (*msg ? msg : "Unknown error\n"));
2875 char* msg = SvPVx(ERRSV, n_a);
2877 sv_setpv(ERRSV, "Compilation error");
2882 CopLINE_set(&PL_compiling, 0);
2884 *startop = PL_eval_root;
2886 SAVEFREEOP(PL_eval_root);
2888 scalarvoid(PL_eval_root);
2889 else if (gimme & G_ARRAY)
2892 scalar(PL_eval_root);
2894 DEBUG_x(dump_eval());
2896 /* Register with debugger: */
2897 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2898 CV *cv = get_cv("DB::postponed", FALSE);
2902 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2904 call_sv((SV*)cv, G_DISCARD);
2908 /* compiled okay, so do it */
2910 CvDEPTH(PL_compcv) = 1;
2911 SP = PL_stack_base + POPMARK; /* pop original mark */
2912 PL_op = saveop; /* The caller may need it. */
2913 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2915 RETURNOP(PL_eval_start);
2919 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2921 STRLEN namelen = strlen(name);
2924 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2925 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2926 char *pmc = SvPV_nolen(pmcsv);
2929 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2930 fp = PerlIO_open(name, mode);
2933 if (PerlLIO_stat(name, &pmstat) < 0 ||
2934 pmstat.st_mtime < pmcstat.st_mtime)
2936 fp = PerlIO_open(pmc, mode);
2939 fp = PerlIO_open(name, mode);
2942 SvREFCNT_dec(pmcsv);
2945 fp = PerlIO_open(name, mode);
2953 register PERL_CONTEXT *cx;
2957 char *tryname = Nullch;
2958 SV *namesv = Nullsv;
2960 I32 gimme = GIMME_V;
2961 PerlIO *tryrsfp = 0;
2963 int filter_has_file = 0;
2964 GV *filter_child_proc = 0;
2965 SV *filter_state = 0;
2972 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2973 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2974 UV rev = 0, ver = 0, sver = 0;
2976 U8 *s = (U8*)SvPVX(sv);
2977 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2979 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2982 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2985 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2988 if (PERL_REVISION < rev
2989 || (PERL_REVISION == rev
2990 && (PERL_VERSION < ver
2991 || (PERL_VERSION == ver
2992 && PERL_SUBVERSION < sver))))
2994 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2995 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2996 PERL_VERSION, PERL_SUBVERSION);
2998 if (ckWARN(WARN_PORTABLE))
2999 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3000 "v-string in use/require non-portable");
3003 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3004 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3005 + ((NV)PERL_SUBVERSION/(NV)1000000)
3006 + 0.00000099 < SvNV(sv))
3010 NV nver = (nrev - rev) * 1000;
3011 UV ver = (UV)(nver + 0.0009);
3012 NV nsver = (nver - ver) * 1000;
3013 UV sver = (UV)(nsver + 0.0009);
3015 /* help out with the "use 5.6" confusion */
3016 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3017 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3018 " (did you mean v%"UVuf".%03"UVuf"?)--"
3019 "this is only v%d.%d.%d, stopped",
3020 rev, ver, sver, rev, ver/100,
3021 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3024 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3025 "this is only v%d.%d.%d, stopped",
3026 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3033 name = SvPV(sv, len);
3034 if (!(name && len > 0 && *name))
3035 DIE(aTHX_ "Null filename used");
3036 TAINT_PROPER("require");
3037 if (PL_op->op_type == OP_REQUIRE &&
3038 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3039 *svp != &PL_sv_undef)
3042 /* prepare to compile file */
3044 if (path_is_absolute(name)) {
3046 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3048 #ifdef MACOS_TRADITIONAL
3052 MacPerl_CanonDir(name, newname, 1);
3053 if (path_is_absolute(newname)) {
3055 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3060 AV *ar = GvAVn(PL_incgv);
3064 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3067 namesv = NEWSV(806, 0);
3068 for (i = 0; i <= AvFILL(ar); i++) {
3069 SV *dirsv = *av_fetch(ar, i, TRUE);
3075 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3076 && !sv_isobject(loader))
3078 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3081 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3082 PTR2UV(SvRV(dirsv)), name);
3083 tryname = SvPVX(namesv);
3094 if (sv_isobject(loader))
3095 count = call_method("INC", G_ARRAY);
3097 count = call_sv(loader, G_ARRAY);
3107 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3111 if (SvTYPE(arg) == SVt_PVGV) {
3112 IO *io = GvIO((GV *)arg);
3117 tryrsfp = IoIFP(io);
3118 if (IoTYPE(io) == IoTYPE_PIPE) {
3119 /* reading from a child process doesn't
3120 nest -- when returning from reading
3121 the inner module, the outer one is
3122 unreadable (closed?) I've tried to
3123 save the gv to manage the lifespan of
3124 the pipe, but this didn't help. XXX */
3125 filter_child_proc = (GV *)arg;
3126 (void)SvREFCNT_inc(filter_child_proc);
3129 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3130 PerlIO_close(IoOFP(io));
3142 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3144 (void)SvREFCNT_inc(filter_sub);
3147 filter_state = SP[i];
3148 (void)SvREFCNT_inc(filter_state);
3152 tryrsfp = PerlIO_open("/dev/null",
3167 filter_has_file = 0;
3168 if (filter_child_proc) {
3169 SvREFCNT_dec(filter_child_proc);
3170 filter_child_proc = 0;
3173 SvREFCNT_dec(filter_state);
3177 SvREFCNT_dec(filter_sub);
3182 if (!path_is_absolute(name)
3183 #ifdef MACOS_TRADITIONAL
3184 /* We consider paths of the form :a:b ambiguous and interpret them first
3185 as global then as local
3187 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3190 char *dir = SvPVx(dirsv, n_a);
3191 #ifdef MACOS_TRADITIONAL
3195 MacPerl_CanonDir(name, buf2, 1);
3196 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3200 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3202 sv_setpv(namesv, unixdir);
3203 sv_catpv(namesv, unixname);
3205 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3208 TAINT_PROPER("require");
3209 tryname = SvPVX(namesv);
3210 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3212 if (tryname[0] == '.' && tryname[1] == '/')
3221 SAVECOPFILE_FREE(&PL_compiling);
3222 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3223 SvREFCNT_dec(namesv);
3225 if (PL_op->op_type == OP_REQUIRE) {
3226 char *msgstr = name;
3227 if (namesv) { /* did we lookup @INC? */
3228 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3229 SV *dirmsgsv = NEWSV(0, 0);
3230 AV *ar = GvAVn(PL_incgv);
3232 sv_catpvn(msg, " in @INC", 8);
3233 if (instr(SvPVX(msg), ".h "))
3234 sv_catpv(msg, " (change .h to .ph maybe?)");
3235 if (instr(SvPVX(msg), ".ph "))
3236 sv_catpv(msg, " (did you run h2ph?)");
3237 sv_catpv(msg, " (@INC contains:");
3238 for (i = 0; i <= AvFILL(ar); i++) {
3239 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3240 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3241 sv_catsv(msg, dirmsgsv);
3243 sv_catpvn(msg, ")", 1);
3244 SvREFCNT_dec(dirmsgsv);
3245 msgstr = SvPV_nolen(msg);
3247 DIE(aTHX_ "Can't locate %s", msgstr);
3253 SETERRNO(0, SS_NORMAL);
3255 /* Assume success here to prevent recursive requirement. */
3257 /* Check whether a hook in @INC has already filled %INC */
3258 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3259 (void)hv_store(GvHVn(PL_incgv), name, len,
3260 (hook_sv ? SvREFCNT_inc(hook_sv)
3261 : newSVpv(CopFILE(&PL_compiling), 0)),
3267 lex_start(sv_2mortal(newSVpvn("",0)));
3268 SAVEGENERICSV(PL_rsfp_filters);
3269 PL_rsfp_filters = Nullav;
3274 SAVESPTR(PL_compiling.cop_warnings);
3275 if (PL_dowarn & G_WARN_ALL_ON)
3276 PL_compiling.cop_warnings = pWARN_ALL ;
3277 else if (PL_dowarn & G_WARN_ALL_OFF)
3278 PL_compiling.cop_warnings = pWARN_NONE ;
3279 else if (PL_taint_warn)
3280 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3282 PL_compiling.cop_warnings = pWARN_STD ;
3283 SAVESPTR(PL_compiling.cop_io);
3284 PL_compiling.cop_io = Nullsv;
3286 if (filter_sub || filter_child_proc) {
3287 SV *datasv = filter_add(run_user_filter, Nullsv);
3288 IoLINES(datasv) = filter_has_file;
3289 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3290 IoTOP_GV(datasv) = (GV *)filter_state;
3291 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3294 /* switch to eval mode */
3295 push_return(PL_op->op_next);
3296 PUSHBLOCK(cx, CXt_EVAL, SP);
3297 PUSHEVAL(cx, name, Nullgv);
3299 SAVECOPLINE(&PL_compiling);
3300 CopLINE_set(&PL_compiling, 0);
3304 /* Store and reset encoding. */
3305 encoding = PL_encoding;
3306 PL_encoding = Nullsv;
3308 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3310 /* Restore encoding. */
3311 PL_encoding = encoding;
3318 return pp_require();
3324 register PERL_CONTEXT *cx;
3326 I32 gimme = GIMME_V, was = PL_sub_generation;
3327 char tbuf[TYPE_DIGITS(long) + 12];
3328 char *tmpbuf = tbuf;
3337 TAINT_PROPER("eval");
3343 /* switch to eval mode */
3345 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3346 SV *sv = sv_newmortal();
3347 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3348 (unsigned long)++PL_evalseq,
3349 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3353 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3354 SAVECOPFILE_FREE(&PL_compiling);
3355 CopFILE_set(&PL_compiling, tmpbuf+2);
3356 SAVECOPLINE(&PL_compiling);
3357 CopLINE_set(&PL_compiling, 1);
3358 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3359 deleting the eval's FILEGV from the stash before gv_check() runs
3360 (i.e. before run-time proper). To work around the coredump that
3361 ensues, we always turn GvMULTI_on for any globals that were
3362 introduced within evals. See force_ident(). GSAR 96-10-12 */
3363 safestr = savepv(tmpbuf);
3364 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3366 PL_hints = PL_op->op_targ;
3367 SAVESPTR(PL_compiling.cop_warnings);
3368 if (specialWARN(PL_curcop->cop_warnings))
3369 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3371 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3372 SAVEFREESV(PL_compiling.cop_warnings);
3374 SAVESPTR(PL_compiling.cop_io);
3375 if (specialCopIO(PL_curcop->cop_io))
3376 PL_compiling.cop_io = PL_curcop->cop_io;
3378 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3379 SAVEFREESV(PL_compiling.cop_io);
3381 /* special case: an eval '' executed within the DB package gets lexically
3382 * placed in the first non-DB CV rather than the current CV - this
3383 * allows the debugger to execute code, find lexicals etc, in the
3384 * scope of the code being debugged. Passing &seq gets find_runcv
3385 * to do the dirty work for us */
3386 runcv = find_runcv(&seq);
3388 push_return(PL_op->op_next);
3389 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3390 PUSHEVAL(cx, 0, Nullgv);
3392 /* prepare to compile string */
3394 if (PERLDB_LINE && PL_curstash != PL_debstash)
3395 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3397 ret = doeval(gimme, NULL, runcv, seq);
3398 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3399 && ret != PL_op->op_next) { /* Successive compilation. */
3400 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3402 return DOCATCH(ret);
3412 register PERL_CONTEXT *cx;
3414 U8 save_flags = PL_op -> op_flags;
3419 retop = pop_return();
3422 if (gimme == G_VOID)
3424 else if (gimme == G_SCALAR) {
3427 if (SvFLAGS(TOPs) & SVs_TEMP)
3430 *MARK = sv_mortalcopy(TOPs);
3434 *MARK = &PL_sv_undef;
3439 /* in case LEAVE wipes old return values */
3440 for (mark = newsp + 1; mark <= SP; mark++) {
3441 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3442 *mark = sv_mortalcopy(*mark);
3443 TAINT_NOT; /* Each item is independent */
3447 PL_curpm = newpm; /* Don't pop $1 et al till now */
3450 assert(CvDEPTH(PL_compcv) == 1);
3452 CvDEPTH(PL_compcv) = 0;
3455 if (optype == OP_REQUIRE &&
3456 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3458 /* Unassume the success we assumed earlier. */
3459 SV *nsv = cx->blk_eval.old_namesv;
3460 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3461 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3462 /* die_where() did LEAVE, or we won't be here */
3466 if (!(save_flags & OPf_SPECIAL))
3476 register PERL_CONTEXT *cx;
3477 I32 gimme = GIMME_V;
3482 push_return(cLOGOP->op_other->op_next);
3483 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3486 PL_in_eval = EVAL_INEVAL;
3489 return DOCATCH(PL_op->op_next);
3500 register PERL_CONTEXT *cx;
3505 retop = pop_return();
3508 if (gimme == G_VOID)
3510 else if (gimme == G_SCALAR) {
3513 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3516 *MARK = sv_mortalcopy(TOPs);
3520 *MARK = &PL_sv_undef;
3525 /* in case LEAVE wipes old return values */
3526 for (mark = newsp + 1; mark <= SP; mark++) {
3527 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3528 *mark = sv_mortalcopy(*mark);
3529 TAINT_NOT; /* Each item is independent */
3533 PL_curpm = newpm; /* Don't pop $1 et al till now */
3541 S_doparseform(pTHX_ SV *sv)
3544 register char *s = SvPV_force(sv, len);
3545 register char *send = s + len;
3546 register char *base = Nullch;
3547 register I32 skipspaces = 0;
3548 bool noblank = FALSE;
3549 bool repeat = FALSE;
3550 bool postspace = FALSE;
3558 Perl_croak(aTHX_ "Null picture in formline");
3560 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3565 *fpc++ = FF_LINEMARK;
3566 noblank = repeat = FALSE;
3584 case ' ': case '\t':
3595 *fpc++ = FF_LITERAL;
3603 *fpc++ = (U16)skipspaces;
3607 *fpc++ = FF_NEWLINE;
3611 arg = fpc - linepc + 1;
3618 *fpc++ = FF_LINEMARK;
3619 noblank = repeat = FALSE;
3628 ischop = s[-1] == '^';
3634 arg = (s - base) - 1;
3636 *fpc++ = FF_LITERAL;
3645 *fpc++ = FF_LINEGLOB;
3647 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3648 arg = ischop ? 512 : 0;
3658 arg |= 256 + (s - f);
3660 *fpc++ = s - base; /* fieldsize for FETCH */
3661 *fpc++ = FF_DECIMAL;
3664 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3665 arg = ischop ? 512 : 0;
3667 s++; /* skip the '0' first */
3676 arg |= 256 + (s - f);
3678 *fpc++ = s - base; /* fieldsize for FETCH */
3679 *fpc++ = FF_0DECIMAL;
3684 bool ismore = FALSE;
3687 while (*++s == '>') ;
3688 prespace = FF_SPACE;
3690 else if (*s == '|') {
3691 while (*++s == '|') ;
3692 prespace = FF_HALFSPACE;
3697 while (*++s == '<') ;
3700 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3704 *fpc++ = s - base; /* fieldsize for FETCH */
3706 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3709 *fpc++ = (U16)prespace;
3724 { /* need to jump to the next word */
3726 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3727 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3728 s = SvPVX(sv) + SvCUR(sv) + z;
3730 Copy(fops, s, arg, U16);
3732 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3737 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3739 SV *datasv = FILTER_DATA(idx);
3740 int filter_has_file = IoLINES(datasv);
3741 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3742 SV *filter_state = (SV *)IoTOP_GV(datasv);
3743 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3746 /* I was having segfault trouble under Linux 2.2.5 after a
3747 parse error occured. (Had to hack around it with a test
3748 for PL_error_count == 0.) Solaris doesn't segfault --
3749 not sure where the trouble is yet. XXX */
3751 if (filter_has_file) {
3752 len = FILTER_READ(idx+1, buf_sv, maxlen);
3755 if (filter_sub && len >= 0) {
3766 PUSHs(sv_2mortal(newSViv(maxlen)));
3768 PUSHs(filter_state);
3771 count = call_sv(filter_sub, G_SCALAR);
3787 IoLINES(datasv) = 0;
3788 if (filter_child_proc) {
3789 SvREFCNT_dec(filter_child_proc);
3790 IoFMT_GV(datasv) = Nullgv;
3793 SvREFCNT_dec(filter_state);
3794 IoTOP_GV(datasv) = Nullgv;
3797 SvREFCNT_dec(filter_sub);
3798 IoBOTTOM_GV(datasv) = Nullgv;
3800 filter_del(run_user_filter);
3806 /* perhaps someone can come up with a better name for
3807 this? it is not really "absolute", per se ... */
3809 S_path_is_absolute(pTHX_ char *name)
3811 if (PERL_FILE_IS_ABSOLUTE(name)
3812 #ifdef MACOS_TRADITIONAL
3815 || (*name == '.' && (name[1] == '/' ||
3816 (name[1] == '.' && name[2] == '/'))))