3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
21 #define PERL_IN_PP_CTL_C
25 #define WORD_ALIGN sizeof(U32)
28 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
30 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
38 cxix = dopoptosub(cxstack_ix);
42 switch (cxstack[cxix].blk_gimme) {
59 /* XXXX Should store the old value to allow for tie/overload - and
60 restore in regcomp, where marked with XXXX. */
69 register PMOP *pm = (PMOP*)cLOGOP->op_other;
73 MAGIC *mg = Null(MAGIC*);
77 /* prevent recompiling under /o and ithreads. */
78 #if defined(USE_ITHREADS)
79 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
84 SV *sv = SvRV(tmpstr);
86 mg = mg_find(sv, PERL_MAGIC_qr);
89 regexp *re = (regexp *)mg->mg_obj;
90 ReREFCNT_dec(PM_GETRE(pm));
91 PM_SETRE(pm, ReREFCNT_inc(re));
94 t = SvPV(tmpstr, len);
96 /* Check against the last compiled regexp. */
97 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
98 PM_GETRE(pm)->prelen != (I32)len ||
99 memNE(PM_GETRE(pm)->precomp, t, len))
102 ReREFCNT_dec(PM_GETRE(pm));
103 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
105 if (PL_op->op_flags & OPf_SPECIAL)
106 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
108 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
110 pm->op_pmdynflags |= PMdf_DYN_UTF8;
112 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
113 if (pm->op_pmdynflags & PMdf_UTF8)
114 t = (char*)bytes_to_utf8((U8*)t, &len);
116 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
117 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
119 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
120 inside tie/overload accessors. */
124 #ifndef INCOMPLETE_TAINTS
127 pm->op_pmdynflags |= PMdf_TAINTED;
129 pm->op_pmdynflags &= ~PMdf_TAINTED;
133 if (!PM_GETRE(pm)->prelen && PL_curpm)
135 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
136 pm->op_pmflags |= PMf_WHITE;
138 pm->op_pmflags &= ~PMf_WHITE;
140 /* XXX runtime compiled output needs to move to the pad */
141 if (pm->op_pmflags & PMf_KEEP) {
142 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
143 #if !defined(USE_ITHREADS)
144 /* XXX can't change the optree at runtime either */
145 cLOGOP->op_first->op_next = PL_op->op_next;
154 register PMOP *pm = (PMOP*) cLOGOP->op_other;
155 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
156 register SV *dstr = cx->sb_dstr;
157 register char *s = cx->sb_s;
158 register char *m = cx->sb_m;
159 char *orig = cx->sb_orig;
160 register REGEXP *rx = cx->sb_rx;
162 REGEXP *old = PM_GETRE(pm);
169 rxres_restore(&cx->sb_rxres, rx);
170 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
172 if (cx->sb_iters++) {
173 I32 saviters = cx->sb_iters;
174 if (cx->sb_iters > cx->sb_maxiters)
175 DIE(aTHX_ "Substitution loop");
177 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
178 cx->sb_rxtainted |= 2;
179 sv_catsv(dstr, POPs);
182 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
183 s == m, cx->sb_targ, NULL,
184 ((cx->sb_rflags & REXEC_COPY_STR)
185 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
186 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
188 SV *targ = cx->sb_targ;
190 if (DO_UTF8(dstr) && !SvUTF8(targ))
191 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
193 sv_catpvn(dstr, s, cx->sb_strend - s);
194 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
196 #ifdef PERL_COPY_ON_WRITE
198 sv_force_normal_flags(targ, SV_COW_DROP_PV);
202 (void)SvOOK_off(targ);
204 Safefree(SvPVX(targ));
206 SvPVX(targ) = SvPVX(dstr);
207 SvCUR_set(targ, SvCUR(dstr));
208 SvLEN_set(targ, SvLEN(dstr));
214 TAINT_IF(cx->sb_rxtainted & 1);
215 PUSHs(sv_2mortal(newSViv(saviters - 1)));
217 (void)SvPOK_only_UTF8(targ);
218 TAINT_IF(cx->sb_rxtainted);
222 LEAVE_SCOPE(cx->sb_oldsave);
225 RETURNOP(pm->op_next);
227 cx->sb_iters = saviters;
229 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
232 cx->sb_orig = orig = rx->subbeg;
234 cx->sb_strend = s + (cx->sb_strend - m);
236 cx->sb_m = m = rx->startp[0] + orig;
238 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
239 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
241 sv_catpvn(dstr, s, m-s);
243 cx->sb_s = rx->endp[0] + orig;
244 { /* Update the pos() information. */
245 SV *sv = cx->sb_targ;
248 if (SvTYPE(sv) < SVt_PVMG)
249 (void)SvUPGRADE(sv, SVt_PVMG);
250 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
251 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
252 mg = mg_find(sv, PERL_MAGIC_regex_global);
261 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
262 rxres_save(&cx->sb_rxres, rx);
263 RETURNOP(pm->op_pmreplstart);
267 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
272 if (!p || p[1] < rx->nparens) {
273 #ifdef PERL_COPY_ON_WRITE
274 i = 7 + rx->nparens * 2;
276 i = 6 + rx->nparens * 2;
285 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
286 RX_MATCH_COPIED_off(rx);
288 #ifdef PERL_COPY_ON_WRITE
289 *p++ = PTR2UV(rx->saved_copy);
290 rx->saved_copy = Nullsv;
295 *p++ = PTR2UV(rx->subbeg);
296 *p++ = (UV)rx->sublen;
297 for (i = 0; i <= rx->nparens; ++i) {
298 *p++ = (UV)rx->startp[i];
299 *p++ = (UV)rx->endp[i];
304 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
309 RX_MATCH_COPY_FREE(rx);
310 RX_MATCH_COPIED_set(rx, *p);
313 #ifdef PERL_COPY_ON_WRITE
315 SvREFCNT_dec (rx->saved_copy);
316 rx->saved_copy = INT2PTR(SV*,*p);
322 rx->subbeg = INT2PTR(char*,*p++);
323 rx->sublen = (I32)(*p++);
324 for (i = 0; i <= rx->nparens; ++i) {
325 rx->startp[i] = (I32)(*p++);
326 rx->endp[i] = (I32)(*p++);
331 Perl_rxres_free(pTHX_ void **rsp)
336 Safefree(INT2PTR(char*,*p));
337 #ifdef PERL_COPY_ON_WRITE
339 SvREFCNT_dec (INT2PTR(SV*,p[1]));
349 dSP; dMARK; dORIGMARK;
350 register SV *tmpForm = *++MARK;
357 register SV *sv = Nullsv;
362 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
363 char *chophere = Nullch;
364 char *linemark = Nullch;
366 bool gotsome = FALSE;
368 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
369 bool item_is_utf8 = FALSE;
370 bool targ_is_utf8 = FALSE;
373 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
374 if (SvREADONLY(tmpForm)) {
375 SvREADONLY_off(tmpForm);
376 doparseform(tmpForm);
377 SvREADONLY_on(tmpForm);
380 doparseform(tmpForm);
382 SvPV_force(PL_formtarget, len);
383 if (DO_UTF8(PL_formtarget))
385 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
387 f = SvPV(tmpForm, len);
388 /* need to jump to the next word */
389 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
398 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
399 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
400 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
401 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
402 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
404 case FF_CHECKNL: name = "CHECKNL"; break;
405 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
406 case FF_SPACE: name = "SPACE"; break;
407 case FF_HALFSPACE: name = "HALFSPACE"; break;
408 case FF_ITEM: name = "ITEM"; break;
409 case FF_CHOP: name = "CHOP"; break;
410 case FF_LINEGLOB: name = "LINEGLOB"; break;
411 case FF_NEWLINE: name = "NEWLINE"; break;
412 case FF_MORE: name = "MORE"; break;
413 case FF_LINEMARK: name = "LINEMARK"; break;
414 case FF_END: name = "END"; break;
415 case FF_0DECIMAL: name = "0DECIMAL"; break;
418 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
420 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
431 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
432 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
434 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
435 t = SvEND(PL_formtarget);
438 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
439 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
441 sv_utf8_upgrade(PL_formtarget);
442 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
443 t = SvEND(PL_formtarget);
463 if (ckWARN(WARN_SYNTAX))
464 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
469 item = s = SvPV(sv, len);
472 itemsize = sv_len_utf8(sv);
473 if (itemsize != (I32)len) {
475 if (itemsize > fieldsize) {
476 itemsize = fieldsize;
477 itembytes = itemsize;
478 sv_pos_u2b(sv, &itembytes, 0);
482 send = chophere = s + itembytes;
492 sv_pos_b2u(sv, &itemsize);
496 item_is_utf8 = FALSE;
497 if (itemsize > fieldsize)
498 itemsize = fieldsize;
499 send = chophere = s + itemsize;
511 item = s = SvPV(sv, len);
514 itemsize = sv_len_utf8(sv);
515 if (itemsize != (I32)len) {
517 if (itemsize <= fieldsize) {
518 send = chophere = s + itemsize;
529 itemsize = fieldsize;
530 itembytes = itemsize;
531 sv_pos_u2b(sv, &itembytes, 0);
532 send = chophere = s + itembytes;
533 while (s < send || (s == send && isSPACE(*s))) {
543 if (strchr(PL_chopset, *s))
548 itemsize = chophere - item;
549 sv_pos_b2u(sv, &itemsize);
555 item_is_utf8 = FALSE;
556 if (itemsize <= fieldsize) {
557 send = chophere = s + itemsize;
568 itemsize = fieldsize;
569 send = chophere = s + itemsize;
570 while (s < send || (s == send && isSPACE(*s))) {
580 if (strchr(PL_chopset, *s))
585 itemsize = chophere - item;
590 arg = fieldsize - itemsize;
599 arg = fieldsize - itemsize;
613 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
615 sv_utf8_upgrade(PL_formtarget);
616 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
617 t = SvEND(PL_formtarget);
621 if (UTF8_IS_CONTINUED(*s)) {
622 STRLEN skip = UTF8SKIP(s);
639 if ( !((*t++ = *s++) & ~31) )
645 if (targ_is_utf8 && !item_is_utf8) {
646 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
648 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
649 for (; t < SvEND(PL_formtarget); t++) {
651 int ch = *t++ = *s++;
662 int ch = *t++ = *s++;
665 if ( !((*t++ = *s++) & ~31) )
674 while (*s && isSPACE(*s))
682 item = s = SvPV(sv, len);
684 if ((item_is_utf8 = DO_UTF8(sv)))
685 itemsize = sv_len_utf8(sv);
687 bool chopped = FALSE;
700 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
702 SvUTF8_on(PL_formtarget);
703 sv_catsv(PL_formtarget, sv);
705 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
706 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
707 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
714 /* If the field is marked with ^ and the value is undefined,
717 if ((arg & 512) && !SvOK(sv)) {
725 /* Formats aren't yet marked for locales, so assume "yes". */
727 STORE_NUMERIC_STANDARD_SET_LOCAL();
728 #if defined(USE_LONG_DOUBLE)
730 sprintf(t, "%#*.*" PERL_PRIfldbl,
731 (int) fieldsize, (int) arg & 255, value);
733 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
738 (int) fieldsize, (int) arg & 255, value);
741 (int) fieldsize, value);
744 RESTORE_NUMERIC_STANDARD();
750 /* If the field is marked with ^ and the value is undefined,
753 if ((arg & 512) && !SvOK(sv)) {
761 /* Formats aren't yet marked for locales, so assume "yes". */
763 STORE_NUMERIC_STANDARD_SET_LOCAL();
764 #if defined(USE_LONG_DOUBLE)
766 sprintf(t, "%#0*.*" PERL_PRIfldbl,
767 (int) fieldsize, (int) arg & 255, value);
768 /* is this legal? I don't have long doubles */
770 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
774 sprintf(t, "%#0*.*f",
775 (int) fieldsize, (int) arg & 255, value);
778 (int) fieldsize, value);
781 RESTORE_NUMERIC_STANDARD();
788 while (t-- > linemark && *t == ' ') ;
796 if (arg) { /* repeat until fields exhausted? */
798 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
799 lines += FmLINES(PL_formtarget);
802 if (strnEQ(linemark, linemark - arg, arg))
803 DIE(aTHX_ "Runaway format");
806 SvUTF8_on(PL_formtarget);
807 FmLINES(PL_formtarget) = lines;
809 RETURNOP(cLISTOP->op_first);
822 while (*s && isSPACE(*s) && s < send)
826 arg = fieldsize - itemsize;
833 if (strnEQ(s," ",3)) {
834 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
845 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
847 SvUTF8_on(PL_formtarget);
848 FmLINES(PL_formtarget) += lines;
860 if (PL_stack_base + *PL_markstack_ptr == SP) {
862 if (GIMME_V == G_SCALAR)
863 XPUSHs(sv_2mortal(newSViv(0)));
864 RETURNOP(PL_op->op_next->op_next);
866 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
867 pp_pushmark(); /* push dst */
868 pp_pushmark(); /* push src */
869 ENTER; /* enter outer scope */
872 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
874 ENTER; /* enter inner scope */
877 src = PL_stack_base[*PL_markstack_ptr];
882 if (PL_op->op_type == OP_MAPSTART)
883 pp_pushmark(); /* push top */
884 return ((LOGOP*)PL_op->op_next)->op_other;
889 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
896 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
902 /* first, move source pointer to the next item in the source list */
903 ++PL_markstack_ptr[-1];
905 /* if there are new items, push them into the destination list */
906 if (items && gimme != G_VOID) {
907 /* might need to make room back there first */
908 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
909 /* XXX this implementation is very pessimal because the stack
910 * is repeatedly extended for every set of items. Is possible
911 * to do this without any stack extension or copying at all
912 * by maintaining a separate list over which the map iterates
913 * (like foreach does). --gsar */
915 /* everything in the stack after the destination list moves
916 * towards the end the stack by the amount of room needed */
917 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
919 /* items to shift up (accounting for the moved source pointer) */
920 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
922 /* This optimization is by Ben Tilly and it does
923 * things differently from what Sarathy (gsar)
924 * is describing. The downside of this optimization is
925 * that leaves "holes" (uninitialized and hopefully unused areas)
926 * to the Perl stack, but on the other hand this
927 * shouldn't be a problem. If Sarathy's idea gets
928 * implemented, this optimization should become
929 * irrelevant. --jhi */
931 shift = count; /* Avoid shifting too often --Ben Tilly */
936 PL_markstack_ptr[-1] += shift;
937 *PL_markstack_ptr += shift;
941 /* copy the new items down to the destination list */
942 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
944 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
946 LEAVE; /* exit inner scope */
949 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
951 (void)POPMARK; /* pop top */
952 LEAVE; /* exit outer scope */
953 (void)POPMARK; /* pop src */
954 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
955 (void)POPMARK; /* pop dst */
956 SP = PL_stack_base + POPMARK; /* pop original mark */
957 if (gimme == G_SCALAR) {
961 else if (gimme == G_ARRAY)
968 ENTER; /* enter inner scope */
971 /* set $_ to the new source item */
972 src = PL_stack_base[PL_markstack_ptr[-1]];
976 RETURNOP(cLOGOP->op_other);
984 if (GIMME == G_ARRAY)
986 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
987 return cLOGOP->op_other;
996 if (GIMME == G_ARRAY) {
997 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1001 SV *targ = PAD_SV(PL_op->op_targ);
1004 if (PL_op->op_private & OPpFLIP_LINENUM) {
1005 if (GvIO(PL_last_in_gv)) {
1006 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1009 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1010 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1016 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1017 if (PL_op->op_flags & OPf_SPECIAL) {
1025 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1038 if (GIMME == G_ARRAY) {
1044 if (SvGMAGICAL(left))
1046 if (SvGMAGICAL(right))
1049 /* This code tries to decide if "$left .. $right" should use the
1050 magical string increment, or if the range is numeric (we make
1051 an exception for .."0" [#18165]). AMS 20021031. */
1053 if (SvNIOKp(left) || !SvPOKp(left) ||
1054 SvNIOKp(right) || !SvPOKp(right) ||
1055 (looks_like_number(left) && *SvPVX(left) != '0' &&
1056 looks_like_number(right)))
1058 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1059 DIE(aTHX_ "Range iterator outside integer range");
1070 sv = sv_2mortal(newSViv(i++));
1075 SV *final = sv_mortalcopy(right);
1077 char *tmps = SvPV(final, len);
1079 sv = sv_mortalcopy(left);
1081 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1083 if (strEQ(SvPVX(sv),tmps))
1085 sv = sv_2mortal(newSVsv(sv));
1092 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1096 if (PL_op->op_private & OPpFLIP_LINENUM) {
1097 if (GvIO(PL_last_in_gv)) {
1098 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1101 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1102 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1110 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1111 sv_catpv(targ, "E0");
1121 static char *context_name[] = {
1132 S_dopoptolabel(pTHX_ char *label)
1135 register PERL_CONTEXT *cx;
1137 for (i = cxstack_ix; i >= 0; i--) {
1139 switch (CxTYPE(cx)) {
1145 if (ckWARN(WARN_EXITING))
1146 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1147 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1148 if (CxTYPE(cx) == CXt_NULL)
1152 if (!cx->blk_loop.label ||
1153 strNE(label, cx->blk_loop.label) ) {
1154 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1155 (long)i, cx->blk_loop.label));
1158 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1166 Perl_dowantarray(pTHX)
1168 I32 gimme = block_gimme();
1169 return (gimme == G_VOID) ? G_SCALAR : gimme;
1173 Perl_block_gimme(pTHX)
1177 cxix = dopoptosub(cxstack_ix);
1181 switch (cxstack[cxix].blk_gimme) {
1189 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1196 Perl_is_lvalue_sub(pTHX)
1200 cxix = dopoptosub(cxstack_ix);
1201 assert(cxix >= 0); /* We should only be called from inside subs */
1203 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1204 return cxstack[cxix].blk_sub.lval;
1210 S_dopoptosub(pTHX_ I32 startingblock)
1212 return dopoptosub_at(cxstack, startingblock);
1216 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1219 register PERL_CONTEXT *cx;
1220 for (i = startingblock; i >= 0; i--) {
1222 switch (CxTYPE(cx)) {
1228 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1236 S_dopoptoeval(pTHX_ I32 startingblock)
1239 register PERL_CONTEXT *cx;
1240 for (i = startingblock; i >= 0; i--) {
1242 switch (CxTYPE(cx)) {
1246 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1254 S_dopoptoloop(pTHX_ I32 startingblock)
1257 register PERL_CONTEXT *cx;
1258 for (i = startingblock; i >= 0; i--) {
1260 switch (CxTYPE(cx)) {
1266 if (ckWARN(WARN_EXITING))
1267 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1268 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1269 if ((CxTYPE(cx)) == CXt_NULL)
1273 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1281 Perl_dounwind(pTHX_ I32 cxix)
1283 register PERL_CONTEXT *cx;
1286 while (cxstack_ix > cxix) {
1288 cx = &cxstack[cxstack_ix];
1289 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1290 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1291 /* Note: we don't need to restore the base context info till the end. */
1292 switch (CxTYPE(cx)) {
1295 continue; /* not break */
1317 Perl_qerror(pTHX_ SV *err)
1320 sv_catsv(ERRSV, err);
1322 sv_catsv(PL_errors, err);
1324 Perl_warn(aTHX_ "%"SVf, err);
1329 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1335 register PERL_CONTEXT *cx;
1340 if (PL_in_eval & EVAL_KEEPERR) {
1341 static char prefix[] = "\t(in cleanup) ";
1346 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1349 if (*e != *message || strNE(e,message))
1353 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1354 sv_catpvn(err, prefix, sizeof(prefix)-1);
1355 sv_catpvn(err, message, msglen);
1356 if (ckWARN(WARN_MISC)) {
1357 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1358 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1363 sv_setpvn(ERRSV, message, msglen);
1367 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1368 && PL_curstackinfo->si_prev)
1377 if (cxix < cxstack_ix)
1380 POPBLOCK(cx,PL_curpm);
1381 if (CxTYPE(cx) != CXt_EVAL) {
1383 message = SvPVx(ERRSV, msglen);
1384 PerlIO_write(Perl_error_log, "panic: die ", 11);
1385 PerlIO_write(Perl_error_log, message, msglen);
1390 if (gimme == G_SCALAR)
1391 *++newsp = &PL_sv_undef;
1392 PL_stack_sp = newsp;
1396 /* LEAVE could clobber PL_curcop (see save_re_context())
1397 * XXX it might be better to find a way to avoid messing with
1398 * PL_curcop in save_re_context() instead, but this is a more
1399 * minimal fix --GSAR */
1400 PL_curcop = cx->blk_oldcop;
1402 if (optype == OP_REQUIRE) {
1403 char* msg = SvPVx(ERRSV, n_a);
1404 SV *nsv = cx->blk_eval.old_namesv;
1405 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1407 DIE(aTHX_ "%sCompilation failed in require",
1408 *msg ? msg : "Unknown error\n");
1410 return pop_return();
1414 message = SvPVx(ERRSV, msglen);
1416 write_to_stderr(message, msglen);
1425 if (SvTRUE(left) != SvTRUE(right))
1437 RETURNOP(cLOGOP->op_other);
1446 RETURNOP(cLOGOP->op_other);
1455 if (!sv || !SvANY(sv)) {
1456 RETURNOP(cLOGOP->op_other);
1459 switch (SvTYPE(sv)) {
1461 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1465 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1469 if (CvROOT(sv) || CvXSUB(sv))
1479 RETURNOP(cLOGOP->op_other);
1485 register I32 cxix = dopoptosub(cxstack_ix);
1486 register PERL_CONTEXT *cx;
1487 register PERL_CONTEXT *ccstack = cxstack;
1488 PERL_SI *top_si = PL_curstackinfo;
1499 /* we may be in a higher stacklevel, so dig down deeper */
1500 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1501 top_si = top_si->si_prev;
1502 ccstack = top_si->si_cxstack;
1503 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1506 if (GIMME != G_ARRAY) {
1512 if (PL_DBsub && cxix >= 0 &&
1513 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1517 cxix = dopoptosub_at(ccstack, cxix - 1);
1520 cx = &ccstack[cxix];
1521 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1522 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1523 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1524 field below is defined for any cx. */
1525 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1526 cx = &ccstack[dbcxix];
1529 stashname = CopSTASHPV(cx->blk_oldcop);
1530 if (GIMME != G_ARRAY) {
1533 PUSHs(&PL_sv_undef);
1536 sv_setpv(TARG, stashname);
1545 PUSHs(&PL_sv_undef);
1547 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1548 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1549 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1552 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1553 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1554 /* So is ccstack[dbcxix]. */
1557 gv_efullname3(sv, cvgv, Nullch);
1558 PUSHs(sv_2mortal(sv));
1559 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1562 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1563 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1567 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1568 PUSHs(sv_2mortal(newSViv(0)));
1570 gimme = (I32)cx->blk_gimme;
1571 if (gimme == G_VOID)
1572 PUSHs(&PL_sv_undef);
1574 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1575 if (CxTYPE(cx) == CXt_EVAL) {
1577 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1578 PUSHs(cx->blk_eval.cur_text);
1582 else if (cx->blk_eval.old_namesv) {
1583 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1586 /* eval BLOCK (try blocks have old_namesv == 0) */
1588 PUSHs(&PL_sv_undef);
1589 PUSHs(&PL_sv_undef);
1593 PUSHs(&PL_sv_undef);
1594 PUSHs(&PL_sv_undef);
1596 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1597 && CopSTASH_eq(PL_curcop, PL_debstash))
1599 AV *ary = cx->blk_sub.argarray;
1600 int off = AvARRAY(ary) - AvALLOC(ary);
1604 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1607 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1610 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1611 av_extend(PL_dbargs, AvFILLp(ary) + off);
1612 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1613 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1615 /* XXX only hints propagated via op_private are currently
1616 * visible (others are not easily accessible, since they
1617 * use the global PL_hints) */
1618 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1619 HINT_PRIVATE_MASK)));
1622 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1624 if (old_warnings == pWARN_NONE ||
1625 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1626 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1627 else if (old_warnings == pWARN_ALL ||
1628 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1629 /* Get the bit mask for $warnings::Bits{all}, because
1630 * it could have been extended by warnings::register */
1632 HV *bits = get_hv("warnings::Bits", FALSE);
1633 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1634 mask = newSVsv(*bits_all);
1637 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1641 mask = newSVsv(old_warnings);
1642 PUSHs(sv_2mortal(mask));
1657 sv_reset(tmps, CopSTASH(PL_curcop));
1667 /* like pp_nextstate, but used instead when the debugger is active */
1671 PL_curcop = (COP*)PL_op;
1672 TAINT_NOT; /* Each statement is presumed innocent */
1673 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1676 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1677 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1681 register PERL_CONTEXT *cx;
1682 I32 gimme = G_ARRAY;
1689 DIE(aTHX_ "No DB::DB routine defined");
1691 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1692 /* don't do recursive DB::DB call */
1704 push_return(PL_op->op_next);
1705 PUSHBLOCK(cx, CXt_SUB, SP);
1708 (void)SvREFCNT_inc(cv);
1709 PAD_SET_CUR(CvPADLIST(cv),1);
1710 RETURNOP(CvSTART(cv));
1724 register PERL_CONTEXT *cx;
1725 I32 gimme = GIMME_V;
1727 U32 cxtype = CXt_LOOP;
1735 if (PL_op->op_targ) {
1736 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1737 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1738 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1739 SVs_PADSTALE, SVs_PADSTALE);
1741 #ifndef USE_ITHREADS
1742 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1745 SAVEPADSV(PL_op->op_targ);
1746 iterdata = INT2PTR(void*, PL_op->op_targ);
1747 cxtype |= CXp_PADVAR;
1752 svp = &GvSV(gv); /* symbol table variable */
1753 SAVEGENERICSV(*svp);
1756 iterdata = (void*)gv;
1762 PUSHBLOCK(cx, cxtype, SP);
1764 PUSHLOOP(cx, iterdata, MARK);
1766 PUSHLOOP(cx, svp, MARK);
1768 if (PL_op->op_flags & OPf_STACKED) {
1769 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1770 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1772 /* See comment in pp_flop() */
1773 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1774 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1775 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1776 looks_like_number((SV*)cx->blk_loop.iterary)))
1778 if (SvNV(sv) < IV_MIN ||
1779 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1780 DIE(aTHX_ "Range iterator outside integer range");
1781 cx->blk_loop.iterix = SvIV(sv);
1782 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1785 cx->blk_loop.iterlval = newSVsv(sv);
1789 cx->blk_loop.iterary = PL_curstack;
1790 AvFILLp(PL_curstack) = SP - PL_stack_base;
1791 cx->blk_loop.iterix = MARK - PL_stack_base;
1800 register PERL_CONTEXT *cx;
1801 I32 gimme = GIMME_V;
1807 PUSHBLOCK(cx, CXt_LOOP, SP);
1808 PUSHLOOP(cx, 0, SP);
1816 register PERL_CONTEXT *cx;
1824 newsp = PL_stack_base + cx->blk_loop.resetsp;
1827 if (gimme == G_VOID)
1829 else if (gimme == G_SCALAR) {
1831 *++newsp = sv_mortalcopy(*SP);
1833 *++newsp = &PL_sv_undef;
1837 *++newsp = sv_mortalcopy(*++mark);
1838 TAINT_NOT; /* Each item is independent */
1844 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1845 PL_curpm = newpm; /* ... and pop $1 et al */
1857 register PERL_CONTEXT *cx;
1858 bool popsub2 = FALSE;
1859 bool clear_errsv = FALSE;
1866 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1867 if (cxstack_ix == PL_sortcxix
1868 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1870 if (cxstack_ix > PL_sortcxix)
1871 dounwind(PL_sortcxix);
1872 AvARRAY(PL_curstack)[1] = *SP;
1873 PL_stack_sp = PL_stack_base + 1;
1878 cxix = dopoptosub(cxstack_ix);
1880 DIE(aTHX_ "Can't return outside a subroutine");
1881 if (cxix < cxstack_ix)
1885 switch (CxTYPE(cx)) {
1888 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1891 if (!(PL_in_eval & EVAL_KEEPERR))
1897 if (optype == OP_REQUIRE &&
1898 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1900 /* Unassume the success we assumed earlier. */
1901 SV *nsv = cx->blk_eval.old_namesv;
1902 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1903 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1910 DIE(aTHX_ "panic: return");
1914 if (gimme == G_SCALAR) {
1917 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1919 *++newsp = SvREFCNT_inc(*SP);
1924 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1926 *++newsp = sv_mortalcopy(sv);
1931 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1934 *++newsp = sv_mortalcopy(*SP);
1937 *++newsp = &PL_sv_undef;
1939 else if (gimme == G_ARRAY) {
1940 while (++MARK <= SP) {
1941 *++newsp = (popsub2 && SvTEMP(*MARK))
1942 ? *MARK : sv_mortalcopy(*MARK);
1943 TAINT_NOT; /* Each item is independent */
1946 PL_stack_sp = newsp;
1949 /* Stack values are safe: */
1952 POPSUB(cx,sv); /* release CV and @_ ... */
1956 PL_curpm = newpm; /* ... and pop $1 et al */
1961 return pop_return();
1968 register PERL_CONTEXT *cx;
1978 if (PL_op->op_flags & OPf_SPECIAL) {
1979 cxix = dopoptoloop(cxstack_ix);
1981 DIE(aTHX_ "Can't \"last\" outside a loop block");
1984 cxix = dopoptolabel(cPVOP->op_pv);
1986 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1988 if (cxix < cxstack_ix)
1992 cxstack_ix++; /* temporarily protect top context */
1994 switch (CxTYPE(cx)) {
1997 newsp = PL_stack_base + cx->blk_loop.resetsp;
1998 nextop = cx->blk_loop.last_op->op_next;
2002 nextop = pop_return();
2006 nextop = pop_return();
2010 nextop = pop_return();
2013 DIE(aTHX_ "panic: last");
2017 if (gimme == G_SCALAR) {
2019 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2020 ? *SP : sv_mortalcopy(*SP);
2022 *++newsp = &PL_sv_undef;
2024 else if (gimme == G_ARRAY) {
2025 while (++MARK <= SP) {
2026 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2027 ? *MARK : sv_mortalcopy(*MARK);
2028 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 */
2055 register PERL_CONTEXT *cx;
2058 if (PL_op->op_flags & OPf_SPECIAL) {
2059 cxix = dopoptoloop(cxstack_ix);
2061 DIE(aTHX_ "Can't \"next\" outside a loop block");
2064 cxix = dopoptolabel(cPVOP->op_pv);
2066 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2068 if (cxix < cxstack_ix)
2071 /* clear off anything above the scope we're re-entering, but
2072 * save the rest until after a possible continue block */
2073 inner = PL_scopestack_ix;
2075 if (PL_scopestack_ix < inner)
2076 leave_scope(PL_scopestack[PL_scopestack_ix]);
2077 return cx->blk_loop.next_op;
2083 register PERL_CONTEXT *cx;
2086 if (PL_op->op_flags & OPf_SPECIAL) {
2087 cxix = dopoptoloop(cxstack_ix);
2089 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2092 cxix = dopoptolabel(cPVOP->op_pv);
2094 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2096 if (cxix < cxstack_ix)
2100 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2101 LEAVE_SCOPE(oldsave);
2102 return cx->blk_loop.redo_op;
2106 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2110 static char too_deep[] = "Target of goto is too deeply nested";
2113 Perl_croak(aTHX_ too_deep);
2114 if (o->op_type == OP_LEAVE ||
2115 o->op_type == OP_SCOPE ||
2116 o->op_type == OP_LEAVELOOP ||
2117 o->op_type == OP_LEAVESUB ||
2118 o->op_type == OP_LEAVETRY)
2120 *ops++ = cUNOPo->op_first;
2122 Perl_croak(aTHX_ too_deep);
2125 if (o->op_flags & OPf_KIDS) {
2126 /* First try all the kids at this level, since that's likeliest. */
2127 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2128 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2129 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2132 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2133 if (kid == PL_lastgotoprobe)
2135 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2138 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2139 ops[-1]->op_type == OP_DBSTATE)
2144 if ((o = dofindlabel(kid, label, ops, oplimit)))
2163 register PERL_CONTEXT *cx;
2164 #define GOTO_DEPTH 64
2165 OP *enterops[GOTO_DEPTH];
2167 int do_dump = (PL_op->op_type == OP_DUMP);
2168 static char must_have_label[] = "goto must have label";
2171 if (PL_op->op_flags & OPf_STACKED) {
2175 /* This egregious kludge implements goto &subroutine */
2176 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2178 register PERL_CONTEXT *cx;
2179 CV* cv = (CV*)SvRV(sv);
2185 if (!CvROOT(cv) && !CvXSUB(cv)) {
2190 /* autoloaded stub? */
2191 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2193 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2194 GvNAMELEN(gv), FALSE);
2195 if (autogv && (cv = GvCV(autogv)))
2197 tmpstr = sv_newmortal();
2198 gv_efullname3(tmpstr, gv, Nullch);
2199 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2201 DIE(aTHX_ "Goto undefined subroutine");
2204 /* First do some returnish stuff. */
2205 SvREFCNT_inc(cv); /* avoid premature free during unwind */
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);
2238 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2240 av = GvAV(PL_defgv);
2241 items = AvFILLp(av) + 1;
2243 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2244 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2245 PL_stack_sp += items;
2247 if (CxTYPE(cx) == CXt_SUB &&
2248 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2249 SvREFCNT_dec(cx->blk_sub.cv);
2250 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2251 LEAVE_SCOPE(oldsave);
2253 /* Now do some callish stuff. */
2255 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2257 #ifdef PERL_XSUB_OLDSTYLE
2258 if (CvOLDSTYLE(cv)) {
2259 I32 (*fp3)(int,int,int);
2264 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2265 items = (*fp3)(CvXSUBANY(cv).any_i32,
2266 mark - PL_stack_base + 1,
2268 SP = PL_stack_base + items;
2271 #endif /* PERL_XSUB_OLDSTYLE */
2276 PL_stack_sp--; /* There is no cv arg. */
2277 /* Push a mark for the start of arglist */
2279 (void)(*CvXSUB(cv))(aTHX_ cv);
2280 /* Pop the current context like a decent sub should */
2281 POPBLOCK(cx, PL_curpm);
2282 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2285 return pop_return();
2288 AV* padlist = CvPADLIST(cv);
2289 if (CxTYPE(cx) == CXt_EVAL) {
2290 PL_in_eval = cx->blk_eval.old_in_eval;
2291 PL_eval_root = cx->blk_eval.old_eval_root;
2292 cx->cx_type = CXt_SUB;
2293 cx->blk_sub.hasargs = 0;
2295 cx->blk_sub.cv = cv;
2296 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2299 if (CvDEPTH(cv) < 2)
2300 (void)SvREFCNT_inc(cv);
2302 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2303 sub_crush_depth(cv);
2304 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2306 PAD_SET_CUR(padlist, CvDEPTH(cv));
2307 if (cx->blk_sub.hasargs)
2309 AV* av = (AV*)PAD_SVl(0);
2312 cx->blk_sub.savearray = GvAV(PL_defgv);
2313 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2314 CX_CURPAD_SAVE(cx->blk_sub);
2315 cx->blk_sub.argarray = av;
2318 if (items >= AvMAX(av) + 1) {
2320 if (AvARRAY(av) != ary) {
2321 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2322 SvPVX(av) = (char*)ary;
2324 if (items >= AvMAX(av) + 1) {
2325 AvMAX(av) = items - 1;
2326 Renew(ary,items+1,SV*);
2328 SvPVX(av) = (char*)ary;
2331 Copy(mark,AvARRAY(av),items,SV*);
2332 AvFILLp(av) = items - 1;
2333 assert(!AvREAL(av));
2340 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2342 * We do not care about using sv to call CV;
2343 * it's for informational purposes only.
2345 SV *sv = GvSV(PL_DBsub);
2348 if (PERLDB_SUB_NN) {
2349 (void)SvUPGRADE(sv, SVt_PVIV);
2352 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2355 gv_efullname3(sv, CvGV(cv), Nullch);
2358 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2359 PUSHMARK( PL_stack_sp );
2360 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2364 RETURNOP(CvSTART(cv));
2368 label = SvPV(sv,n_a);
2369 if (!(do_dump || *label))
2370 DIE(aTHX_ must_have_label);
2373 else if (PL_op->op_flags & OPf_SPECIAL) {
2375 DIE(aTHX_ must_have_label);
2378 label = cPVOP->op_pv;
2380 if (label && *label) {
2382 bool leaving_eval = FALSE;
2383 bool in_block = FALSE;
2384 PERL_CONTEXT *last_eval_cx = 0;
2388 PL_lastgotoprobe = 0;
2390 for (ix = cxstack_ix; ix >= 0; ix--) {
2392 switch (CxTYPE(cx)) {
2394 leaving_eval = TRUE;
2395 if (!CxTRYBLOCK(cx)) {
2396 gotoprobe = (last_eval_cx ?
2397 last_eval_cx->blk_eval.old_eval_root :
2402 /* else fall through */
2404 gotoprobe = cx->blk_oldcop->op_sibling;
2410 gotoprobe = cx->blk_oldcop->op_sibling;
2413 gotoprobe = PL_main_root;
2416 if (CvDEPTH(cx->blk_sub.cv)) {
2417 gotoprobe = CvROOT(cx->blk_sub.cv);
2423 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2426 DIE(aTHX_ "panic: goto");
2427 gotoprobe = PL_main_root;
2431 retop = dofindlabel(gotoprobe, label,
2432 enterops, enterops + GOTO_DEPTH);
2436 PL_lastgotoprobe = gotoprobe;
2439 DIE(aTHX_ "Can't find label %s", label);
2441 /* if we're leaving an eval, check before we pop any frames
2442 that we're not going to punt, otherwise the error
2445 if (leaving_eval && *enterops && enterops[1]) {
2447 for (i = 1; enterops[i]; i++)
2448 if (enterops[i]->op_type == OP_ENTERITER)
2449 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2452 /* pop unwanted frames */
2454 if (ix < cxstack_ix) {
2461 oldsave = PL_scopestack[PL_scopestack_ix];
2462 LEAVE_SCOPE(oldsave);
2465 /* push wanted frames */
2467 if (*enterops && enterops[1]) {
2469 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2470 for (; enterops[ix]; ix++) {
2471 PL_op = enterops[ix];
2472 /* Eventually we may want to stack the needed arguments
2473 * for each op. For now, we punt on the hard ones. */
2474 if (PL_op->op_type == OP_ENTERITER)
2475 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2476 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2484 if (!retop) retop = PL_main_start;
2486 PL_restartop = retop;
2487 PL_do_undump = TRUE;
2491 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2492 PL_do_undump = FALSE;
2508 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2510 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2513 PL_exit_flags |= PERL_EXIT_EXPECTED;
2515 PUSHs(&PL_sv_undef);
2523 NV value = SvNVx(GvSV(cCOP->cop_gv));
2524 register I32 match = I_32(value);
2527 if (((NV)match) > value)
2528 --match; /* was fractional--truncate other way */
2530 match -= cCOP->uop.scop.scop_offset;
2533 else if (match > cCOP->uop.scop.scop_max)
2534 match = cCOP->uop.scop.scop_max;
2535 PL_op = cCOP->uop.scop.scop_next[match];
2545 PL_op = PL_op->op_next; /* can't assume anything */
2548 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2549 match -= cCOP->uop.scop.scop_offset;
2552 else if (match > cCOP->uop.scop.scop_max)
2553 match = cCOP->uop.scop.scop_max;
2554 PL_op = cCOP->uop.scop.scop_next[match];
2563 S_save_lines(pTHX_ AV *array, SV *sv)
2565 register char *s = SvPVX(sv);
2566 register char *send = SvPVX(sv) + SvCUR(sv);
2568 register I32 line = 1;
2570 while (s && s < send) {
2571 SV *tmpstr = NEWSV(85,0);
2573 sv_upgrade(tmpstr, SVt_PVMG);
2574 t = strchr(s, '\n');
2580 sv_setpvn(tmpstr, s, t - s);
2581 av_store(array, line++, tmpstr);
2586 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2588 S_docatch_body(pTHX_ va_list args)
2590 return docatch_body();
2595 S_docatch_body(pTHX)
2602 S_docatch(pTHX_ OP *o)
2607 volatile PERL_SI *cursi = PL_curstackinfo;
2611 assert(CATCH_GET == TRUE);
2615 /* Normally, the leavetry at the end of this block of ops will
2616 * pop an op off the return stack and continue there. By setting
2617 * the op to Nullop, we force an exit from the inner runops()
2620 retop = pop_return();
2621 push_return(Nullop);
2623 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2625 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2631 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2637 /* die caught by an inner eval - continue inner loop */
2638 if (PL_restartop && cursi == PL_curstackinfo) {
2639 PL_op = PL_restartop;
2643 /* a die in this eval - continue in outer loop */
2659 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2660 /* sv Text to convert to OP tree. */
2661 /* startop op_free() this to undo. */
2662 /* code Short string id of the caller. */
2664 dSP; /* Make POPBLOCK work. */
2667 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2671 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2672 char *tmpbuf = tbuf;
2675 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2680 /* switch to eval mode */
2682 if (IN_PERL_COMPILETIME) {
2683 SAVECOPSTASH_FREE(&PL_compiling);
2684 CopSTASH_set(&PL_compiling, PL_curstash);
2686 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2687 SV *sv = sv_newmortal();
2688 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2689 code, (unsigned long)++PL_evalseq,
2690 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2694 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2695 SAVECOPFILE_FREE(&PL_compiling);
2696 CopFILE_set(&PL_compiling, tmpbuf+2);
2697 SAVECOPLINE(&PL_compiling);
2698 CopLINE_set(&PL_compiling, 1);
2699 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2700 deleting the eval's FILEGV from the stash before gv_check() runs
2701 (i.e. before run-time proper). To work around the coredump that
2702 ensues, we always turn GvMULTI_on for any globals that were
2703 introduced within evals. See force_ident(). GSAR 96-10-12 */
2704 safestr = savepv(tmpbuf);
2705 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2707 #ifdef OP_IN_REGISTER
2712 PL_hints &= HINT_UTF8;
2714 /* we get here either during compilation, or via pp_regcomp at runtime */
2715 runtime = IN_PERL_RUNTIME;
2717 runcv = find_runcv(NULL);
2720 PL_op->op_type = OP_ENTEREVAL;
2721 PL_op->op_flags = 0; /* Avoid uninit warning. */
2722 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2723 PUSHEVAL(cx, 0, Nullgv);
2726 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2728 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2729 POPBLOCK(cx,PL_curpm);
2732 (*startop)->op_type = OP_NULL;
2733 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2735 /* XXX DAPM do this properly one year */
2736 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2738 if (IN_PERL_COMPILETIME)
2739 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2740 #ifdef OP_IN_REGISTER
2748 =for apidoc find_runcv
2750 Locate the CV corresponding to the currently executing sub or eval.
2751 If db_seqp is non_null, skip CVs that are in the DB package and populate
2752 *db_seqp with the cop sequence number at the point that the DB:: code was
2753 entered. (allows debuggers to eval in the scope of the breakpoint rather
2754 than in in the scope of the debuger itself).
2760 Perl_find_runcv(pTHX_ U32 *db_seqp)
2767 *db_seqp = PL_curcop->cop_seq;
2768 for (si = PL_curstackinfo; si; si = si->si_prev) {
2769 for (ix = si->si_cxix; ix >= 0; ix--) {
2770 cx = &(si->si_cxstack[ix]);
2771 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2772 CV *cv = cx->blk_sub.cv;
2773 /* skip DB:: code */
2774 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2775 *db_seqp = cx->blk_oldcop->cop_seq;
2780 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2788 /* Compile a require/do, an eval '', or a /(?{...})/.
2789 * In the last case, startop is non-null, and contains the address of
2790 * a pointer that should be set to the just-compiled code.
2791 * outside is the lexically enclosing CV (if any) that invoked us.
2794 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2796 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2801 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2802 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2807 SAVESPTR(PL_compcv);
2808 PL_compcv = (CV*)NEWSV(1104,0);
2809 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2810 CvEVAL_on(PL_compcv);
2811 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2812 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2814 CvOUTSIDE_SEQ(PL_compcv) = seq;
2815 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2817 /* set up a scratch pad */
2819 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2822 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2824 /* make sure we compile in the right package */
2826 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2827 SAVESPTR(PL_curstash);
2828 PL_curstash = CopSTASH(PL_curcop);
2830 SAVESPTR(PL_beginav);
2831 PL_beginav = newAV();
2832 SAVEFREESV(PL_beginav);
2833 SAVEI32(PL_error_count);
2835 /* try to compile it */
2837 PL_eval_root = Nullop;
2839 PL_curcop = &PL_compiling;
2840 PL_curcop->cop_arybase = 0;
2841 if (saveop && saveop->op_flags & OPf_SPECIAL)
2842 PL_in_eval |= EVAL_KEEPERR;
2845 if (yyparse() || PL_error_count || !PL_eval_root) {
2846 SV **newsp; /* Used by POPBLOCK. */
2847 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2848 I32 optype = 0; /* Might be reset by POPEVAL. */
2853 op_free(PL_eval_root);
2854 PL_eval_root = Nullop;
2856 SP = PL_stack_base + POPMARK; /* pop original mark */
2858 POPBLOCK(cx,PL_curpm);
2864 if (optype == OP_REQUIRE) {
2865 char* msg = SvPVx(ERRSV, n_a);
2866 SV *nsv = cx->blk_eval.old_namesv;
2867 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2869 DIE(aTHX_ "%sCompilation failed in require",
2870 *msg ? msg : "Unknown error\n");
2873 char* msg = SvPVx(ERRSV, n_a);
2875 POPBLOCK(cx,PL_curpm);
2877 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2878 (*msg ? msg : "Unknown error\n"));
2881 char* msg = SvPVx(ERRSV, n_a);
2883 sv_setpv(ERRSV, "Compilation error");
2888 CopLINE_set(&PL_compiling, 0);
2890 *startop = PL_eval_root;
2892 SAVEFREEOP(PL_eval_root);
2894 /* Set the context for this new optree.
2895 * If the last op is an OP_REQUIRE, force scalar context.
2896 * Otherwise, propagate the context from the eval(). */
2897 if (PL_eval_root->op_type == OP_LEAVEEVAL
2898 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2899 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2901 scalar(PL_eval_root);
2902 else if (gimme & G_VOID)
2903 scalarvoid(PL_eval_root);
2904 else if (gimme & G_ARRAY)
2907 scalar(PL_eval_root);
2909 DEBUG_x(dump_eval());
2911 /* Register with debugger: */
2912 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2913 CV *cv = get_cv("DB::postponed", FALSE);
2917 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2919 call_sv((SV*)cv, G_DISCARD);
2923 /* compiled okay, so do it */
2925 CvDEPTH(PL_compcv) = 1;
2926 SP = PL_stack_base + POPMARK; /* pop original mark */
2927 PL_op = saveop; /* The caller may need it. */
2928 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2930 RETURNOP(PL_eval_start);
2934 S_doopen_pm(pTHX_ const char *name, const char *mode)
2936 #ifndef PERL_DISABLE_PMC
2937 STRLEN namelen = strlen(name);
2940 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2941 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2942 char *pmc = SvPV_nolen(pmcsv);
2945 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2946 fp = PerlIO_open(name, mode);
2949 if (PerlLIO_stat(name, &pmstat) < 0 ||
2950 pmstat.st_mtime < pmcstat.st_mtime)
2952 fp = PerlIO_open(pmc, mode);
2955 fp = PerlIO_open(name, mode);
2958 SvREFCNT_dec(pmcsv);
2961 fp = PerlIO_open(name, mode);
2965 return PerlIO_open(name, mode);
2966 #endif /* !PERL_DISABLE_PMC */
2972 register PERL_CONTEXT *cx;
2976 char *tryname = Nullch;
2977 SV *namesv = Nullsv;
2979 I32 gimme = GIMME_V;
2980 PerlIO *tryrsfp = 0;
2982 int filter_has_file = 0;
2983 GV *filter_child_proc = 0;
2984 SV *filter_state = 0;
2991 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2992 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2993 UV rev = 0, ver = 0, sver = 0;
2995 U8 *s = (U8*)SvPVX(sv);
2996 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2998 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3001 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3004 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3007 if (PERL_REVISION < rev
3008 || (PERL_REVISION == rev
3009 && (PERL_VERSION < ver
3010 || (PERL_VERSION == ver
3011 && PERL_SUBVERSION < sver))))
3013 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3014 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3015 PERL_VERSION, PERL_SUBVERSION);
3017 if (ckWARN(WARN_PORTABLE))
3018 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3019 "v-string in use/require non-portable");
3022 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3023 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3024 + ((NV)PERL_SUBVERSION/(NV)1000000)
3025 + 0.00000099 < SvNV(sv))
3029 NV nver = (nrev - rev) * 1000;
3030 UV ver = (UV)(nver + 0.0009);
3031 NV nsver = (nver - ver) * 1000;
3032 UV sver = (UV)(nsver + 0.0009);
3034 /* help out with the "use 5.6" confusion */
3035 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3036 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3037 " (did you mean v%"UVuf".%03"UVuf"?)--"
3038 "this is only v%d.%d.%d, stopped",
3039 rev, ver, sver, rev, ver/100,
3040 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3043 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3044 "this is only v%d.%d.%d, stopped",
3045 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3052 name = SvPV(sv, len);
3053 if (!(name && len > 0 && *name))
3054 DIE(aTHX_ "Null filename used");
3055 TAINT_PROPER("require");
3056 if (PL_op->op_type == OP_REQUIRE &&
3057 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3058 if (*svp != &PL_sv_undef)
3061 DIE(aTHX_ "Compilation failed in require");
3064 /* prepare to compile file */
3066 if (path_is_absolute(name)) {
3068 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3070 #ifdef MACOS_TRADITIONAL
3074 MacPerl_CanonDir(name, newname, 1);
3075 if (path_is_absolute(newname)) {
3077 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3082 AV *ar = GvAVn(PL_incgv);
3086 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3089 namesv = NEWSV(806, 0);
3090 for (i = 0; i <= AvFILL(ar); i++) {
3091 SV *dirsv = *av_fetch(ar, i, TRUE);
3097 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3098 && !sv_isobject(loader))
3100 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3103 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3104 PTR2UV(SvRV(dirsv)), name);
3105 tryname = SvPVX(namesv);
3116 if (sv_isobject(loader))
3117 count = call_method("INC", G_ARRAY);
3119 count = call_sv(loader, G_ARRAY);
3129 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3133 if (SvTYPE(arg) == SVt_PVGV) {
3134 IO *io = GvIO((GV *)arg);
3139 tryrsfp = IoIFP(io);
3140 if (IoTYPE(io) == IoTYPE_PIPE) {
3141 /* reading from a child process doesn't
3142 nest -- when returning from reading
3143 the inner module, the outer one is
3144 unreadable (closed?) I've tried to
3145 save the gv to manage the lifespan of
3146 the pipe, but this didn't help. XXX */
3147 filter_child_proc = (GV *)arg;
3148 (void)SvREFCNT_inc(filter_child_proc);
3151 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3152 PerlIO_close(IoOFP(io));
3164 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3166 (void)SvREFCNT_inc(filter_sub);
3169 filter_state = SP[i];
3170 (void)SvREFCNT_inc(filter_state);
3174 tryrsfp = PerlIO_open("/dev/null",
3190 filter_has_file = 0;
3191 if (filter_child_proc) {
3192 SvREFCNT_dec(filter_child_proc);
3193 filter_child_proc = 0;
3196 SvREFCNT_dec(filter_state);
3200 SvREFCNT_dec(filter_sub);
3205 if (!path_is_absolute(name)
3206 #ifdef MACOS_TRADITIONAL
3207 /* We consider paths of the form :a:b ambiguous and interpret them first
3208 as global then as local
3210 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3213 char *dir = SvPVx(dirsv, n_a);
3214 #ifdef MACOS_TRADITIONAL
3218 MacPerl_CanonDir(name, buf2, 1);
3219 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3223 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3225 sv_setpv(namesv, unixdir);
3226 sv_catpv(namesv, unixname);
3228 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3231 TAINT_PROPER("require");
3232 tryname = SvPVX(namesv);
3233 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3235 if (tryname[0] == '.' && tryname[1] == '/')
3244 SAVECOPFILE_FREE(&PL_compiling);
3245 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3246 SvREFCNT_dec(namesv);
3248 if (PL_op->op_type == OP_REQUIRE) {
3249 char *msgstr = name;
3250 if (namesv) { /* did we lookup @INC? */
3251 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3252 SV *dirmsgsv = NEWSV(0, 0);
3253 AV *ar = GvAVn(PL_incgv);
3255 sv_catpvn(msg, " in @INC", 8);
3256 if (instr(SvPVX(msg), ".h "))
3257 sv_catpv(msg, " (change .h to .ph maybe?)");
3258 if (instr(SvPVX(msg), ".ph "))
3259 sv_catpv(msg, " (did you run h2ph?)");
3260 sv_catpv(msg, " (@INC contains:");
3261 for (i = 0; i <= AvFILL(ar); i++) {
3262 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3263 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3264 sv_catsv(msg, dirmsgsv);
3266 sv_catpvn(msg, ")", 1);
3267 SvREFCNT_dec(dirmsgsv);
3268 msgstr = SvPV_nolen(msg);
3270 DIE(aTHX_ "Can't locate %s", msgstr);
3276 SETERRNO(0, SS_NORMAL);
3278 /* Assume success here to prevent recursive requirement. */
3280 /* Check whether a hook in @INC has already filled %INC */
3281 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3282 (void)hv_store(GvHVn(PL_incgv), name, len,
3283 (hook_sv ? SvREFCNT_inc(hook_sv)
3284 : newSVpv(CopFILE(&PL_compiling), 0)),
3290 lex_start(sv_2mortal(newSVpvn("",0)));
3291 SAVEGENERICSV(PL_rsfp_filters);
3292 PL_rsfp_filters = Nullav;
3297 SAVESPTR(PL_compiling.cop_warnings);
3298 if (PL_dowarn & G_WARN_ALL_ON)
3299 PL_compiling.cop_warnings = pWARN_ALL ;
3300 else if (PL_dowarn & G_WARN_ALL_OFF)
3301 PL_compiling.cop_warnings = pWARN_NONE ;
3302 else if (PL_taint_warn)
3303 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3305 PL_compiling.cop_warnings = pWARN_STD ;
3306 SAVESPTR(PL_compiling.cop_io);
3307 PL_compiling.cop_io = Nullsv;
3309 if (filter_sub || filter_child_proc) {
3310 SV *datasv = filter_add(run_user_filter, Nullsv);
3311 IoLINES(datasv) = filter_has_file;
3312 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3313 IoTOP_GV(datasv) = (GV *)filter_state;
3314 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3317 /* switch to eval mode */
3318 push_return(PL_op->op_next);
3319 PUSHBLOCK(cx, CXt_EVAL, SP);
3320 PUSHEVAL(cx, name, Nullgv);
3322 SAVECOPLINE(&PL_compiling);
3323 CopLINE_set(&PL_compiling, 0);
3327 /* Store and reset encoding. */
3328 encoding = PL_encoding;
3329 PL_encoding = Nullsv;
3331 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3333 /* Restore encoding. */
3334 PL_encoding = encoding;
3341 return pp_require();
3347 register PERL_CONTEXT *cx;
3349 I32 gimme = GIMME_V, was = PL_sub_generation;
3350 char tbuf[TYPE_DIGITS(long) + 12];
3351 char *tmpbuf = tbuf;
3360 TAINT_PROPER("eval");
3366 /* switch to eval mode */
3368 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3369 SV *sv = sv_newmortal();
3370 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3371 (unsigned long)++PL_evalseq,
3372 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3376 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3377 SAVECOPFILE_FREE(&PL_compiling);
3378 CopFILE_set(&PL_compiling, tmpbuf+2);
3379 SAVECOPLINE(&PL_compiling);
3380 CopLINE_set(&PL_compiling, 1);
3381 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3382 deleting the eval's FILEGV from the stash before gv_check() runs
3383 (i.e. before run-time proper). To work around the coredump that
3384 ensues, we always turn GvMULTI_on for any globals that were
3385 introduced within evals. See force_ident(). GSAR 96-10-12 */
3386 safestr = savepv(tmpbuf);
3387 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3389 PL_hints = PL_op->op_targ;
3390 SAVESPTR(PL_compiling.cop_warnings);
3391 if (specialWARN(PL_curcop->cop_warnings))
3392 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3394 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3395 SAVEFREESV(PL_compiling.cop_warnings);
3397 SAVESPTR(PL_compiling.cop_io);
3398 if (specialCopIO(PL_curcop->cop_io))
3399 PL_compiling.cop_io = PL_curcop->cop_io;
3401 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3402 SAVEFREESV(PL_compiling.cop_io);
3404 /* special case: an eval '' executed within the DB package gets lexically
3405 * placed in the first non-DB CV rather than the current CV - this
3406 * allows the debugger to execute code, find lexicals etc, in the
3407 * scope of the code being debugged. Passing &seq gets find_runcv
3408 * to do the dirty work for us */
3409 runcv = find_runcv(&seq);
3411 push_return(PL_op->op_next);
3412 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3413 PUSHEVAL(cx, 0, Nullgv);
3415 /* prepare to compile string */
3417 if (PERLDB_LINE && PL_curstash != PL_debstash)
3418 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3420 ret = doeval(gimme, NULL, runcv, seq);
3421 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3422 && ret != PL_op->op_next) { /* Successive compilation. */
3423 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3425 return DOCATCH(ret);
3435 register PERL_CONTEXT *cx;
3437 U8 save_flags = PL_op -> op_flags;
3442 retop = pop_return();
3445 if (gimme == G_VOID)
3447 else if (gimme == G_SCALAR) {
3450 if (SvFLAGS(TOPs) & SVs_TEMP)
3453 *MARK = sv_mortalcopy(TOPs);
3457 *MARK = &PL_sv_undef;
3462 /* in case LEAVE wipes old return values */
3463 for (mark = newsp + 1; mark <= SP; mark++) {
3464 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3465 *mark = sv_mortalcopy(*mark);
3466 TAINT_NOT; /* Each item is independent */
3470 PL_curpm = newpm; /* Don't pop $1 et al till now */
3473 assert(CvDEPTH(PL_compcv) == 1);
3475 CvDEPTH(PL_compcv) = 0;
3478 if (optype == OP_REQUIRE &&
3479 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3481 /* Unassume the success we assumed earlier. */
3482 SV *nsv = cx->blk_eval.old_namesv;
3483 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3484 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3485 /* die_where() did LEAVE, or we won't be here */
3489 if (!(save_flags & OPf_SPECIAL))
3499 register PERL_CONTEXT *cx;
3500 I32 gimme = GIMME_V;
3505 push_return(cLOGOP->op_other->op_next);
3506 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3509 PL_in_eval = EVAL_INEVAL;
3512 return DOCATCH(PL_op->op_next);
3523 register PERL_CONTEXT *cx;
3528 retop = pop_return();
3531 if (gimme == G_VOID)
3533 else if (gimme == G_SCALAR) {
3536 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3539 *MARK = sv_mortalcopy(TOPs);
3543 *MARK = &PL_sv_undef;
3548 /* in case LEAVE wipes old return values */
3549 for (mark = newsp + 1; mark <= SP; mark++) {
3550 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3551 *mark = sv_mortalcopy(*mark);
3552 TAINT_NOT; /* Each item is independent */
3556 PL_curpm = newpm; /* Don't pop $1 et al till now */
3564 S_doparseform(pTHX_ SV *sv)
3567 register char *s = SvPV_force(sv, len);
3568 register char *send = s + len;
3569 register char *base = Nullch;
3570 register I32 skipspaces = 0;
3571 bool noblank = FALSE;
3572 bool repeat = FALSE;
3573 bool postspace = FALSE;
3579 int maxops = 2; /* FF_LINEMARK + FF_END) */
3582 Perl_croak(aTHX_ "Null picture in formline");
3584 /* estimate the buffer size needed */
3585 for (base = s; s <= send; s++) {
3586 if (*s == '\n' || *s == '@' || *s == '^')
3592 New(804, fops, maxops, U32);
3597 *fpc++ = FF_LINEMARK;
3598 noblank = repeat = FALSE;
3616 case ' ': case '\t':
3627 *fpc++ = FF_LITERAL;
3635 *fpc++ = (U16)skipspaces;
3639 *fpc++ = FF_NEWLINE;
3643 arg = fpc - linepc + 1;
3650 *fpc++ = FF_LINEMARK;
3651 noblank = repeat = FALSE;
3660 ischop = s[-1] == '^';
3666 arg = (s - base) - 1;
3668 *fpc++ = FF_LITERAL;
3677 *fpc++ = FF_LINEGLOB;
3679 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3680 arg = ischop ? 512 : 0;
3690 arg |= 256 + (s - f);
3692 *fpc++ = s - base; /* fieldsize for FETCH */
3693 *fpc++ = FF_DECIMAL;
3696 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3697 arg = ischop ? 512 : 0;
3699 s++; /* skip the '0' first */
3708 arg |= 256 + (s - f);
3710 *fpc++ = s - base; /* fieldsize for FETCH */
3711 *fpc++ = FF_0DECIMAL;
3716 bool ismore = FALSE;
3719 while (*++s == '>') ;
3720 prespace = FF_SPACE;
3722 else if (*s == '|') {
3723 while (*++s == '|') ;
3724 prespace = FF_HALFSPACE;
3729 while (*++s == '<') ;
3732 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3736 *fpc++ = s - base; /* fieldsize for FETCH */
3738 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3741 *fpc++ = (U16)prespace;
3755 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3757 { /* need to jump to the next word */
3759 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3760 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3761 s = SvPVX(sv) + SvCUR(sv) + z;
3763 Copy(fops, s, arg, U32);
3765 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3770 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3772 SV *datasv = FILTER_DATA(idx);
3773 int filter_has_file = IoLINES(datasv);
3774 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3775 SV *filter_state = (SV *)IoTOP_GV(datasv);
3776 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3779 /* I was having segfault trouble under Linux 2.2.5 after a
3780 parse error occured. (Had to hack around it with a test
3781 for PL_error_count == 0.) Solaris doesn't segfault --
3782 not sure where the trouble is yet. XXX */
3784 if (filter_has_file) {
3785 len = FILTER_READ(idx+1, buf_sv, maxlen);
3788 if (filter_sub && len >= 0) {
3799 PUSHs(sv_2mortal(newSViv(maxlen)));
3801 PUSHs(filter_state);
3804 count = call_sv(filter_sub, G_SCALAR);
3820 IoLINES(datasv) = 0;
3821 if (filter_child_proc) {
3822 SvREFCNT_dec(filter_child_proc);
3823 IoFMT_GV(datasv) = Nullgv;
3826 SvREFCNT_dec(filter_state);
3827 IoTOP_GV(datasv) = Nullgv;
3830 SvREFCNT_dec(filter_sub);
3831 IoBOTTOM_GV(datasv) = Nullgv;
3833 filter_del(run_user_filter);
3839 /* perhaps someone can come up with a better name for
3840 this? it is not really "absolute", per se ... */
3842 S_path_is_absolute(pTHX_ char *name)
3844 if (PERL_FILE_IS_ABSOLUTE(name)
3845 #ifdef MACOS_TRADITIONAL
3848 || (*name == '.' && (name[1] == '/' ||
3849 (name[1] == '.' && name[2] == '/'))))