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. */
2207 cxix = dopoptosub(cxstack_ix);
2209 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2210 if (cxix < cxstack_ix)
2214 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2216 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2217 /* put @_ back onto stack */
2218 AV* av = cx->blk_sub.argarray;
2220 items = AvFILLp(av) + 1;
2222 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2223 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2224 PL_stack_sp += items;
2225 SvREFCNT_dec(GvAV(PL_defgv));
2226 GvAV(PL_defgv) = cx->blk_sub.savearray;
2227 /* abandon @_ if it got reified */
2229 (void)sv_2mortal((SV*)av); /* delay until return */
2231 av_extend(av, items-1);
2232 AvFLAGS(av) = AVf_REIFY;
2233 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2236 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2238 av = GvAV(PL_defgv);
2239 items = AvFILLp(av) + 1;
2241 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2242 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2243 PL_stack_sp += items;
2245 if (CxTYPE(cx) == CXt_SUB &&
2246 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2247 SvREFCNT_dec(cx->blk_sub.cv);
2248 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2249 LEAVE_SCOPE(oldsave);
2251 /* Now do some callish stuff. */
2254 #ifdef PERL_XSUB_OLDSTYLE
2255 if (CvOLDSTYLE(cv)) {
2256 I32 (*fp3)(int,int,int);
2261 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2262 items = (*fp3)(CvXSUBANY(cv).any_i32,
2263 mark - PL_stack_base + 1,
2265 SP = PL_stack_base + items;
2268 #endif /* PERL_XSUB_OLDSTYLE */
2273 PL_stack_sp--; /* There is no cv arg. */
2274 /* Push a mark for the start of arglist */
2276 (void)(*CvXSUB(cv))(aTHX_ cv);
2277 /* Pop the current context like a decent sub should */
2278 POPBLOCK(cx, PL_curpm);
2279 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2282 return pop_return();
2285 AV* padlist = CvPADLIST(cv);
2286 if (CxTYPE(cx) == CXt_EVAL) {
2287 PL_in_eval = cx->blk_eval.old_in_eval;
2288 PL_eval_root = cx->blk_eval.old_eval_root;
2289 cx->cx_type = CXt_SUB;
2290 cx->blk_sub.hasargs = 0;
2292 cx->blk_sub.cv = cv;
2293 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2296 if (CvDEPTH(cv) < 2)
2297 (void)SvREFCNT_inc(cv);
2299 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2300 sub_crush_depth(cv);
2301 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2303 PAD_SET_CUR(padlist, CvDEPTH(cv));
2304 if (cx->blk_sub.hasargs)
2306 AV* av = (AV*)PAD_SVl(0);
2309 cx->blk_sub.savearray = GvAV(PL_defgv);
2310 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2311 CX_CURPAD_SAVE(cx->blk_sub);
2312 cx->blk_sub.argarray = av;
2315 if (items >= AvMAX(av) + 1) {
2317 if (AvARRAY(av) != ary) {
2318 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2319 SvPVX(av) = (char*)ary;
2321 if (items >= AvMAX(av) + 1) {
2322 AvMAX(av) = items - 1;
2323 Renew(ary,items+1,SV*);
2325 SvPVX(av) = (char*)ary;
2328 Copy(mark,AvARRAY(av),items,SV*);
2329 AvFILLp(av) = items - 1;
2330 assert(!AvREAL(av));
2337 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2339 * We do not care about using sv to call CV;
2340 * it's for informational purposes only.
2342 SV *sv = GvSV(PL_DBsub);
2345 if (PERLDB_SUB_NN) {
2346 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2349 gv_efullname3(sv, CvGV(cv), Nullch);
2352 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2353 PUSHMARK( PL_stack_sp );
2354 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2358 RETURNOP(CvSTART(cv));
2362 label = SvPV(sv,n_a);
2363 if (!(do_dump || *label))
2364 DIE(aTHX_ must_have_label);
2367 else if (PL_op->op_flags & OPf_SPECIAL) {
2369 DIE(aTHX_ must_have_label);
2372 label = cPVOP->op_pv;
2374 if (label && *label) {
2376 bool leaving_eval = FALSE;
2377 bool in_block = FALSE;
2378 PERL_CONTEXT *last_eval_cx = 0;
2382 PL_lastgotoprobe = 0;
2384 for (ix = cxstack_ix; ix >= 0; ix--) {
2386 switch (CxTYPE(cx)) {
2388 leaving_eval = TRUE;
2389 if (CxREALEVAL(cx)) {
2390 gotoprobe = (last_eval_cx ?
2391 last_eval_cx->blk_eval.old_eval_root :
2396 /* else fall through */
2398 gotoprobe = cx->blk_oldcop->op_sibling;
2404 gotoprobe = cx->blk_oldcop->op_sibling;
2407 gotoprobe = PL_main_root;
2410 if (CvDEPTH(cx->blk_sub.cv)) {
2411 gotoprobe = CvROOT(cx->blk_sub.cv);
2417 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2420 DIE(aTHX_ "panic: goto");
2421 gotoprobe = PL_main_root;
2425 retop = dofindlabel(gotoprobe, label,
2426 enterops, enterops + GOTO_DEPTH);
2430 PL_lastgotoprobe = gotoprobe;
2433 DIE(aTHX_ "Can't find label %s", label);
2435 /* if we're leaving an eval, check before we pop any frames
2436 that we're not going to punt, otherwise the error
2439 if (leaving_eval && *enterops && enterops[1]) {
2441 for (i = 1; enterops[i]; i++)
2442 if (enterops[i]->op_type == OP_ENTERITER)
2443 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2446 /* pop unwanted frames */
2448 if (ix < cxstack_ix) {
2455 oldsave = PL_scopestack[PL_scopestack_ix];
2456 LEAVE_SCOPE(oldsave);
2459 /* push wanted frames */
2461 if (*enterops && enterops[1]) {
2463 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2464 for (; enterops[ix]; ix++) {
2465 PL_op = enterops[ix];
2466 /* Eventually we may want to stack the needed arguments
2467 * for each op. For now, we punt on the hard ones. */
2468 if (PL_op->op_type == OP_ENTERITER)
2469 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2470 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2478 if (!retop) retop = PL_main_start;
2480 PL_restartop = retop;
2481 PL_do_undump = TRUE;
2485 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2486 PL_do_undump = FALSE;
2502 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2504 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2507 PL_exit_flags |= PERL_EXIT_EXPECTED;
2509 PUSHs(&PL_sv_undef);
2517 NV value = SvNVx(GvSV(cCOP->cop_gv));
2518 register I32 match = I_32(value);
2521 if (((NV)match) > value)
2522 --match; /* was fractional--truncate other way */
2524 match -= cCOP->uop.scop.scop_offset;
2527 else if (match > cCOP->uop.scop.scop_max)
2528 match = cCOP->uop.scop.scop_max;
2529 PL_op = cCOP->uop.scop.scop_next[match];
2539 PL_op = PL_op->op_next; /* can't assume anything */
2542 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2543 match -= cCOP->uop.scop.scop_offset;
2546 else if (match > cCOP->uop.scop.scop_max)
2547 match = cCOP->uop.scop.scop_max;
2548 PL_op = cCOP->uop.scop.scop_next[match];
2557 S_save_lines(pTHX_ AV *array, SV *sv)
2559 register char *s = SvPVX(sv);
2560 register char *send = SvPVX(sv) + SvCUR(sv);
2562 register I32 line = 1;
2564 while (s && s < send) {
2565 SV *tmpstr = NEWSV(85,0);
2567 sv_upgrade(tmpstr, SVt_PVMG);
2568 t = strchr(s, '\n');
2574 sv_setpvn(tmpstr, s, t - s);
2575 av_store(array, line++, tmpstr);
2580 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2582 S_docatch_body(pTHX_ va_list args)
2584 return docatch_body();
2589 S_docatch_body(pTHX)
2596 S_docatch(pTHX_ OP *o)
2601 volatile PERL_SI *cursi = PL_curstackinfo;
2605 assert(CATCH_GET == TRUE);
2609 /* Normally, the leavetry at the end of this block of ops will
2610 * pop an op off the return stack and continue there. By setting
2611 * the op to Nullop, we force an exit from the inner runops()
2614 retop = pop_return();
2615 push_return(Nullop);
2617 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2619 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2625 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2631 /* die caught by an inner eval - continue inner loop */
2632 if (PL_restartop && cursi == PL_curstackinfo) {
2633 PL_op = PL_restartop;
2637 /* a die in this eval - continue in outer loop */
2653 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2654 /* sv Text to convert to OP tree. */
2655 /* startop op_free() this to undo. */
2656 /* code Short string id of the caller. */
2658 dSP; /* Make POPBLOCK work. */
2661 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2665 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2666 char *tmpbuf = tbuf;
2669 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2674 /* switch to eval mode */
2676 if (PL_curcop == &PL_compiling) {
2677 SAVECOPSTASH_FREE(&PL_compiling);
2678 CopSTASH_set(&PL_compiling, PL_curstash);
2680 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2681 SV *sv = sv_newmortal();
2682 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2683 code, (unsigned long)++PL_evalseq,
2684 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2688 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2689 SAVECOPFILE_FREE(&PL_compiling);
2690 CopFILE_set(&PL_compiling, tmpbuf+2);
2691 SAVECOPLINE(&PL_compiling);
2692 CopLINE_set(&PL_compiling, 1);
2693 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2694 deleting the eval's FILEGV from the stash before gv_check() runs
2695 (i.e. before run-time proper). To work around the coredump that
2696 ensues, we always turn GvMULTI_on for any globals that were
2697 introduced within evals. See force_ident(). GSAR 96-10-12 */
2698 safestr = savepv(tmpbuf);
2699 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2701 #ifdef OP_IN_REGISTER
2706 PL_hints &= HINT_UTF8;
2708 /* we get here either during compilation, or via pp_regcomp at runtime */
2709 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2711 runcv = find_runcv(NULL);
2714 PL_op->op_type = OP_ENTEREVAL;
2715 PL_op->op_flags = 0; /* Avoid uninit warning. */
2716 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2717 PUSHEVAL(cx, 0, Nullgv);
2720 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2722 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2723 POPBLOCK(cx,PL_curpm);
2726 (*startop)->op_type = OP_NULL;
2727 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2729 /* XXX DAPM do this properly one year */
2730 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2732 if (PL_curcop == &PL_compiling)
2733 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2734 #ifdef OP_IN_REGISTER
2742 =for apidoc find_runcv
2744 Locate the CV corresponding to the currently executing sub or eval.
2745 If db_seqp is non_null, skip CVs that are in the DB package and populate
2746 *db_seqp with the cop sequence number at the point that the DB:: code was
2747 entered. (allows debuggers to eval in the scope of the breakpoint rather
2748 than in in the scope of the debuger itself).
2754 Perl_find_runcv(pTHX_ U32 *db_seqp)
2761 *db_seqp = PL_curcop->cop_seq;
2762 for (si = PL_curstackinfo; si; si = si->si_prev) {
2763 for (ix = si->si_cxix; ix >= 0; ix--) {
2764 cx = &(si->si_cxstack[ix]);
2765 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2766 CV *cv = cx->blk_sub.cv;
2767 /* skip DB:: code */
2768 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2769 *db_seqp = cx->blk_oldcop->cop_seq;
2774 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2782 /* Compile a require/do, an eval '', or a /(?{...})/.
2783 * In the last case, startop is non-null, and contains the address of
2784 * a pointer that should be set to the just-compiled code.
2785 * outside is the lexically enclosing CV (if any) that invoked us.
2788 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2790 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2795 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2796 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2801 SAVESPTR(PL_compcv);
2802 PL_compcv = (CV*)NEWSV(1104,0);
2803 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2804 CvEVAL_on(PL_compcv);
2805 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2806 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2808 CvOUTSIDE_SEQ(PL_compcv) = seq;
2809 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2811 /* set up a scratch pad */
2813 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2816 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2818 /* make sure we compile in the right package */
2820 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2821 SAVESPTR(PL_curstash);
2822 PL_curstash = CopSTASH(PL_curcop);
2824 SAVESPTR(PL_beginav);
2825 PL_beginav = newAV();
2826 SAVEFREESV(PL_beginav);
2827 SAVEI32(PL_error_count);
2829 /* try to compile it */
2831 PL_eval_root = Nullop;
2833 PL_curcop = &PL_compiling;
2834 PL_curcop->cop_arybase = 0;
2835 if (saveop && saveop->op_flags & OPf_SPECIAL)
2836 PL_in_eval |= EVAL_KEEPERR;
2839 if (yyparse() || PL_error_count || !PL_eval_root) {
2843 I32 optype = 0; /* Might be reset by POPEVAL. */
2848 op_free(PL_eval_root);
2849 PL_eval_root = Nullop;
2851 SP = PL_stack_base + POPMARK; /* pop original mark */
2853 POPBLOCK(cx,PL_curpm);
2859 if (optype == OP_REQUIRE) {
2860 char* msg = SvPVx(ERRSV, n_a);
2861 DIE(aTHX_ "%sCompilation failed in require",
2862 *msg ? msg : "Unknown error\n");
2865 char* msg = SvPVx(ERRSV, n_a);
2867 POPBLOCK(cx,PL_curpm);
2869 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2870 (*msg ? msg : "Unknown error\n"));
2873 char* msg = SvPVx(ERRSV, n_a);
2875 sv_setpv(ERRSV, "Compilation error");
2880 CopLINE_set(&PL_compiling, 0);
2882 *startop = PL_eval_root;
2884 SAVEFREEOP(PL_eval_root);
2886 scalarvoid(PL_eval_root);
2887 else if (gimme & G_ARRAY)
2890 scalar(PL_eval_root);
2892 DEBUG_x(dump_eval());
2894 /* Register with debugger: */
2895 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2896 CV *cv = get_cv("DB::postponed", FALSE);
2900 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2902 call_sv((SV*)cv, G_DISCARD);
2906 /* compiled okay, so do it */
2908 CvDEPTH(PL_compcv) = 1;
2909 SP = PL_stack_base + POPMARK; /* pop original mark */
2910 PL_op = saveop; /* The caller may need it. */
2911 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2913 RETURNOP(PL_eval_start);
2917 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2919 STRLEN namelen = strlen(name);
2922 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2923 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2924 char *pmc = SvPV_nolen(pmcsv);
2927 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2928 fp = PerlIO_open(name, mode);
2931 if (PerlLIO_stat(name, &pmstat) < 0 ||
2932 pmstat.st_mtime < pmcstat.st_mtime)
2934 fp = PerlIO_open(pmc, mode);
2937 fp = PerlIO_open(name, mode);
2940 SvREFCNT_dec(pmcsv);
2943 fp = PerlIO_open(name, mode);
2951 register PERL_CONTEXT *cx;
2955 char *tryname = Nullch;
2956 SV *namesv = Nullsv;
2958 I32 gimme = GIMME_V;
2959 PerlIO *tryrsfp = 0;
2961 int filter_has_file = 0;
2962 GV *filter_child_proc = 0;
2963 SV *filter_state = 0;
2970 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2971 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2972 UV rev = 0, ver = 0, sver = 0;
2974 U8 *s = (U8*)SvPVX(sv);
2975 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2977 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2980 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2983 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2986 if (PERL_REVISION < rev
2987 || (PERL_REVISION == rev
2988 && (PERL_VERSION < ver
2989 || (PERL_VERSION == ver
2990 && PERL_SUBVERSION < sver))))
2992 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2993 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2994 PERL_VERSION, PERL_SUBVERSION);
2996 if (ckWARN(WARN_PORTABLE))
2997 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2998 "v-string in use/require non-portable");
3001 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3002 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3003 + ((NV)PERL_SUBVERSION/(NV)1000000)
3004 + 0.00000099 < SvNV(sv))
3008 NV nver = (nrev - rev) * 1000;
3009 UV ver = (UV)(nver + 0.0009);
3010 NV nsver = (nver - ver) * 1000;
3011 UV sver = (UV)(nsver + 0.0009);
3013 /* help out with the "use 5.6" confusion */
3014 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3015 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3016 " (did you mean v%"UVuf".%03"UVuf"?)--"
3017 "this is only v%d.%d.%d, stopped",
3018 rev, ver, sver, rev, ver/100,
3019 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3022 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3023 "this is only v%d.%d.%d, stopped",
3024 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3031 name = SvPV(sv, len);
3032 if (!(name && len > 0 && *name))
3033 DIE(aTHX_ "Null filename used");
3034 TAINT_PROPER("require");
3035 if (PL_op->op_type == OP_REQUIRE &&
3036 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3037 *svp != &PL_sv_undef)
3040 /* prepare to compile file */
3042 if (path_is_absolute(name)) {
3044 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3046 #ifdef MACOS_TRADITIONAL
3050 MacPerl_CanonDir(name, newname, 1);
3051 if (path_is_absolute(newname)) {
3053 tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3058 AV *ar = GvAVn(PL_incgv);
3062 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3065 namesv = NEWSV(806, 0);
3066 for (i = 0; i <= AvFILL(ar); i++) {
3067 SV *dirsv = *av_fetch(ar, i, TRUE);
3073 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3074 && !sv_isobject(loader))
3076 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3079 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3080 PTR2UV(SvRV(dirsv)), name);
3081 tryname = SvPVX(namesv);
3092 if (sv_isobject(loader))
3093 count = call_method("INC", G_ARRAY);
3095 count = call_sv(loader, G_ARRAY);
3105 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3109 if (SvTYPE(arg) == SVt_PVGV) {
3110 IO *io = GvIO((GV *)arg);
3115 tryrsfp = IoIFP(io);
3116 if (IoTYPE(io) == IoTYPE_PIPE) {
3117 /* reading from a child process doesn't
3118 nest -- when returning from reading
3119 the inner module, the outer one is
3120 unreadable (closed?) I've tried to
3121 save the gv to manage the lifespan of
3122 the pipe, but this didn't help. XXX */
3123 filter_child_proc = (GV *)arg;
3124 (void)SvREFCNT_inc(filter_child_proc);
3127 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3128 PerlIO_close(IoOFP(io));
3140 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3142 (void)SvREFCNT_inc(filter_sub);
3145 filter_state = SP[i];
3146 (void)SvREFCNT_inc(filter_state);
3150 tryrsfp = PerlIO_open("/dev/null",
3165 filter_has_file = 0;
3166 if (filter_child_proc) {
3167 SvREFCNT_dec(filter_child_proc);
3168 filter_child_proc = 0;
3171 SvREFCNT_dec(filter_state);
3175 SvREFCNT_dec(filter_sub);
3180 if (!path_is_absolute(name)
3181 #ifdef MACOS_TRADITIONAL
3182 /* We consider paths of the form :a:b ambiguous and interpret them first
3183 as global then as local
3185 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3188 char *dir = SvPVx(dirsv, n_a);
3189 #ifdef MACOS_TRADITIONAL
3193 MacPerl_CanonDir(name, buf2, 1);
3194 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3198 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3200 sv_setpv(namesv, unixdir);
3201 sv_catpv(namesv, unixname);
3203 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3206 TAINT_PROPER("require");
3207 tryname = SvPVX(namesv);
3208 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3210 if (tryname[0] == '.' && tryname[1] == '/')
3219 SAVECOPFILE_FREE(&PL_compiling);
3220 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3221 SvREFCNT_dec(namesv);
3223 if (PL_op->op_type == OP_REQUIRE) {
3224 char *msgstr = name;
3225 if (namesv) { /* did we lookup @INC? */
3226 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3227 SV *dirmsgsv = NEWSV(0, 0);
3228 AV *ar = GvAVn(PL_incgv);
3230 sv_catpvn(msg, " in @INC", 8);
3231 if (instr(SvPVX(msg), ".h "))
3232 sv_catpv(msg, " (change .h to .ph maybe?)");
3233 if (instr(SvPVX(msg), ".ph "))
3234 sv_catpv(msg, " (did you run h2ph?)");
3235 sv_catpv(msg, " (@INC contains:");
3236 for (i = 0; i <= AvFILL(ar); i++) {
3237 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3238 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3239 sv_catsv(msg, dirmsgsv);
3241 sv_catpvn(msg, ")", 1);
3242 SvREFCNT_dec(dirmsgsv);
3243 msgstr = SvPV_nolen(msg);
3245 DIE(aTHX_ "Can't locate %s", msgstr);
3251 SETERRNO(0, SS_NORMAL);
3253 /* Assume success here to prevent recursive requirement. */
3255 /* Check whether a hook in @INC has already filled %INC */
3256 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3257 (void)hv_store(GvHVn(PL_incgv), name, len,
3258 (hook_sv ? SvREFCNT_inc(hook_sv)
3259 : newSVpv(CopFILE(&PL_compiling), 0)),
3265 lex_start(sv_2mortal(newSVpvn("",0)));
3266 SAVEGENERICSV(PL_rsfp_filters);
3267 PL_rsfp_filters = Nullav;
3272 SAVESPTR(PL_compiling.cop_warnings);
3273 if (PL_dowarn & G_WARN_ALL_ON)
3274 PL_compiling.cop_warnings = pWARN_ALL ;
3275 else if (PL_dowarn & G_WARN_ALL_OFF)
3276 PL_compiling.cop_warnings = pWARN_NONE ;
3277 else if (PL_taint_warn)
3278 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3280 PL_compiling.cop_warnings = pWARN_STD ;
3281 SAVESPTR(PL_compiling.cop_io);
3282 PL_compiling.cop_io = Nullsv;
3284 if (filter_sub || filter_child_proc) {
3285 SV *datasv = filter_add(run_user_filter, Nullsv);
3286 IoLINES(datasv) = filter_has_file;
3287 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3288 IoTOP_GV(datasv) = (GV *)filter_state;
3289 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3292 /* switch to eval mode */
3293 push_return(PL_op->op_next);
3294 PUSHBLOCK(cx, CXt_EVAL, SP);
3295 PUSHEVAL(cx, name, Nullgv);
3297 SAVECOPLINE(&PL_compiling);
3298 CopLINE_set(&PL_compiling, 0);
3302 /* Store and reset encoding. */
3303 encoding = PL_encoding;
3304 PL_encoding = Nullsv;
3306 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3308 /* Restore encoding. */
3309 PL_encoding = encoding;
3316 return pp_require();
3322 register PERL_CONTEXT *cx;
3324 I32 gimme = GIMME_V, was = PL_sub_generation;
3325 char tbuf[TYPE_DIGITS(long) + 12];
3326 char *tmpbuf = tbuf;
3335 TAINT_PROPER("eval");
3341 /* switch to eval mode */
3343 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3344 SV *sv = sv_newmortal();
3345 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3346 (unsigned long)++PL_evalseq,
3347 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3351 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3352 SAVECOPFILE_FREE(&PL_compiling);
3353 CopFILE_set(&PL_compiling, tmpbuf+2);
3354 SAVECOPLINE(&PL_compiling);
3355 CopLINE_set(&PL_compiling, 1);
3356 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3357 deleting the eval's FILEGV from the stash before gv_check() runs
3358 (i.e. before run-time proper). To work around the coredump that
3359 ensues, we always turn GvMULTI_on for any globals that were
3360 introduced within evals. See force_ident(). GSAR 96-10-12 */
3361 safestr = savepv(tmpbuf);
3362 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3364 PL_hints = PL_op->op_targ;
3365 SAVESPTR(PL_compiling.cop_warnings);
3366 if (specialWARN(PL_curcop->cop_warnings))
3367 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3369 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3370 SAVEFREESV(PL_compiling.cop_warnings);
3372 SAVESPTR(PL_compiling.cop_io);
3373 if (specialCopIO(PL_curcop->cop_io))
3374 PL_compiling.cop_io = PL_curcop->cop_io;
3376 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3377 SAVEFREESV(PL_compiling.cop_io);
3379 /* special case: an eval '' executed within the DB package gets lexically
3380 * placed in the first non-DB CV rather than the current CV - this
3381 * allows the debugger to execute code, find lexicals etc, in the
3382 * scope of the code being debugged. Passing &seq gets find_runcv
3383 * to do the dirty work for us */
3384 runcv = find_runcv(&seq);
3386 push_return(PL_op->op_next);
3387 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3388 PUSHEVAL(cx, 0, Nullgv);
3390 /* prepare to compile string */
3392 if (PERLDB_LINE && PL_curstash != PL_debstash)
3393 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3395 ret = doeval(gimme, NULL, runcv, seq);
3396 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3397 && ret != PL_op->op_next) { /* Successive compilation. */
3398 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3400 return DOCATCH(ret);
3410 register PERL_CONTEXT *cx;
3412 U8 save_flags = PL_op -> op_flags;
3417 retop = pop_return();
3420 if (gimme == G_VOID)
3422 else if (gimme == G_SCALAR) {
3425 if (SvFLAGS(TOPs) & SVs_TEMP)
3428 *MARK = sv_mortalcopy(TOPs);
3432 *MARK = &PL_sv_undef;
3437 /* in case LEAVE wipes old return values */
3438 for (mark = newsp + 1; mark <= SP; mark++) {
3439 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3440 *mark = sv_mortalcopy(*mark);
3441 TAINT_NOT; /* Each item is independent */
3445 PL_curpm = newpm; /* Don't pop $1 et al till now */
3448 assert(CvDEPTH(PL_compcv) == 1);
3450 CvDEPTH(PL_compcv) = 0;
3453 if (optype == OP_REQUIRE &&
3454 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3456 /* Unassume the success we assumed earlier. */
3457 SV *nsv = cx->blk_eval.old_namesv;
3458 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3459 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3460 /* die_where() did LEAVE, or we won't be here */
3464 if (!(save_flags & OPf_SPECIAL))
3474 register PERL_CONTEXT *cx;
3475 I32 gimme = GIMME_V;
3480 push_return(cLOGOP->op_other->op_next);
3481 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3484 PL_in_eval = EVAL_INEVAL;
3487 return DOCATCH(PL_op->op_next);
3498 register PERL_CONTEXT *cx;
3503 retop = pop_return();
3506 if (gimme == G_VOID)
3508 else if (gimme == G_SCALAR) {
3511 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3514 *MARK = sv_mortalcopy(TOPs);
3518 *MARK = &PL_sv_undef;
3523 /* in case LEAVE wipes old return values */
3524 for (mark = newsp + 1; mark <= SP; mark++) {
3525 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3526 *mark = sv_mortalcopy(*mark);
3527 TAINT_NOT; /* Each item is independent */
3531 PL_curpm = newpm; /* Don't pop $1 et al till now */
3539 S_doparseform(pTHX_ SV *sv)
3542 register char *s = SvPV_force(sv, len);
3543 register char *send = s + len;
3544 register char *base = Nullch;
3545 register I32 skipspaces = 0;
3546 bool noblank = FALSE;
3547 bool repeat = FALSE;
3548 bool postspace = FALSE;
3556 Perl_croak(aTHX_ "Null picture in formline");
3558 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3563 *fpc++ = FF_LINEMARK;
3564 noblank = repeat = FALSE;
3582 case ' ': case '\t':
3593 *fpc++ = FF_LITERAL;
3601 *fpc++ = (U16)skipspaces;
3605 *fpc++ = FF_NEWLINE;
3609 arg = fpc - linepc + 1;
3616 *fpc++ = FF_LINEMARK;
3617 noblank = repeat = FALSE;
3626 ischop = s[-1] == '^';
3632 arg = (s - base) - 1;
3634 *fpc++ = FF_LITERAL;
3643 *fpc++ = FF_LINEGLOB;
3645 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3646 arg = ischop ? 512 : 0;
3656 arg |= 256 + (s - f);
3658 *fpc++ = s - base; /* fieldsize for FETCH */
3659 *fpc++ = FF_DECIMAL;
3662 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3663 arg = ischop ? 512 : 0;
3665 s++; /* skip the '0' first */
3674 arg |= 256 + (s - f);
3676 *fpc++ = s - base; /* fieldsize for FETCH */
3677 *fpc++ = FF_0DECIMAL;
3682 bool ismore = FALSE;
3685 while (*++s == '>') ;
3686 prespace = FF_SPACE;
3688 else if (*s == '|') {
3689 while (*++s == '|') ;
3690 prespace = FF_HALFSPACE;
3695 while (*++s == '<') ;
3698 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3702 *fpc++ = s - base; /* fieldsize for FETCH */
3704 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3707 *fpc++ = (U16)prespace;
3722 { /* need to jump to the next word */
3724 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3725 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3726 s = SvPVX(sv) + SvCUR(sv) + z;
3728 Copy(fops, s, arg, U16);
3730 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3735 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3737 SV *datasv = FILTER_DATA(idx);
3738 int filter_has_file = IoLINES(datasv);
3739 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3740 SV *filter_state = (SV *)IoTOP_GV(datasv);
3741 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3744 /* I was having segfault trouble under Linux 2.2.5 after a
3745 parse error occured. (Had to hack around it with a test
3746 for PL_error_count == 0.) Solaris doesn't segfault --
3747 not sure where the trouble is yet. XXX */
3749 if (filter_has_file) {
3750 len = FILTER_READ(idx+1, buf_sv, maxlen);
3753 if (filter_sub && len >= 0) {
3764 PUSHs(sv_2mortal(newSViv(maxlen)));
3766 PUSHs(filter_state);
3769 count = call_sv(filter_sub, G_SCALAR);
3785 IoLINES(datasv) = 0;
3786 if (filter_child_proc) {
3787 SvREFCNT_dec(filter_child_proc);
3788 IoFMT_GV(datasv) = Nullgv;
3791 SvREFCNT_dec(filter_state);
3792 IoTOP_GV(datasv) = Nullgv;
3795 SvREFCNT_dec(filter_sub);
3796 IoBOTTOM_GV(datasv) = Nullgv;
3798 filter_del(run_user_filter);
3804 /* perhaps someone can come up with a better name for
3805 this? it is not really "absolute", per se ... */
3807 S_path_is_absolute(pTHX_ char *name)
3809 if (PERL_FILE_IS_ABSOLUTE(name)
3810 #ifdef MACOS_TRADITIONAL
3813 || (*name == '.' && (name[1] == '/' ||
3814 (name[1] == '.' && name[2] == '/'))))