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. */
68 register PMOP *pm = (PMOP*)cLOGOP->op_other;
72 MAGIC *mg = Null(MAGIC*);
76 /* prevent recompiling under /o and ithreads. */
77 #if defined(USE_ITHREADS)
78 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
83 SV *sv = SvRV(tmpstr);
85 mg = mg_find(sv, PERL_MAGIC_qr);
88 regexp *re = (regexp *)mg->mg_obj;
89 ReREFCNT_dec(PM_GETRE(pm));
90 PM_SETRE(pm, ReREFCNT_inc(re));
93 t = SvPV(tmpstr, len);
95 /* Check against the last compiled regexp. */
96 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
97 PM_GETRE(pm)->prelen != (I32)len ||
98 memNE(PM_GETRE(pm)->precomp, t, len))
101 ReREFCNT_dec(PM_GETRE(pm));
102 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
104 if (PL_op->op_flags & OPf_SPECIAL)
105 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
107 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
109 pm->op_pmdynflags |= PMdf_DYN_UTF8;
111 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
112 if (pm->op_pmdynflags & PMdf_UTF8)
113 t = (char*)bytes_to_utf8((U8*)t, &len);
115 PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
116 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
118 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
119 inside tie/overload accessors. */
123 #ifndef INCOMPLETE_TAINTS
126 pm->op_pmdynflags |= PMdf_TAINTED;
128 pm->op_pmdynflags &= ~PMdf_TAINTED;
132 if (!PM_GETRE(pm)->prelen && PL_curpm)
134 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
135 pm->op_pmflags |= PMf_WHITE;
137 pm->op_pmflags &= ~PMf_WHITE;
139 /* XXX runtime compiled output needs to move to the pad */
140 if (pm->op_pmflags & PMf_KEEP) {
141 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
142 #if !defined(USE_ITHREADS)
143 /* XXX can't change the optree at runtime either */
144 cLOGOP->op_first->op_next = PL_op->op_next;
153 register PMOP *pm = (PMOP*) cLOGOP->op_other;
154 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
155 register SV *dstr = cx->sb_dstr;
156 register char *s = cx->sb_s;
157 register char *m = cx->sb_m;
158 char *orig = cx->sb_orig;
159 register REGEXP *rx = cx->sb_rx;
163 REGEXP *old = PM_GETRE(pm);
171 rxres_restore(&cx->sb_rxres, rx);
172 RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
174 if (cx->sb_iters++) {
175 I32 saviters = cx->sb_iters;
176 if (cx->sb_iters > cx->sb_maxiters)
177 DIE(aTHX_ "Substitution loop");
179 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
180 cx->sb_rxtainted |= 2;
181 sv_catsv(dstr, POPs);
184 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
185 s == m, cx->sb_targ, NULL,
186 ((cx->sb_rflags & REXEC_COPY_STR)
187 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
188 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
190 SV *targ = cx->sb_targ;
192 if (DO_UTF8(dstr) && !SvUTF8(targ))
193 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
195 sv_catpvn(dstr, s, cx->sb_strend - s);
196 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
198 #ifdef PERL_COPY_ON_WRITE
200 sv_force_normal_flags(targ, SV_COW_DROP_PV);
204 (void)SvOOK_off(targ);
206 Safefree(SvPVX(targ));
208 SvPVX(targ) = SvPVX(dstr);
209 SvCUR_set(targ, SvCUR(dstr));
210 SvLEN_set(targ, SvLEN(dstr));
216 TAINT_IF(cx->sb_rxtainted & 1);
217 PUSHs(sv_2mortal(newSViv(saviters - 1)));
219 (void)SvPOK_only_UTF8(targ);
220 TAINT_IF(cx->sb_rxtainted);
224 LEAVE_SCOPE(cx->sb_oldsave);
227 RETURNOP(pm->op_next);
229 cx->sb_iters = saviters;
231 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
234 cx->sb_orig = orig = rx->subbeg;
236 cx->sb_strend = s + (cx->sb_strend - m);
238 cx->sb_m = m = rx->startp[0] + orig;
240 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
241 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
243 sv_catpvn(dstr, s, m-s);
245 cx->sb_s = rx->endp[0] + orig;
246 { /* Update the pos() information. */
247 SV *sv = cx->sb_targ;
250 if (SvTYPE(sv) < SVt_PVMG)
251 (void)SvUPGRADE(sv, SVt_PVMG);
252 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
253 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
254 mg = mg_find(sv, PERL_MAGIC_regex_global);
262 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
263 rxres_save(&cx->sb_rxres, rx);
264 RETURNOP(pm->op_pmreplstart);
268 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
273 if (!p || p[1] < rx->nparens) {
274 #ifdef PERL_COPY_ON_WRITE
275 i = 7 + rx->nparens * 2;
277 i = 6 + rx->nparens * 2;
286 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
287 RX_MATCH_COPIED_off(rx);
289 #ifdef PERL_COPY_ON_WRITE
290 *p++ = PTR2UV(rx->saved_copy);
291 rx->saved_copy = Nullsv;
296 *p++ = PTR2UV(rx->subbeg);
297 *p++ = (UV)rx->sublen;
298 for (i = 0; i <= rx->nparens; ++i) {
299 *p++ = (UV)rx->startp[i];
300 *p++ = (UV)rx->endp[i];
305 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
310 RX_MATCH_COPY_FREE(rx);
311 RX_MATCH_COPIED_set(rx, *p);
314 #ifdef PERL_COPY_ON_WRITE
316 SvREFCNT_dec (rx->saved_copy);
317 rx->saved_copy = INT2PTR(SV*,*p);
323 rx->subbeg = INT2PTR(char*,*p++);
324 rx->sublen = (I32)(*p++);
325 for (i = 0; i <= rx->nparens; ++i) {
326 rx->startp[i] = (I32)(*p++);
327 rx->endp[i] = (I32)(*p++);
332 Perl_rxres_free(pTHX_ void **rsp)
337 Safefree(INT2PTR(char*,*p));
338 #ifdef PERL_COPY_ON_WRITE
340 SvREFCNT_dec (INT2PTR(SV*,p[1]));
350 dSP; dMARK; dORIGMARK;
351 register SV *tmpForm = *++MARK;
358 register SV *sv = Nullsv;
363 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
364 char *chophere = Nullch;
365 char *linemark = Nullch;
367 bool gotsome = FALSE;
369 STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
370 bool item_is_utf8 = FALSE;
371 bool targ_is_utf8 = FALSE;
374 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
375 if (SvREADONLY(tmpForm)) {
376 SvREADONLY_off(tmpForm);
377 doparseform(tmpForm);
378 SvREADONLY_on(tmpForm);
381 doparseform(tmpForm);
383 SvPV_force(PL_formtarget, len);
384 if (DO_UTF8(PL_formtarget))
386 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
388 f = SvPV(tmpForm, len);
389 /* need to jump to the next word */
390 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
399 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
400 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
401 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
402 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
403 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
405 case FF_CHECKNL: name = "CHECKNL"; break;
406 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
407 case FF_SPACE: name = "SPACE"; break;
408 case FF_HALFSPACE: name = "HALFSPACE"; break;
409 case FF_ITEM: name = "ITEM"; break;
410 case FF_CHOP: name = "CHOP"; break;
411 case FF_LINEGLOB: name = "LINEGLOB"; break;
412 case FF_NEWLINE: name = "NEWLINE"; break;
413 case FF_MORE: name = "MORE"; break;
414 case FF_LINEMARK: name = "LINEMARK"; break;
415 case FF_END: name = "END"; break;
416 case FF_0DECIMAL: name = "0DECIMAL"; break;
419 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
421 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
432 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
433 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
435 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
436 t = SvEND(PL_formtarget);
439 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
440 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
442 sv_utf8_upgrade(PL_formtarget);
443 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
444 t = SvEND(PL_formtarget);
464 if (ckWARN(WARN_SYNTAX))
465 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
470 item = s = SvPV(sv, len);
473 itemsize = sv_len_utf8(sv);
474 if (itemsize != (I32)len) {
476 if (itemsize > fieldsize) {
477 itemsize = fieldsize;
478 itembytes = itemsize;
479 sv_pos_u2b(sv, &itembytes, 0);
483 send = chophere = s + itembytes;
493 sv_pos_b2u(sv, &itemsize);
497 item_is_utf8 = FALSE;
498 if (itemsize > fieldsize)
499 itemsize = fieldsize;
500 send = chophere = s + itemsize;
512 item = s = SvPV(sv, len);
515 itemsize = sv_len_utf8(sv);
516 if (itemsize != (I32)len) {
518 if (itemsize <= fieldsize) {
519 send = chophere = s + itemsize;
530 itemsize = fieldsize;
531 itembytes = itemsize;
532 sv_pos_u2b(sv, &itembytes, 0);
533 send = chophere = s + itembytes;
534 while (s < send || (s == send && isSPACE(*s))) {
544 if (strchr(PL_chopset, *s))
549 itemsize = chophere - item;
550 sv_pos_b2u(sv, &itemsize);
556 item_is_utf8 = FALSE;
557 if (itemsize <= fieldsize) {
558 send = chophere = s + itemsize;
569 itemsize = fieldsize;
570 send = chophere = s + itemsize;
571 while (s < send || (s == send && isSPACE(*s))) {
581 if (strchr(PL_chopset, *s))
586 itemsize = chophere - item;
591 arg = fieldsize - itemsize;
600 arg = fieldsize - itemsize;
614 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
616 sv_utf8_upgrade(PL_formtarget);
617 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
618 t = SvEND(PL_formtarget);
622 if (UTF8_IS_CONTINUED(*s)) {
623 STRLEN skip = UTF8SKIP(s);
640 if ( !((*t++ = *s++) & ~31) )
646 if (targ_is_utf8 && !item_is_utf8) {
647 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
649 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
650 for (; t < SvEND(PL_formtarget); t++) {
652 int ch = *t++ = *s++;
663 int ch = *t++ = *s++;
666 if ( !((*t++ = *s++) & ~31) )
675 while (*s && isSPACE(*s))
683 item = s = SvPV(sv, len);
685 if ((item_is_utf8 = DO_UTF8(sv)))
686 itemsize = sv_len_utf8(sv);
688 bool chopped = FALSE;
701 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
703 SvUTF8_on(PL_formtarget);
704 sv_catsv(PL_formtarget, sv);
706 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
707 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
708 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
715 /* If the field is marked with ^ and the value is undefined,
718 if ((arg & 512) && !SvOK(sv)) {
726 /* Formats aren't yet marked for locales, so assume "yes". */
728 STORE_NUMERIC_STANDARD_SET_LOCAL();
729 #if defined(USE_LONG_DOUBLE)
731 sprintf(t, "%#*.*" PERL_PRIfldbl,
732 (int) fieldsize, (int) arg & 255, value);
734 sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
739 (int) fieldsize, (int) arg & 255, value);
742 (int) fieldsize, value);
745 RESTORE_NUMERIC_STANDARD();
751 /* If the field is marked with ^ and the value is undefined,
754 if ((arg & 512) && !SvOK(sv)) {
762 /* Formats aren't yet marked for locales, so assume "yes". */
764 STORE_NUMERIC_STANDARD_SET_LOCAL();
765 #if defined(USE_LONG_DOUBLE)
767 sprintf(t, "%#0*.*" PERL_PRIfldbl,
768 (int) fieldsize, (int) arg & 255, value);
769 /* is this legal? I don't have long doubles */
771 sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
775 sprintf(t, "%#0*.*f",
776 (int) fieldsize, (int) arg & 255, value);
779 (int) fieldsize, value);
782 RESTORE_NUMERIC_STANDARD();
789 while (t-- > linemark && *t == ' ') ;
797 if (arg) { /* repeat until fields exhausted? */
799 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
800 lines += FmLINES(PL_formtarget);
803 if (strnEQ(linemark, linemark - arg, arg))
804 DIE(aTHX_ "Runaway format");
807 SvUTF8_on(PL_formtarget);
808 FmLINES(PL_formtarget) = lines;
810 RETURNOP(cLISTOP->op_first);
823 while (*s && isSPACE(*s) && s < send)
827 arg = fieldsize - itemsize;
834 if (strnEQ(s," ",3)) {
835 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
846 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
848 SvUTF8_on(PL_formtarget);
849 FmLINES(PL_formtarget) += lines;
861 if (PL_stack_base + *PL_markstack_ptr == SP) {
863 if (GIMME_V == G_SCALAR)
864 XPUSHs(sv_2mortal(newSViv(0)));
865 RETURNOP(PL_op->op_next->op_next);
867 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
868 pp_pushmark(); /* push dst */
869 pp_pushmark(); /* push src */
870 ENTER; /* enter outer scope */
873 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
875 ENTER; /* enter inner scope */
878 src = PL_stack_base[*PL_markstack_ptr];
883 if (PL_op->op_type == OP_MAPSTART)
884 pp_pushmark(); /* push top */
885 return ((LOGOP*)PL_op->op_next)->op_other;
890 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
897 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
903 /* first, move source pointer to the next item in the source list */
904 ++PL_markstack_ptr[-1];
906 /* if there are new items, push them into the destination list */
907 if (items && gimme != G_VOID) {
908 /* might need to make room back there first */
909 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
910 /* XXX this implementation is very pessimal because the stack
911 * is repeatedly extended for every set of items. Is possible
912 * to do this without any stack extension or copying at all
913 * by maintaining a separate list over which the map iterates
914 * (like foreach does). --gsar */
916 /* everything in the stack after the destination list moves
917 * towards the end the stack by the amount of room needed */
918 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
920 /* items to shift up (accounting for the moved source pointer) */
921 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
923 /* This optimization is by Ben Tilly and it does
924 * things differently from what Sarathy (gsar)
925 * is describing. The downside of this optimization is
926 * that leaves "holes" (uninitialized and hopefully unused areas)
927 * to the Perl stack, but on the other hand this
928 * shouldn't be a problem. If Sarathy's idea gets
929 * implemented, this optimization should become
930 * irrelevant. --jhi */
932 shift = count; /* Avoid shifting too often --Ben Tilly */
937 PL_markstack_ptr[-1] += shift;
938 *PL_markstack_ptr += shift;
942 /* copy the new items down to the destination list */
943 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
945 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
947 LEAVE; /* exit inner scope */
950 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
952 (void)POPMARK; /* pop top */
953 LEAVE; /* exit outer scope */
954 (void)POPMARK; /* pop src */
955 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
956 (void)POPMARK; /* pop dst */
957 SP = PL_stack_base + POPMARK; /* pop original mark */
958 if (gimme == G_SCALAR) {
962 else if (gimme == G_ARRAY)
969 ENTER; /* enter inner scope */
972 /* set $_ to the new source item */
973 src = PL_stack_base[PL_markstack_ptr[-1]];
977 RETURNOP(cLOGOP->op_other);
985 if (GIMME == G_ARRAY)
987 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
988 return cLOGOP->op_other;
997 if (GIMME == G_ARRAY) {
998 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1002 SV *targ = PAD_SV(PL_op->op_targ);
1005 if (PL_op->op_private & OPpFLIP_LINENUM) {
1006 if (GvIO(PL_last_in_gv)) {
1007 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1010 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1011 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
1017 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1018 if (PL_op->op_flags & OPf_SPECIAL) {
1026 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1039 if (GIMME == G_ARRAY) {
1045 if (SvGMAGICAL(left))
1047 if (SvGMAGICAL(right))
1050 /* This code tries to decide if "$left .. $right" should use the
1051 magical string increment, or if the range is numeric (we make
1052 an exception for .."0" [#18165]). AMS 20021031. */
1054 if (SvNIOKp(left) || !SvPOKp(left) ||
1055 SvNIOKp(right) || !SvPOKp(right) ||
1056 (looks_like_number(left) && *SvPVX(left) != '0' &&
1057 looks_like_number(right)))
1059 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1060 DIE(aTHX_ "Range iterator outside integer range");
1071 sv = sv_2mortal(newSViv(i++));
1076 SV *final = sv_mortalcopy(right);
1078 char *tmps = SvPV(final, len);
1080 sv = sv_mortalcopy(left);
1082 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1084 if (strEQ(SvPVX(sv),tmps))
1086 sv = sv_2mortal(newSVsv(sv));
1093 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1097 if (PL_op->op_private & OPpFLIP_LINENUM) {
1098 if (GvIO(PL_last_in_gv)) {
1099 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1102 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1103 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1111 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1112 sv_catpv(targ, "E0");
1122 static char *context_name[] = {
1133 S_dopoptolabel(pTHX_ char *label)
1136 register PERL_CONTEXT *cx;
1138 for (i = cxstack_ix; i >= 0; i--) {
1140 switch (CxTYPE(cx)) {
1146 if (ckWARN(WARN_EXITING))
1147 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1148 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1149 if (CxTYPE(cx) == CXt_NULL)
1153 if (!cx->blk_loop.label ||
1154 strNE(label, cx->blk_loop.label) ) {
1155 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1156 (long)i, cx->blk_loop.label));
1159 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1167 Perl_dowantarray(pTHX)
1169 I32 gimme = block_gimme();
1170 return (gimme == G_VOID) ? G_SCALAR : gimme;
1174 Perl_block_gimme(pTHX)
1178 cxix = dopoptosub(cxstack_ix);
1182 switch (cxstack[cxix].blk_gimme) {
1190 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1197 Perl_is_lvalue_sub(pTHX)
1201 cxix = dopoptosub(cxstack_ix);
1202 assert(cxix >= 0); /* We should only be called from inside subs */
1204 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1205 return cxstack[cxix].blk_sub.lval;
1211 S_dopoptosub(pTHX_ I32 startingblock)
1213 return dopoptosub_at(cxstack, startingblock);
1217 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1220 register PERL_CONTEXT *cx;
1221 for (i = startingblock; i >= 0; i--) {
1223 switch (CxTYPE(cx)) {
1229 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1237 S_dopoptoeval(pTHX_ I32 startingblock)
1240 register PERL_CONTEXT *cx;
1241 for (i = startingblock; i >= 0; i--) {
1243 switch (CxTYPE(cx)) {
1247 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1255 S_dopoptoloop(pTHX_ I32 startingblock)
1258 register PERL_CONTEXT *cx;
1259 for (i = startingblock; i >= 0; i--) {
1261 switch (CxTYPE(cx)) {
1267 if (ckWARN(WARN_EXITING))
1268 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1269 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1270 if ((CxTYPE(cx)) == CXt_NULL)
1274 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1282 Perl_dounwind(pTHX_ I32 cxix)
1284 register PERL_CONTEXT *cx;
1287 while (cxstack_ix > cxix) {
1289 cx = &cxstack[cxstack_ix];
1290 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1291 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1292 /* Note: we don't need to restore the base context info till the end. */
1293 switch (CxTYPE(cx)) {
1296 continue; /* not break */
1318 Perl_qerror(pTHX_ SV *err)
1321 sv_catsv(ERRSV, err);
1323 sv_catsv(PL_errors, err);
1325 Perl_warn(aTHX_ "%"SVf, err);
1330 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1336 register PERL_CONTEXT *cx;
1341 if (PL_in_eval & EVAL_KEEPERR) {
1342 static char prefix[] = "\t(in cleanup) ";
1347 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1350 if (*e != *message || strNE(e,message))
1354 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1355 sv_catpvn(err, prefix, sizeof(prefix)-1);
1356 sv_catpvn(err, message, msglen);
1357 if (ckWARN(WARN_MISC)) {
1358 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1359 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1364 sv_setpvn(ERRSV, message, msglen);
1368 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1369 && PL_curstackinfo->si_prev)
1378 if (cxix < cxstack_ix)
1381 POPBLOCK(cx,PL_curpm);
1382 if (CxTYPE(cx) != CXt_EVAL) {
1384 message = SvPVx(ERRSV, msglen);
1385 PerlIO_write(Perl_error_log, "panic: die ", 11);
1386 PerlIO_write(Perl_error_log, message, msglen);
1391 if (gimme == G_SCALAR)
1392 *++newsp = &PL_sv_undef;
1393 PL_stack_sp = newsp;
1397 /* LEAVE could clobber PL_curcop (see save_re_context())
1398 * XXX it might be better to find a way to avoid messing with
1399 * PL_curcop in save_re_context() instead, but this is a more
1400 * minimal fix --GSAR */
1401 PL_curcop = cx->blk_oldcop;
1403 if (optype == OP_REQUIRE) {
1404 char* msg = SvPVx(ERRSV, n_a);
1405 DIE(aTHX_ "%sCompilation failed in require",
1406 *msg ? msg : "Unknown error\n");
1408 return pop_return();
1412 message = SvPVx(ERRSV, msglen);
1414 write_to_stderr(message, msglen);
1423 if (SvTRUE(left) != SvTRUE(right))
1435 RETURNOP(cLOGOP->op_other);
1444 RETURNOP(cLOGOP->op_other);
1453 if (!sv || !SvANY(sv)) {
1454 RETURNOP(cLOGOP->op_other);
1457 switch (SvTYPE(sv)) {
1459 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1463 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1467 if (CvROOT(sv) || CvXSUB(sv))
1477 RETURNOP(cLOGOP->op_other);
1483 register I32 cxix = dopoptosub(cxstack_ix);
1484 register PERL_CONTEXT *cx;
1485 register PERL_CONTEXT *ccstack = cxstack;
1486 PERL_SI *top_si = PL_curstackinfo;
1497 /* we may be in a higher stacklevel, so dig down deeper */
1498 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1499 top_si = top_si->si_prev;
1500 ccstack = top_si->si_cxstack;
1501 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1504 if (GIMME != G_ARRAY) {
1510 if (PL_DBsub && cxix >= 0 &&
1511 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1515 cxix = dopoptosub_at(ccstack, cxix - 1);
1518 cx = &ccstack[cxix];
1519 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1520 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1521 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1522 field below is defined for any cx. */
1523 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1524 cx = &ccstack[dbcxix];
1527 stashname = CopSTASHPV(cx->blk_oldcop);
1528 if (GIMME != G_ARRAY) {
1531 PUSHs(&PL_sv_undef);
1534 sv_setpv(TARG, stashname);
1543 PUSHs(&PL_sv_undef);
1545 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1546 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1547 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1550 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1551 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1552 /* So is ccstack[dbcxix]. */
1555 gv_efullname3(sv, cvgv, Nullch);
1556 PUSHs(sv_2mortal(sv));
1557 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1560 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1561 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1565 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1566 PUSHs(sv_2mortal(newSViv(0)));
1568 gimme = (I32)cx->blk_gimme;
1569 if (gimme == G_VOID)
1570 PUSHs(&PL_sv_undef);
1572 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1573 if (CxTYPE(cx) == CXt_EVAL) {
1575 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1576 PUSHs(cx->blk_eval.cur_text);
1580 else if (cx->blk_eval.old_namesv) {
1581 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1584 /* eval BLOCK (try blocks have old_namesv == 0) */
1586 PUSHs(&PL_sv_undef);
1587 PUSHs(&PL_sv_undef);
1591 PUSHs(&PL_sv_undef);
1592 PUSHs(&PL_sv_undef);
1594 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1595 && CopSTASH_eq(PL_curcop, PL_debstash))
1597 AV *ary = cx->blk_sub.argarray;
1598 int off = AvARRAY(ary) - AvALLOC(ary);
1602 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1605 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1608 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1609 av_extend(PL_dbargs, AvFILLp(ary) + off);
1610 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1611 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1613 /* XXX only hints propagated via op_private are currently
1614 * visible (others are not easily accessible, since they
1615 * use the global PL_hints) */
1616 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1617 HINT_PRIVATE_MASK)));
1620 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1622 if (old_warnings == pWARN_NONE ||
1623 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1624 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1625 else if (old_warnings == pWARN_ALL ||
1626 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1627 /* Get the bit mask for $warnings::Bits{all}, because
1628 * it could have been extended by warnings::register */
1630 HV *bits = get_hv("warnings::Bits", FALSE);
1631 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1632 mask = newSVsv(*bits_all);
1635 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1639 mask = newSVsv(old_warnings);
1640 PUSHs(sv_2mortal(mask));
1655 sv_reset(tmps, CopSTASH(PL_curcop));
1665 /* like pp_nextstate, but used instead when the debugger is active */
1669 PL_curcop = (COP*)PL_op;
1670 TAINT_NOT; /* Each statement is presumed innocent */
1671 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1674 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1675 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1679 register PERL_CONTEXT *cx;
1680 I32 gimme = G_ARRAY;
1687 DIE(aTHX_ "No DB::DB routine defined");
1689 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1690 /* don't do recursive DB::DB call */
1702 push_return(PL_op->op_next);
1703 PUSHBLOCK(cx, CXt_SUB, SP);
1706 (void)SvREFCNT_inc(cv);
1707 PAD_SET_CUR(CvPADLIST(cv),1);
1708 RETURNOP(CvSTART(cv));
1722 register PERL_CONTEXT *cx;
1723 I32 gimme = GIMME_V;
1725 U32 cxtype = CXt_LOOP;
1733 if (PL_op->op_targ) {
1734 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1735 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1736 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1737 SVs_PADSTALE, SVs_PADSTALE);
1739 #ifndef USE_ITHREADS
1740 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1743 SAVEPADSV(PL_op->op_targ);
1744 iterdata = INT2PTR(void*, PL_op->op_targ);
1745 cxtype |= CXp_PADVAR;
1750 svp = &GvSV(gv); /* symbol table variable */
1751 SAVEGENERICSV(*svp);
1754 iterdata = (void*)gv;
1760 PUSHBLOCK(cx, cxtype, SP);
1762 PUSHLOOP(cx, iterdata, MARK);
1764 PUSHLOOP(cx, svp, MARK);
1766 if (PL_op->op_flags & OPf_STACKED) {
1767 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1768 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1770 /* See comment in pp_flop() */
1771 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1772 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1773 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1774 looks_like_number((SV*)cx->blk_loop.iterary)))
1776 if (SvNV(sv) < IV_MIN ||
1777 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1778 DIE(aTHX_ "Range iterator outside integer range");
1779 cx->blk_loop.iterix = SvIV(sv);
1780 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1783 cx->blk_loop.iterlval = newSVsv(sv);
1787 cx->blk_loop.iterary = PL_curstack;
1788 AvFILLp(PL_curstack) = SP - PL_stack_base;
1789 cx->blk_loop.iterix = MARK - PL_stack_base;
1798 register PERL_CONTEXT *cx;
1799 I32 gimme = GIMME_V;
1805 PUSHBLOCK(cx, CXt_LOOP, SP);
1806 PUSHLOOP(cx, 0, SP);
1814 register PERL_CONTEXT *cx;
1822 newsp = PL_stack_base + cx->blk_loop.resetsp;
1825 if (gimme == G_VOID)
1827 else if (gimme == G_SCALAR) {
1829 *++newsp = sv_mortalcopy(*SP);
1831 *++newsp = &PL_sv_undef;
1835 *++newsp = sv_mortalcopy(*++mark);
1836 TAINT_NOT; /* Each item is independent */
1842 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1843 PL_curpm = newpm; /* ... and pop $1 et al */
1855 register PERL_CONTEXT *cx;
1856 bool popsub2 = FALSE;
1857 bool clear_errsv = FALSE;
1864 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1865 if (cxstack_ix == PL_sortcxix
1866 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1868 if (cxstack_ix > PL_sortcxix)
1869 dounwind(PL_sortcxix);
1870 AvARRAY(PL_curstack)[1] = *SP;
1871 PL_stack_sp = PL_stack_base + 1;
1876 cxix = dopoptosub(cxstack_ix);
1878 DIE(aTHX_ "Can't return outside a subroutine");
1879 if (cxix < cxstack_ix)
1883 switch (CxTYPE(cx)) {
1886 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1889 if (!(PL_in_eval & EVAL_KEEPERR))
1895 if (optype == OP_REQUIRE &&
1896 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1898 /* Unassume the success we assumed earlier. */
1899 SV *nsv = cx->blk_eval.old_namesv;
1900 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1901 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1908 DIE(aTHX_ "panic: return");
1912 if (gimme == G_SCALAR) {
1915 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1917 *++newsp = SvREFCNT_inc(*SP);
1922 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1924 *++newsp = sv_mortalcopy(sv);
1929 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1932 *++newsp = sv_mortalcopy(*SP);
1935 *++newsp = &PL_sv_undef;
1937 else if (gimme == G_ARRAY) {
1938 while (++MARK <= SP) {
1939 *++newsp = (popsub2 && SvTEMP(*MARK))
1940 ? *MARK : sv_mortalcopy(*MARK);
1941 TAINT_NOT; /* Each item is independent */
1944 PL_stack_sp = newsp;
1947 /* Stack values are safe: */
1950 POPSUB(cx,sv); /* release CV and @_ ... */
1954 PL_curpm = newpm; /* ... and pop $1 et al */
1959 return pop_return();
1966 register PERL_CONTEXT *cx;
1976 if (PL_op->op_flags & OPf_SPECIAL) {
1977 cxix = dopoptoloop(cxstack_ix);
1979 DIE(aTHX_ "Can't \"last\" outside a loop block");
1982 cxix = dopoptolabel(cPVOP->op_pv);
1984 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1986 if (cxix < cxstack_ix)
1990 cxstack_ix++; /* temporarily protect top context */
1992 switch (CxTYPE(cx)) {
1995 newsp = PL_stack_base + cx->blk_loop.resetsp;
1996 nextop = cx->blk_loop.last_op->op_next;
2000 nextop = pop_return();
2004 nextop = pop_return();
2008 nextop = pop_return();
2011 DIE(aTHX_ "panic: last");
2015 if (gimme == G_SCALAR) {
2017 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2018 ? *SP : sv_mortalcopy(*SP);
2020 *++newsp = &PL_sv_undef;
2022 else if (gimme == G_ARRAY) {
2023 while (++MARK <= SP) {
2024 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2025 ? *MARK : sv_mortalcopy(*MARK);
2026 TAINT_NOT; /* Each item is independent */
2034 /* Stack values are safe: */
2037 POPLOOP(cx); /* release loop vars ... */
2041 POPSUB(cx,sv); /* release CV and @_ ... */
2044 PL_curpm = newpm; /* ... and pop $1 et al */
2053 register PERL_CONTEXT *cx;
2056 if (PL_op->op_flags & OPf_SPECIAL) {
2057 cxix = dopoptoloop(cxstack_ix);
2059 DIE(aTHX_ "Can't \"next\" outside a loop block");
2062 cxix = dopoptolabel(cPVOP->op_pv);
2064 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2066 if (cxix < cxstack_ix)
2069 /* clear off anything above the scope we're re-entering, but
2070 * save the rest until after a possible continue block */
2071 inner = PL_scopestack_ix;
2073 if (PL_scopestack_ix < inner)
2074 leave_scope(PL_scopestack[PL_scopestack_ix]);
2075 return cx->blk_loop.next_op;
2081 register PERL_CONTEXT *cx;
2084 if (PL_op->op_flags & OPf_SPECIAL) {
2085 cxix = dopoptoloop(cxstack_ix);
2087 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2090 cxix = dopoptolabel(cPVOP->op_pv);
2092 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2094 if (cxix < cxstack_ix)
2098 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2099 LEAVE_SCOPE(oldsave);
2100 return cx->blk_loop.redo_op;
2104 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2108 static char too_deep[] = "Target of goto is too deeply nested";
2111 Perl_croak(aTHX_ too_deep);
2112 if (o->op_type == OP_LEAVE ||
2113 o->op_type == OP_SCOPE ||
2114 o->op_type == OP_LEAVELOOP ||
2115 o->op_type == OP_LEAVESUB ||
2116 o->op_type == OP_LEAVETRY)
2118 *ops++ = cUNOPo->op_first;
2120 Perl_croak(aTHX_ too_deep);
2123 if (o->op_flags & OPf_KIDS) {
2124 /* First try all the kids at this level, since that's likeliest. */
2125 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2126 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2127 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2130 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2131 if (kid == PL_lastgotoprobe)
2133 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2136 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2137 ops[-1]->op_type == OP_DBSTATE)
2142 if ((o = dofindlabel(kid, label, ops, oplimit)))
2161 register PERL_CONTEXT *cx;
2162 #define GOTO_DEPTH 64
2163 OP *enterops[GOTO_DEPTH];
2165 int do_dump = (PL_op->op_type == OP_DUMP);
2166 static char must_have_label[] = "goto must have label";
2169 if (PL_op->op_flags & OPf_STACKED) {
2173 /* This egregious kludge implements goto &subroutine */
2174 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2176 register PERL_CONTEXT *cx;
2177 CV* cv = (CV*)SvRV(sv);
2183 if (!CvROOT(cv) && !CvXSUB(cv)) {
2188 /* autoloaded stub? */
2189 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2191 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2192 GvNAMELEN(gv), FALSE);
2193 if (autogv && (cv = GvCV(autogv)))
2195 tmpstr = sv_newmortal();
2196 gv_efullname3(tmpstr, gv, Nullch);
2197 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2199 DIE(aTHX_ "Goto undefined subroutine");
2202 /* First do some returnish stuff. */
2203 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2205 cxix = dopoptosub(cxstack_ix);
2207 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2208 if (cxix < cxstack_ix)
2212 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2214 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2215 /* put @_ back onto stack */
2216 AV* av = cx->blk_sub.argarray;
2218 items = AvFILLp(av) + 1;
2220 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2221 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2222 PL_stack_sp += items;
2223 SvREFCNT_dec(GvAV(PL_defgv));
2224 GvAV(PL_defgv) = cx->blk_sub.savearray;
2225 /* abandon @_ if it got reified */
2227 (void)sv_2mortal((SV*)av); /* delay until return */
2229 av_extend(av, items-1);
2230 AvFLAGS(av) = AVf_REIFY;
2231 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. */
2253 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2255 #ifdef PERL_XSUB_OLDSTYLE
2256 if (CvOLDSTYLE(cv)) {
2257 I32 (*fp3)(int,int,int);
2262 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2263 items = (*fp3)(CvXSUBANY(cv).any_i32,
2264 mark - PL_stack_base + 1,
2266 SP = PL_stack_base + items;
2269 #endif /* PERL_XSUB_OLDSTYLE */
2274 PL_stack_sp--; /* There is no cv arg. */
2275 /* Push a mark for the start of arglist */
2277 (void)(*CvXSUB(cv))(aTHX_ cv);
2278 /* Pop the current context like a decent sub should */
2279 POPBLOCK(cx, PL_curpm);
2280 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2283 return pop_return();
2286 AV* padlist = CvPADLIST(cv);
2287 if (CxTYPE(cx) == CXt_EVAL) {
2288 PL_in_eval = cx->blk_eval.old_in_eval;
2289 PL_eval_root = cx->blk_eval.old_eval_root;
2290 cx->cx_type = CXt_SUB;
2291 cx->blk_sub.hasargs = 0;
2293 cx->blk_sub.cv = cv;
2294 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2297 if (CvDEPTH(cv) < 2)
2298 (void)SvREFCNT_inc(cv);
2300 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2301 sub_crush_depth(cv);
2302 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2304 PAD_SET_CUR(padlist, CvDEPTH(cv));
2305 if (cx->blk_sub.hasargs)
2307 AV* av = (AV*)PAD_SVl(0);
2310 cx->blk_sub.savearray = GvAV(PL_defgv);
2311 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2312 CX_CURPAD_SAVE(cx->blk_sub);
2313 cx->blk_sub.argarray = av;
2316 if (items >= AvMAX(av) + 1) {
2318 if (AvARRAY(av) != ary) {
2319 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2320 SvPVX(av) = (char*)ary;
2322 if (items >= AvMAX(av) + 1) {
2323 AvMAX(av) = items - 1;
2324 Renew(ary,items+1,SV*);
2326 SvPVX(av) = (char*)ary;
2329 Copy(mark,AvARRAY(av),items,SV*);
2330 AvFILLp(av) = items - 1;
2331 assert(!AvREAL(av));
2338 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2340 * We do not care about using sv to call CV;
2341 * it's for informational purposes only.
2343 SV *sv = GvSV(PL_DBsub);
2346 if (PERLDB_SUB_NN) {
2347 (void)SvUPGRADE(sv, SVt_PVIV);
2350 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2353 gv_efullname3(sv, CvGV(cv), Nullch);
2356 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2357 PUSHMARK( PL_stack_sp );
2358 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2362 RETURNOP(CvSTART(cv));
2366 label = SvPV(sv,n_a);
2367 if (!(do_dump || *label))
2368 DIE(aTHX_ must_have_label);
2371 else if (PL_op->op_flags & OPf_SPECIAL) {
2373 DIE(aTHX_ must_have_label);
2376 label = cPVOP->op_pv;
2378 if (label && *label) {
2380 bool leaving_eval = FALSE;
2381 bool in_block = FALSE;
2382 PERL_CONTEXT *last_eval_cx = 0;
2386 PL_lastgotoprobe = 0;
2388 for (ix = cxstack_ix; ix >= 0; ix--) {
2390 switch (CxTYPE(cx)) {
2392 leaving_eval = TRUE;
2393 if (!CxTRYBLOCK(cx)) {
2394 gotoprobe = (last_eval_cx ?
2395 last_eval_cx->blk_eval.old_eval_root :
2400 /* else fall through */
2402 gotoprobe = cx->blk_oldcop->op_sibling;
2408 gotoprobe = cx->blk_oldcop->op_sibling;
2411 gotoprobe = PL_main_root;
2414 if (CvDEPTH(cx->blk_sub.cv)) {
2415 gotoprobe = CvROOT(cx->blk_sub.cv);
2421 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2424 DIE(aTHX_ "panic: goto");
2425 gotoprobe = PL_main_root;
2429 retop = dofindlabel(gotoprobe, label,
2430 enterops, enterops + GOTO_DEPTH);
2434 PL_lastgotoprobe = gotoprobe;
2437 DIE(aTHX_ "Can't find label %s", label);
2439 /* if we're leaving an eval, check before we pop any frames
2440 that we're not going to punt, otherwise the error
2443 if (leaving_eval && *enterops && enterops[1]) {
2445 for (i = 1; enterops[i]; i++)
2446 if (enterops[i]->op_type == OP_ENTERITER)
2447 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2450 /* pop unwanted frames */
2452 if (ix < cxstack_ix) {
2459 oldsave = PL_scopestack[PL_scopestack_ix];
2460 LEAVE_SCOPE(oldsave);
2463 /* push wanted frames */
2465 if (*enterops && enterops[1]) {
2467 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2468 for (; enterops[ix]; ix++) {
2469 PL_op = enterops[ix];
2470 /* Eventually we may want to stack the needed arguments
2471 * for each op. For now, we punt on the hard ones. */
2472 if (PL_op->op_type == OP_ENTERITER)
2473 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2474 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2482 if (!retop) retop = PL_main_start;
2484 PL_restartop = retop;
2485 PL_do_undump = TRUE;
2489 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2490 PL_do_undump = FALSE;
2506 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2508 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2511 PL_exit_flags |= PERL_EXIT_EXPECTED;
2513 PUSHs(&PL_sv_undef);
2521 NV value = SvNVx(GvSV(cCOP->cop_gv));
2522 register I32 match = I_32(value);
2525 if (((NV)match) > value)
2526 --match; /* was fractional--truncate other way */
2528 match -= cCOP->uop.scop.scop_offset;
2531 else if (match > cCOP->uop.scop.scop_max)
2532 match = cCOP->uop.scop.scop_max;
2533 PL_op = cCOP->uop.scop.scop_next[match];
2543 PL_op = PL_op->op_next; /* can't assume anything */
2546 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2547 match -= cCOP->uop.scop.scop_offset;
2550 else if (match > cCOP->uop.scop.scop_max)
2551 match = cCOP->uop.scop.scop_max;
2552 PL_op = cCOP->uop.scop.scop_next[match];
2561 S_save_lines(pTHX_ AV *array, SV *sv)
2563 register char *s = SvPVX(sv);
2564 register char *send = SvPVX(sv) + SvCUR(sv);
2566 register I32 line = 1;
2568 while (s && s < send) {
2569 SV *tmpstr = NEWSV(85,0);
2571 sv_upgrade(tmpstr, SVt_PVMG);
2572 t = strchr(s, '\n');
2578 sv_setpvn(tmpstr, s, t - s);
2579 av_store(array, line++, tmpstr);
2584 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2586 S_docatch_body(pTHX_ va_list args)
2588 return docatch_body();
2593 S_docatch_body(pTHX)
2600 S_docatch(pTHX_ OP *o)
2605 volatile PERL_SI *cursi = PL_curstackinfo;
2609 assert(CATCH_GET == TRUE);
2613 /* Normally, the leavetry at the end of this block of ops will
2614 * pop an op off the return stack and continue there. By setting
2615 * the op to Nullop, we force an exit from the inner runops()
2618 retop = pop_return();
2619 push_return(Nullop);
2621 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2623 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2629 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2635 /* die caught by an inner eval - continue inner loop */
2636 if (PL_restartop && cursi == PL_curstackinfo) {
2637 PL_op = PL_restartop;
2641 /* a die in this eval - continue in outer loop */
2657 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2658 /* sv Text to convert to OP tree. */
2659 /* startop op_free() this to undo. */
2660 /* code Short string id of the caller. */
2662 dSP; /* Make POPBLOCK work. */
2665 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2669 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2670 char *tmpbuf = tbuf;
2673 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2678 /* switch to eval mode */
2680 if (IN_PERL_COMPILETIME) {
2681 SAVECOPSTASH_FREE(&PL_compiling);
2682 CopSTASH_set(&PL_compiling, PL_curstash);
2684 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2685 SV *sv = sv_newmortal();
2686 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2687 code, (unsigned long)++PL_evalseq,
2688 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2692 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2693 SAVECOPFILE_FREE(&PL_compiling);
2694 CopFILE_set(&PL_compiling, tmpbuf+2);
2695 SAVECOPLINE(&PL_compiling);
2696 CopLINE_set(&PL_compiling, 1);
2697 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2698 deleting the eval's FILEGV from the stash before gv_check() runs
2699 (i.e. before run-time proper). To work around the coredump that
2700 ensues, we always turn GvMULTI_on for any globals that were
2701 introduced within evals. See force_ident(). GSAR 96-10-12 */
2702 safestr = savepv(tmpbuf);
2703 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2705 #ifdef OP_IN_REGISTER
2710 PL_hints &= HINT_UTF8;
2712 /* we get here either during compilation, or via pp_regcomp at runtime */
2713 runtime = IN_PERL_RUNTIME;
2715 runcv = find_runcv(NULL);
2718 PL_op->op_type = OP_ENTEREVAL;
2719 PL_op->op_flags = 0; /* Avoid uninit warning. */
2720 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2721 PUSHEVAL(cx, 0, Nullgv);
2724 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2726 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2727 POPBLOCK(cx,PL_curpm);
2730 (*startop)->op_type = OP_NULL;
2731 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2733 /* XXX DAPM do this properly one year */
2734 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2736 if (IN_PERL_COMPILETIME)
2737 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2738 #ifdef OP_IN_REGISTER
2746 =for apidoc find_runcv
2748 Locate the CV corresponding to the currently executing sub or eval.
2749 If db_seqp is non_null, skip CVs that are in the DB package and populate
2750 *db_seqp with the cop sequence number at the point that the DB:: code was
2751 entered. (allows debuggers to eval in the scope of the breakpoint rather
2752 than in in the scope of the debuger itself).
2758 Perl_find_runcv(pTHX_ U32 *db_seqp)
2765 *db_seqp = PL_curcop->cop_seq;
2766 for (si = PL_curstackinfo; si; si = si->si_prev) {
2767 for (ix = si->si_cxix; ix >= 0; ix--) {
2768 cx = &(si->si_cxstack[ix]);
2769 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2770 CV *cv = cx->blk_sub.cv;
2771 /* skip DB:: code */
2772 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2773 *db_seqp = cx->blk_oldcop->cop_seq;
2778 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2786 /* Compile a require/do, an eval '', or a /(?{...})/.
2787 * In the last case, startop is non-null, and contains the address of
2788 * a pointer that should be set to the just-compiled code.
2789 * outside is the lexically enclosing CV (if any) that invoked us.
2792 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2794 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2799 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2800 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2805 SAVESPTR(PL_compcv);
2806 PL_compcv = (CV*)NEWSV(1104,0);
2807 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2808 CvEVAL_on(PL_compcv);
2809 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2810 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2812 CvOUTSIDE_SEQ(PL_compcv) = seq;
2813 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2815 /* set up a scratch pad */
2817 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2820 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2822 /* make sure we compile in the right package */
2824 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2825 SAVESPTR(PL_curstash);
2826 PL_curstash = CopSTASH(PL_curcop);
2828 SAVESPTR(PL_beginav);
2829 PL_beginav = newAV();
2830 SAVEFREESV(PL_beginav);
2831 SAVEI32(PL_error_count);
2833 /* try to compile it */
2835 PL_eval_root = Nullop;
2837 PL_curcop = &PL_compiling;
2838 PL_curcop->cop_arybase = 0;
2839 if (saveop && saveop->op_flags & OPf_SPECIAL)
2840 PL_in_eval |= EVAL_KEEPERR;
2843 if (yyparse() || PL_error_count || !PL_eval_root) {
2844 SV **newsp; /* Used by POPBLOCK. */
2846 I32 optype = 0; /* Might be reset by POPEVAL. */
2851 op_free(PL_eval_root);
2852 PL_eval_root = Nullop;
2854 SP = PL_stack_base + POPMARK; /* pop original mark */
2856 POPBLOCK(cx,PL_curpm);
2862 if (optype == OP_REQUIRE) {
2863 char* msg = SvPVx(ERRSV, n_a);
2864 DIE(aTHX_ "%sCompilation failed in require",
2865 *msg ? msg : "Unknown error\n");
2868 char* msg = SvPVx(ERRSV, n_a);
2870 POPBLOCK(cx,PL_curpm);
2872 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2873 (*msg ? msg : "Unknown error\n"));
2876 char* msg = SvPVx(ERRSV, n_a);
2878 sv_setpv(ERRSV, "Compilation error");
2883 CopLINE_set(&PL_compiling, 0);
2885 *startop = PL_eval_root;
2887 SAVEFREEOP(PL_eval_root);
2889 /* Set the context for this new optree.
2890 * If the last op is an OP_REQUIRE, force scalar context.
2891 * Otherwise, propagate the context from the eval(). */
2892 if (PL_eval_root->op_type == OP_LEAVEEVAL
2893 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2894 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2896 scalar(PL_eval_root);
2897 else if (gimme & G_VOID)
2898 scalarvoid(PL_eval_root);
2899 else if (gimme & G_ARRAY)
2902 scalar(PL_eval_root);
2904 DEBUG_x(dump_eval());
2906 /* Register with debugger: */
2907 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2908 CV *cv = get_cv("DB::postponed", FALSE);
2912 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2914 call_sv((SV*)cv, G_DISCARD);
2918 /* compiled okay, so do it */
2920 CvDEPTH(PL_compcv) = 1;
2921 SP = PL_stack_base + POPMARK; /* pop original mark */
2922 PL_op = saveop; /* The caller may need it. */
2923 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2925 RETURNOP(PL_eval_start);
2929 S_doopen_pm(pTHX_ const char *name, const char *mode)
2931 #ifndef PERL_DISABLE_PMC
2932 STRLEN namelen = strlen(name);
2935 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2936 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2937 char *pmc = SvPV_nolen(pmcsv);
2940 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2941 fp = PerlIO_open(name, mode);
2944 if (PerlLIO_stat(name, &pmstat) < 0 ||
2945 pmstat.st_mtime < pmcstat.st_mtime)
2947 fp = PerlIO_open(pmc, mode);
2950 fp = PerlIO_open(name, mode);
2953 SvREFCNT_dec(pmcsv);
2956 fp = PerlIO_open(name, mode);
2960 return PerlIO_open(name, mode);
2961 #endif /* !PERL_DISABLE_PMC */
2967 register PERL_CONTEXT *cx;
2971 char *tryname = Nullch;
2972 SV *namesv = Nullsv;
2974 I32 gimme = GIMME_V;
2975 PerlIO *tryrsfp = 0;
2977 int filter_has_file = 0;
2978 GV *filter_child_proc = 0;
2979 SV *filter_state = 0;
2986 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2987 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2988 UV rev = 0, ver = 0, sver = 0;
2990 U8 *s = (U8*)SvPVX(sv);
2991 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2993 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2996 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2999 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3002 if (PERL_REVISION < rev
3003 || (PERL_REVISION == rev
3004 && (PERL_VERSION < ver
3005 || (PERL_VERSION == ver
3006 && PERL_SUBVERSION < sver))))
3008 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3009 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3010 PERL_VERSION, PERL_SUBVERSION);
3012 if (ckWARN(WARN_PORTABLE))
3013 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3014 "v-string in use/require non-portable");
3017 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3018 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3019 + ((NV)PERL_SUBVERSION/(NV)1000000)
3020 + 0.00000099 < SvNV(sv))
3024 NV nver = (nrev - rev) * 1000;
3025 UV ver = (UV)(nver + 0.0009);
3026 NV nsver = (nver - ver) * 1000;
3027 UV sver = (UV)(nsver + 0.0009);
3029 /* help out with the "use 5.6" confusion */
3030 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3031 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3032 " (did you mean v%"UVuf".%03"UVuf"?)--"
3033 "this is only v%d.%d.%d, stopped",
3034 rev, ver, sver, rev, ver/100,
3035 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3038 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3039 "this is only v%d.%d.%d, stopped",
3040 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3047 name = SvPV(sv, len);
3048 if (!(name && len > 0 && *name))
3049 DIE(aTHX_ "Null filename used");
3050 TAINT_PROPER("require");
3051 if (PL_op->op_type == OP_REQUIRE &&
3052 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3053 *svp != &PL_sv_undef)
3056 /* prepare to compile file */
3058 if (path_is_absolute(name)) {
3060 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3062 #ifdef MACOS_TRADITIONAL
3066 MacPerl_CanonDir(name, newname, 1);
3067 if (path_is_absolute(newname)) {
3069 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3074 AV *ar = GvAVn(PL_incgv);
3078 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3081 namesv = NEWSV(806, 0);
3082 for (i = 0; i <= AvFILL(ar); i++) {
3083 SV *dirsv = *av_fetch(ar, i, TRUE);
3089 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3090 && !sv_isobject(loader))
3092 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3095 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3096 PTR2UV(SvRV(dirsv)), name);
3097 tryname = SvPVX(namesv);
3108 if (sv_isobject(loader))
3109 count = call_method("INC", G_ARRAY);
3111 count = call_sv(loader, G_ARRAY);
3121 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3125 if (SvTYPE(arg) == SVt_PVGV) {
3126 IO *io = GvIO((GV *)arg);
3131 tryrsfp = IoIFP(io);
3132 if (IoTYPE(io) == IoTYPE_PIPE) {
3133 /* reading from a child process doesn't
3134 nest -- when returning from reading
3135 the inner module, the outer one is
3136 unreadable (closed?) I've tried to
3137 save the gv to manage the lifespan of
3138 the pipe, but this didn't help. XXX */
3139 filter_child_proc = (GV *)arg;
3140 (void)SvREFCNT_inc(filter_child_proc);
3143 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3144 PerlIO_close(IoOFP(io));
3156 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3158 (void)SvREFCNT_inc(filter_sub);
3161 filter_state = SP[i];
3162 (void)SvREFCNT_inc(filter_state);
3166 tryrsfp = PerlIO_open("/dev/null",
3181 filter_has_file = 0;
3182 if (filter_child_proc) {
3183 SvREFCNT_dec(filter_child_proc);
3184 filter_child_proc = 0;
3187 SvREFCNT_dec(filter_state);
3191 SvREFCNT_dec(filter_sub);
3196 if (!path_is_absolute(name)
3197 #ifdef MACOS_TRADITIONAL
3198 /* We consider paths of the form :a:b ambiguous and interpret them first
3199 as global then as local
3201 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3204 char *dir = SvPVx(dirsv, n_a);
3205 #ifdef MACOS_TRADITIONAL
3209 MacPerl_CanonDir(name, buf2, 1);
3210 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3214 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3216 sv_setpv(namesv, unixdir);
3217 sv_catpv(namesv, unixname);
3219 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3222 TAINT_PROPER("require");
3223 tryname = SvPVX(namesv);
3224 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3226 if (tryname[0] == '.' && tryname[1] == '/')
3235 SAVECOPFILE_FREE(&PL_compiling);
3236 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3237 SvREFCNT_dec(namesv);
3239 if (PL_op->op_type == OP_REQUIRE) {
3240 char *msgstr = name;
3241 if (namesv) { /* did we lookup @INC? */
3242 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3243 SV *dirmsgsv = NEWSV(0, 0);
3244 AV *ar = GvAVn(PL_incgv);
3246 sv_catpvn(msg, " in @INC", 8);
3247 if (instr(SvPVX(msg), ".h "))
3248 sv_catpv(msg, " (change .h to .ph maybe?)");
3249 if (instr(SvPVX(msg), ".ph "))
3250 sv_catpv(msg, " (did you run h2ph?)");
3251 sv_catpv(msg, " (@INC contains:");
3252 for (i = 0; i <= AvFILL(ar); i++) {
3253 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3254 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3255 sv_catsv(msg, dirmsgsv);
3257 sv_catpvn(msg, ")", 1);
3258 SvREFCNT_dec(dirmsgsv);
3259 msgstr = SvPV_nolen(msg);
3261 DIE(aTHX_ "Can't locate %s", msgstr);
3267 SETERRNO(0, SS_NORMAL);
3269 /* Assume success here to prevent recursive requirement. */
3271 /* Check whether a hook in @INC has already filled %INC */
3272 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3273 (void)hv_store(GvHVn(PL_incgv), name, len,
3274 (hook_sv ? SvREFCNT_inc(hook_sv)
3275 : newSVpv(CopFILE(&PL_compiling), 0)),
3281 lex_start(sv_2mortal(newSVpvn("",0)));
3282 SAVEGENERICSV(PL_rsfp_filters);
3283 PL_rsfp_filters = Nullav;
3288 SAVESPTR(PL_compiling.cop_warnings);
3289 if (PL_dowarn & G_WARN_ALL_ON)
3290 PL_compiling.cop_warnings = pWARN_ALL ;
3291 else if (PL_dowarn & G_WARN_ALL_OFF)
3292 PL_compiling.cop_warnings = pWARN_NONE ;
3293 else if (PL_taint_warn)
3294 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3296 PL_compiling.cop_warnings = pWARN_STD ;
3297 SAVESPTR(PL_compiling.cop_io);
3298 PL_compiling.cop_io = Nullsv;
3300 if (filter_sub || filter_child_proc) {
3301 SV *datasv = filter_add(run_user_filter, Nullsv);
3302 IoLINES(datasv) = filter_has_file;
3303 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3304 IoTOP_GV(datasv) = (GV *)filter_state;
3305 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3308 /* switch to eval mode */
3309 push_return(PL_op->op_next);
3310 PUSHBLOCK(cx, CXt_EVAL, SP);
3311 PUSHEVAL(cx, name, Nullgv);
3313 SAVECOPLINE(&PL_compiling);
3314 CopLINE_set(&PL_compiling, 0);
3318 /* Store and reset encoding. */
3319 encoding = PL_encoding;
3320 PL_encoding = Nullsv;
3322 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3324 /* Restore encoding. */
3325 PL_encoding = encoding;
3332 return pp_require();
3338 register PERL_CONTEXT *cx;
3340 I32 gimme = GIMME_V, was = PL_sub_generation;
3341 char tbuf[TYPE_DIGITS(long) + 12];
3342 char *tmpbuf = tbuf;
3351 TAINT_PROPER("eval");
3357 /* switch to eval mode */
3359 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3360 SV *sv = sv_newmortal();
3361 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3362 (unsigned long)++PL_evalseq,
3363 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3367 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3368 SAVECOPFILE_FREE(&PL_compiling);
3369 CopFILE_set(&PL_compiling, tmpbuf+2);
3370 SAVECOPLINE(&PL_compiling);
3371 CopLINE_set(&PL_compiling, 1);
3372 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3373 deleting the eval's FILEGV from the stash before gv_check() runs
3374 (i.e. before run-time proper). To work around the coredump that
3375 ensues, we always turn GvMULTI_on for any globals that were
3376 introduced within evals. See force_ident(). GSAR 96-10-12 */
3377 safestr = savepv(tmpbuf);
3378 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3380 PL_hints = PL_op->op_targ;
3381 SAVESPTR(PL_compiling.cop_warnings);
3382 if (specialWARN(PL_curcop->cop_warnings))
3383 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3385 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3386 SAVEFREESV(PL_compiling.cop_warnings);
3388 SAVESPTR(PL_compiling.cop_io);
3389 if (specialCopIO(PL_curcop->cop_io))
3390 PL_compiling.cop_io = PL_curcop->cop_io;
3392 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3393 SAVEFREESV(PL_compiling.cop_io);
3395 /* special case: an eval '' executed within the DB package gets lexically
3396 * placed in the first non-DB CV rather than the current CV - this
3397 * allows the debugger to execute code, find lexicals etc, in the
3398 * scope of the code being debugged. Passing &seq gets find_runcv
3399 * to do the dirty work for us */
3400 runcv = find_runcv(&seq);
3402 push_return(PL_op->op_next);
3403 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3404 PUSHEVAL(cx, 0, Nullgv);
3406 /* prepare to compile string */
3408 if (PERLDB_LINE && PL_curstash != PL_debstash)
3409 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3411 ret = doeval(gimme, NULL, runcv, seq);
3412 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3413 && ret != PL_op->op_next) { /* Successive compilation. */
3414 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3416 return DOCATCH(ret);
3426 register PERL_CONTEXT *cx;
3428 U8 save_flags = PL_op -> op_flags;
3433 retop = pop_return();
3436 if (gimme == G_VOID)
3438 else if (gimme == G_SCALAR) {
3441 if (SvFLAGS(TOPs) & SVs_TEMP)
3444 *MARK = sv_mortalcopy(TOPs);
3448 *MARK = &PL_sv_undef;
3453 /* in case LEAVE wipes old return values */
3454 for (mark = newsp + 1; mark <= SP; mark++) {
3455 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3456 *mark = sv_mortalcopy(*mark);
3457 TAINT_NOT; /* Each item is independent */
3461 PL_curpm = newpm; /* Don't pop $1 et al till now */
3464 assert(CvDEPTH(PL_compcv) == 1);
3466 CvDEPTH(PL_compcv) = 0;
3469 if (optype == OP_REQUIRE &&
3470 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3472 /* Unassume the success we assumed earlier. */
3473 SV *nsv = cx->blk_eval.old_namesv;
3474 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3475 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3476 /* die_where() did LEAVE, or we won't be here */
3480 if (!(save_flags & OPf_SPECIAL))
3490 register PERL_CONTEXT *cx;
3491 I32 gimme = GIMME_V;
3496 push_return(cLOGOP->op_other->op_next);
3497 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3500 PL_in_eval = EVAL_INEVAL;
3503 return DOCATCH(PL_op->op_next);
3514 register PERL_CONTEXT *cx;
3519 retop = pop_return();
3522 if (gimme == G_VOID)
3524 else if (gimme == G_SCALAR) {
3527 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3530 *MARK = sv_mortalcopy(TOPs);
3534 *MARK = &PL_sv_undef;
3539 /* in case LEAVE wipes old return values */
3540 for (mark = newsp + 1; mark <= SP; mark++) {
3541 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3542 *mark = sv_mortalcopy(*mark);
3543 TAINT_NOT; /* Each item is independent */
3547 PL_curpm = newpm; /* Don't pop $1 et al till now */
3555 S_doparseform(pTHX_ SV *sv)
3558 register char *s = SvPV_force(sv, len);
3559 register char *send = s + len;
3560 register char *base = Nullch;
3561 register I32 skipspaces = 0;
3562 bool noblank = FALSE;
3563 bool repeat = FALSE;
3564 bool postspace = FALSE;
3570 int maxops = 2; /* FF_LINEMARK + FF_END) */
3573 Perl_croak(aTHX_ "Null picture in formline");
3575 /* estimate the buffer size needed */
3576 for (base = s; s <= send; s++) {
3577 if (*s == '\n' || *s == '@' || *s == '^')
3583 New(804, fops, maxops, U32);
3588 *fpc++ = FF_LINEMARK;
3589 noblank = repeat = FALSE;
3607 case ' ': case '\t':
3618 *fpc++ = FF_LITERAL;
3626 *fpc++ = (U16)skipspaces;
3630 *fpc++ = FF_NEWLINE;
3634 arg = fpc - linepc + 1;
3641 *fpc++ = FF_LINEMARK;
3642 noblank = repeat = FALSE;
3651 ischop = s[-1] == '^';
3657 arg = (s - base) - 1;
3659 *fpc++ = FF_LITERAL;
3668 *fpc++ = FF_LINEGLOB;
3670 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3671 arg = ischop ? 512 : 0;
3681 arg |= 256 + (s - f);
3683 *fpc++ = s - base; /* fieldsize for FETCH */
3684 *fpc++ = FF_DECIMAL;
3687 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3688 arg = ischop ? 512 : 0;
3690 s++; /* skip the '0' first */
3699 arg |= 256 + (s - f);
3701 *fpc++ = s - base; /* fieldsize for FETCH */
3702 *fpc++ = FF_0DECIMAL;
3707 bool ismore = FALSE;
3710 while (*++s == '>') ;
3711 prespace = FF_SPACE;
3713 else if (*s == '|') {
3714 while (*++s == '|') ;
3715 prespace = FF_HALFSPACE;
3720 while (*++s == '<') ;
3723 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3727 *fpc++ = s - base; /* fieldsize for FETCH */
3729 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3732 *fpc++ = (U16)prespace;
3746 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3748 { /* need to jump to the next word */
3750 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3751 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3752 s = SvPVX(sv) + SvCUR(sv) + z;
3754 Copy(fops, s, arg, U32);
3756 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3761 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3763 SV *datasv = FILTER_DATA(idx);
3764 int filter_has_file = IoLINES(datasv);
3765 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3766 SV *filter_state = (SV *)IoTOP_GV(datasv);
3767 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3770 /* I was having segfault trouble under Linux 2.2.5 after a
3771 parse error occured. (Had to hack around it with a test
3772 for PL_error_count == 0.) Solaris doesn't segfault --
3773 not sure where the trouble is yet. XXX */
3775 if (filter_has_file) {
3776 len = FILTER_READ(idx+1, buf_sv, maxlen);
3779 if (filter_sub && len >= 0) {
3790 PUSHs(sv_2mortal(newSViv(maxlen)));
3792 PUSHs(filter_state);
3795 count = call_sv(filter_sub, G_SCALAR);
3811 IoLINES(datasv) = 0;
3812 if (filter_child_proc) {
3813 SvREFCNT_dec(filter_child_proc);
3814 IoFMT_GV(datasv) = Nullgv;
3817 SvREFCNT_dec(filter_state);
3818 IoTOP_GV(datasv) = Nullgv;
3821 SvREFCNT_dec(filter_sub);
3822 IoBOTTOM_GV(datasv) = Nullgv;
3824 filter_del(run_user_filter);
3830 /* perhaps someone can come up with a better name for
3831 this? it is not really "absolute", per se ... */
3833 S_path_is_absolute(pTHX_ char *name)
3835 if (PERL_FILE_IS_ABSOLUTE(name)
3836 #ifdef MACOS_TRADITIONAL
3839 || (*name == '.' && (name[1] == '/' ||
3840 (name[1] == '.' && name[2] == '/'))))