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 */
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 */
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) {
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)) {
1888 if (!(PL_in_eval & EVAL_KEEPERR))
1894 if (optype == OP_REQUIRE &&
1895 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1897 /* Unassume the success we assumed earlier. */
1898 SV *nsv = cx->blk_eval.old_namesv;
1899 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1900 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1907 DIE(aTHX_ "panic: return");
1911 if (gimme == G_SCALAR) {
1914 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1916 *++newsp = SvREFCNT_inc(*SP);
1921 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1923 *++newsp = sv_mortalcopy(sv);
1928 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1931 *++newsp = sv_mortalcopy(*SP);
1934 *++newsp = &PL_sv_undef;
1936 else if (gimme == G_ARRAY) {
1937 while (++MARK <= SP) {
1938 *++newsp = (popsub2 && SvTEMP(*MARK))
1939 ? *MARK : sv_mortalcopy(*MARK);
1940 TAINT_NOT; /* Each item is independent */
1943 PL_stack_sp = newsp;
1945 /* Stack values are safe: */
1947 POPSUB(cx,sv); /* release CV and @_ ... */
1951 PL_curpm = newpm; /* ... and pop $1 et al */
1957 return pop_return();
1964 register PERL_CONTEXT *cx;
1974 if (PL_op->op_flags & OPf_SPECIAL) {
1975 cxix = dopoptoloop(cxstack_ix);
1977 DIE(aTHX_ "Can't \"last\" outside a loop block");
1980 cxix = dopoptolabel(cPVOP->op_pv);
1982 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1984 if (cxix < cxstack_ix)
1989 switch (CxTYPE(cx)) {
1992 newsp = PL_stack_base + cx->blk_loop.resetsp;
1993 nextop = cx->blk_loop.last_op->op_next;
1997 nextop = pop_return();
2001 nextop = pop_return();
2005 nextop = pop_return();
2008 DIE(aTHX_ "panic: last");
2012 if (gimme == G_SCALAR) {
2014 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2015 ? *SP : sv_mortalcopy(*SP);
2017 *++newsp = &PL_sv_undef;
2019 else if (gimme == G_ARRAY) {
2020 while (++MARK <= SP) {
2021 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2022 ? *MARK : sv_mortalcopy(*MARK);
2023 TAINT_NOT; /* Each item is independent */
2029 /* Stack values are safe: */
2032 POPLOOP(cx); /* release loop vars ... */
2036 POPSUB(cx,sv); /* release CV and @_ ... */
2039 PL_curpm = newpm; /* ... and pop $1 et al */
2049 register PERL_CONTEXT *cx;
2052 if (PL_op->op_flags & OPf_SPECIAL) {
2053 cxix = dopoptoloop(cxstack_ix);
2055 DIE(aTHX_ "Can't \"next\" outside a loop block");
2058 cxix = dopoptolabel(cPVOP->op_pv);
2060 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2062 if (cxix < cxstack_ix)
2065 /* clear off anything above the scope we're re-entering, but
2066 * save the rest until after a possible continue block */
2067 inner = PL_scopestack_ix;
2069 if (PL_scopestack_ix < inner)
2070 leave_scope(PL_scopestack[PL_scopestack_ix]);
2071 return cx->blk_loop.next_op;
2077 register PERL_CONTEXT *cx;
2080 if (PL_op->op_flags & OPf_SPECIAL) {
2081 cxix = dopoptoloop(cxstack_ix);
2083 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2086 cxix = dopoptolabel(cPVOP->op_pv);
2088 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2090 if (cxix < cxstack_ix)
2094 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2095 LEAVE_SCOPE(oldsave);
2096 return cx->blk_loop.redo_op;
2100 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2104 static char too_deep[] = "Target of goto is too deeply nested";
2107 Perl_croak(aTHX_ too_deep);
2108 if (o->op_type == OP_LEAVE ||
2109 o->op_type == OP_SCOPE ||
2110 o->op_type == OP_LEAVELOOP ||
2111 o->op_type == OP_LEAVESUB ||
2112 o->op_type == OP_LEAVETRY)
2114 *ops++ = cUNOPo->op_first;
2116 Perl_croak(aTHX_ too_deep);
2119 if (o->op_flags & OPf_KIDS) {
2120 /* First try all the kids at this level, since that's likeliest. */
2121 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2122 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2123 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2126 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2127 if (kid == PL_lastgotoprobe)
2129 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2132 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2133 ops[-1]->op_type == OP_DBSTATE)
2138 if ((o = dofindlabel(kid, label, ops, oplimit)))
2157 register PERL_CONTEXT *cx;
2158 #define GOTO_DEPTH 64
2159 OP *enterops[GOTO_DEPTH];
2161 int do_dump = (PL_op->op_type == OP_DUMP);
2162 static char must_have_label[] = "goto must have label";
2165 if (PL_op->op_flags & OPf_STACKED) {
2169 /* This egregious kludge implements goto &subroutine */
2170 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2172 register PERL_CONTEXT *cx;
2173 CV* cv = (CV*)SvRV(sv);
2179 if (!CvROOT(cv) && !CvXSUB(cv)) {
2184 /* autoloaded stub? */
2185 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2187 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2188 GvNAMELEN(gv), FALSE);
2189 if (autogv && (cv = GvCV(autogv)))
2191 tmpstr = sv_newmortal();
2192 gv_efullname3(tmpstr, gv, Nullch);
2193 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2195 DIE(aTHX_ "Goto undefined subroutine");
2198 /* First do some returnish stuff. */
2199 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2201 cxix = dopoptosub(cxstack_ix);
2203 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2204 if (cxix < cxstack_ix)
2208 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2210 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2211 /* put @_ back onto stack */
2212 AV* av = cx->blk_sub.argarray;
2214 items = AvFILLp(av) + 1;
2216 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2217 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2218 PL_stack_sp += items;
2219 SvREFCNT_dec(GvAV(PL_defgv));
2220 GvAV(PL_defgv) = cx->blk_sub.savearray;
2221 /* abandon @_ if it got reified */
2223 (void)sv_2mortal((SV*)av); /* delay until return */
2225 av_extend(av, items-1);
2226 AvFLAGS(av) = AVf_REIFY;
2227 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2232 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2234 av = GvAV(PL_defgv);
2235 items = AvFILLp(av) + 1;
2237 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2238 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2239 PL_stack_sp += items;
2241 if (CxTYPE(cx) == CXt_SUB &&
2242 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2243 SvREFCNT_dec(cx->blk_sub.cv);
2244 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2245 LEAVE_SCOPE(oldsave);
2247 /* Now do some callish stuff. */
2249 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2251 #ifdef PERL_XSUB_OLDSTYLE
2252 if (CvOLDSTYLE(cv)) {
2253 I32 (*fp3)(int,int,int);
2258 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2259 items = (*fp3)(CvXSUBANY(cv).any_i32,
2260 mark - PL_stack_base + 1,
2262 SP = PL_stack_base + items;
2265 #endif /* PERL_XSUB_OLDSTYLE */
2270 PL_stack_sp--; /* There is no cv arg. */
2271 /* Push a mark for the start of arglist */
2273 (void)(*CvXSUB(cv))(aTHX_ cv);
2274 /* Pop the current context like a decent sub should */
2275 POPBLOCK(cx, PL_curpm);
2276 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2279 return pop_return();
2282 AV* padlist = CvPADLIST(cv);
2283 if (CxTYPE(cx) == CXt_EVAL) {
2284 PL_in_eval = cx->blk_eval.old_in_eval;
2285 PL_eval_root = cx->blk_eval.old_eval_root;
2286 cx->cx_type = CXt_SUB;
2287 cx->blk_sub.hasargs = 0;
2289 cx->blk_sub.cv = cv;
2290 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2293 if (CvDEPTH(cv) < 2)
2294 (void)SvREFCNT_inc(cv);
2296 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2297 sub_crush_depth(cv);
2298 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2300 PAD_SET_CUR(padlist, CvDEPTH(cv));
2301 if (cx->blk_sub.hasargs)
2303 AV* av = (AV*)PAD_SVl(0);
2306 cx->blk_sub.savearray = GvAV(PL_defgv);
2307 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2308 CX_CURPAD_SAVE(cx->blk_sub);
2309 cx->blk_sub.argarray = av;
2312 if (items >= AvMAX(av) + 1) {
2314 if (AvARRAY(av) != ary) {
2315 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2316 SvPVX(av) = (char*)ary;
2318 if (items >= AvMAX(av) + 1) {
2319 AvMAX(av) = items - 1;
2320 Renew(ary,items+1,SV*);
2322 SvPVX(av) = (char*)ary;
2325 Copy(mark,AvARRAY(av),items,SV*);
2326 AvFILLp(av) = items - 1;
2327 assert(!AvREAL(av));
2334 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2336 * We do not care about using sv to call CV;
2337 * it's for informational purposes only.
2339 SV *sv = GvSV(PL_DBsub);
2342 if (PERLDB_SUB_NN) {
2343 (void)SvUPGRADE(sv, SVt_PVIV);
2346 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2349 gv_efullname3(sv, CvGV(cv), Nullch);
2352 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2353 PUSHMARK( PL_stack_sp );
2354 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2358 RETURNOP(CvSTART(cv));
2362 label = SvPV(sv,n_a);
2363 if (!(do_dump || *label))
2364 DIE(aTHX_ must_have_label);
2367 else if (PL_op->op_flags & OPf_SPECIAL) {
2369 DIE(aTHX_ must_have_label);
2372 label = cPVOP->op_pv;
2374 if (label && *label) {
2376 bool leaving_eval = FALSE;
2377 bool in_block = FALSE;
2378 PERL_CONTEXT *last_eval_cx = 0;
2382 PL_lastgotoprobe = 0;
2384 for (ix = cxstack_ix; ix >= 0; ix--) {
2386 switch (CxTYPE(cx)) {
2388 leaving_eval = TRUE;
2389 if (!CxTRYBLOCK(cx)) {
2390 gotoprobe = (last_eval_cx ?
2391 last_eval_cx->blk_eval.old_eval_root :
2396 /* else fall through */
2398 gotoprobe = cx->blk_oldcop->op_sibling;
2404 gotoprobe = cx->blk_oldcop->op_sibling;
2407 gotoprobe = PL_main_root;
2410 if (CvDEPTH(cx->blk_sub.cv)) {
2411 gotoprobe = CvROOT(cx->blk_sub.cv);
2417 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2420 DIE(aTHX_ "panic: goto");
2421 gotoprobe = PL_main_root;
2425 retop = dofindlabel(gotoprobe, label,
2426 enterops, enterops + GOTO_DEPTH);
2430 PL_lastgotoprobe = gotoprobe;
2433 DIE(aTHX_ "Can't find label %s", label);
2435 /* if we're leaving an eval, check before we pop any frames
2436 that we're not going to punt, otherwise the error
2439 if (leaving_eval && *enterops && enterops[1]) {
2441 for (i = 1; enterops[i]; i++)
2442 if (enterops[i]->op_type == OP_ENTERITER)
2443 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2446 /* pop unwanted frames */
2448 if (ix < cxstack_ix) {
2455 oldsave = PL_scopestack[PL_scopestack_ix];
2456 LEAVE_SCOPE(oldsave);
2459 /* push wanted frames */
2461 if (*enterops && enterops[1]) {
2463 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2464 for (; enterops[ix]; ix++) {
2465 PL_op = enterops[ix];
2466 /* Eventually we may want to stack the needed arguments
2467 * for each op. For now, we punt on the hard ones. */
2468 if (PL_op->op_type == OP_ENTERITER)
2469 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2470 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2478 if (!retop) retop = PL_main_start;
2480 PL_restartop = retop;
2481 PL_do_undump = TRUE;
2485 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2486 PL_do_undump = FALSE;
2502 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2504 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2507 PL_exit_flags |= PERL_EXIT_EXPECTED;
2509 PUSHs(&PL_sv_undef);
2517 NV value = SvNVx(GvSV(cCOP->cop_gv));
2518 register I32 match = I_32(value);
2521 if (((NV)match) > value)
2522 --match; /* was fractional--truncate other way */
2524 match -= cCOP->uop.scop.scop_offset;
2527 else if (match > cCOP->uop.scop.scop_max)
2528 match = cCOP->uop.scop.scop_max;
2529 PL_op = cCOP->uop.scop.scop_next[match];
2539 PL_op = PL_op->op_next; /* can't assume anything */
2542 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2543 match -= cCOP->uop.scop.scop_offset;
2546 else if (match > cCOP->uop.scop.scop_max)
2547 match = cCOP->uop.scop.scop_max;
2548 PL_op = cCOP->uop.scop.scop_next[match];
2557 S_save_lines(pTHX_ AV *array, SV *sv)
2559 register char *s = SvPVX(sv);
2560 register char *send = SvPVX(sv) + SvCUR(sv);
2562 register I32 line = 1;
2564 while (s && s < send) {
2565 SV *tmpstr = NEWSV(85,0);
2567 sv_upgrade(tmpstr, SVt_PVMG);
2568 t = strchr(s, '\n');
2574 sv_setpvn(tmpstr, s, t - s);
2575 av_store(array, line++, tmpstr);
2580 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2582 S_docatch_body(pTHX_ va_list args)
2584 return docatch_body();
2589 S_docatch_body(pTHX)
2596 S_docatch(pTHX_ OP *o)
2601 volatile PERL_SI *cursi = PL_curstackinfo;
2605 assert(CATCH_GET == TRUE);
2609 /* Normally, the leavetry at the end of this block of ops will
2610 * pop an op off the return stack and continue there. By setting
2611 * the op to Nullop, we force an exit from the inner runops()
2614 retop = pop_return();
2615 push_return(Nullop);
2617 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2619 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2625 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2631 /* die caught by an inner eval - continue inner loop */
2632 if (PL_restartop && cursi == PL_curstackinfo) {
2633 PL_op = PL_restartop;
2637 /* a die in this eval - continue in outer loop */
2653 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2654 /* sv Text to convert to OP tree. */
2655 /* startop op_free() this to undo. */
2656 /* code Short string id of the caller. */
2658 dSP; /* Make POPBLOCK work. */
2661 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2665 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2666 char *tmpbuf = tbuf;
2669 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2674 /* switch to eval mode */
2676 if (PL_curcop == &PL_compiling) {
2677 SAVECOPSTASH_FREE(&PL_compiling);
2678 CopSTASH_set(&PL_compiling, PL_curstash);
2680 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2681 SV *sv = sv_newmortal();
2682 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2683 code, (unsigned long)++PL_evalseq,
2684 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2688 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2689 SAVECOPFILE_FREE(&PL_compiling);
2690 CopFILE_set(&PL_compiling, tmpbuf+2);
2691 SAVECOPLINE(&PL_compiling);
2692 CopLINE_set(&PL_compiling, 1);
2693 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2694 deleting the eval's FILEGV from the stash before gv_check() runs
2695 (i.e. before run-time proper). To work around the coredump that
2696 ensues, we always turn GvMULTI_on for any globals that were
2697 introduced within evals. See force_ident(). GSAR 96-10-12 */
2698 safestr = savepv(tmpbuf);
2699 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2701 #ifdef OP_IN_REGISTER
2706 PL_hints &= HINT_UTF8;
2708 /* we get here either during compilation, or via pp_regcomp at runtime */
2709 runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2711 runcv = find_runcv(NULL);
2714 PL_op->op_type = OP_ENTEREVAL;
2715 PL_op->op_flags = 0; /* Avoid uninit warning. */
2716 PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2717 PUSHEVAL(cx, 0, Nullgv);
2720 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2722 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2723 POPBLOCK(cx,PL_curpm);
2726 (*startop)->op_type = OP_NULL;
2727 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2729 /* XXX DAPM do this properly one year */
2730 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2732 if (PL_curcop == &PL_compiling)
2733 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2734 #ifdef OP_IN_REGISTER
2742 =for apidoc find_runcv
2744 Locate the CV corresponding to the currently executing sub or eval.
2745 If db_seqp is non_null, skip CVs that are in the DB package and populate
2746 *db_seqp with the cop sequence number at the point that the DB:: code was
2747 entered. (allows debuggers to eval in the scope of the breakpoint rather
2748 than in in the scope of the debuger itself).
2754 Perl_find_runcv(pTHX_ U32 *db_seqp)
2761 *db_seqp = PL_curcop->cop_seq;
2762 for (si = PL_curstackinfo; si; si = si->si_prev) {
2763 for (ix = si->si_cxix; ix >= 0; ix--) {
2764 cx = &(si->si_cxstack[ix]);
2765 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2766 CV *cv = cx->blk_sub.cv;
2767 /* skip DB:: code */
2768 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2769 *db_seqp = cx->blk_oldcop->cop_seq;
2774 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2782 /* Compile a require/do, an eval '', or a /(?{...})/.
2783 * In the last case, startop is non-null, and contains the address of
2784 * a pointer that should be set to the just-compiled code.
2785 * outside is the lexically enclosing CV (if any) that invoked us.
2788 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2790 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2795 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2796 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2801 SAVESPTR(PL_compcv);
2802 PL_compcv = (CV*)NEWSV(1104,0);
2803 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2804 CvEVAL_on(PL_compcv);
2805 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2806 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2808 CvOUTSIDE_SEQ(PL_compcv) = seq;
2809 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2811 /* set up a scratch pad */
2813 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2816 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2818 /* make sure we compile in the right package */
2820 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2821 SAVESPTR(PL_curstash);
2822 PL_curstash = CopSTASH(PL_curcop);
2824 SAVESPTR(PL_beginav);
2825 PL_beginav = newAV();
2826 SAVEFREESV(PL_beginav);
2827 SAVEI32(PL_error_count);
2829 /* try to compile it */
2831 PL_eval_root = Nullop;
2833 PL_curcop = &PL_compiling;
2834 PL_curcop->cop_arybase = 0;
2835 if (saveop && saveop->op_flags & OPf_SPECIAL)
2836 PL_in_eval |= EVAL_KEEPERR;
2839 if (yyparse() || PL_error_count || !PL_eval_root) {
2840 SV **newsp; /* Used by POPBLOCK. */
2842 I32 optype = 0; /* Might be reset by POPEVAL. */
2847 op_free(PL_eval_root);
2848 PL_eval_root = Nullop;
2850 SP = PL_stack_base + POPMARK; /* pop original mark */
2852 POPBLOCK(cx,PL_curpm);
2858 if (optype == OP_REQUIRE) {
2859 char* msg = SvPVx(ERRSV, n_a);
2860 DIE(aTHX_ "%sCompilation failed in require",
2861 *msg ? msg : "Unknown error\n");
2864 char* msg = SvPVx(ERRSV, n_a);
2866 POPBLOCK(cx,PL_curpm);
2868 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2869 (*msg ? msg : "Unknown error\n"));
2872 char* msg = SvPVx(ERRSV, n_a);
2874 sv_setpv(ERRSV, "Compilation error");
2879 CopLINE_set(&PL_compiling, 0);
2881 *startop = PL_eval_root;
2883 SAVEFREEOP(PL_eval_root);
2885 /* Set the context for this new optree.
2886 * If the last op is an OP_REQUIRE, force scalar context.
2887 * Otherwise, propagate the context from the eval(). */
2888 if (PL_eval_root->op_type == OP_LEAVEEVAL
2889 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2890 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2892 scalar(PL_eval_root);
2893 else if (gimme & G_VOID)
2894 scalarvoid(PL_eval_root);
2895 else if (gimme & G_ARRAY)
2898 scalar(PL_eval_root);
2900 DEBUG_x(dump_eval());
2902 /* Register with debugger: */
2903 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2904 CV *cv = get_cv("DB::postponed", FALSE);
2908 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2910 call_sv((SV*)cv, G_DISCARD);
2914 /* compiled okay, so do it */
2916 CvDEPTH(PL_compcv) = 1;
2917 SP = PL_stack_base + POPMARK; /* pop original mark */
2918 PL_op = saveop; /* The caller may need it. */
2919 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2921 RETURNOP(PL_eval_start);
2925 S_doopen_pm(pTHX_ const char *name, const char *mode)
2927 #ifndef PERL_DISABLE_PMC
2928 STRLEN namelen = strlen(name);
2931 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2932 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2933 char *pmc = SvPV_nolen(pmcsv);
2936 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2937 fp = PerlIO_open(name, mode);
2940 if (PerlLIO_stat(name, &pmstat) < 0 ||
2941 pmstat.st_mtime < pmcstat.st_mtime)
2943 fp = PerlIO_open(pmc, mode);
2946 fp = PerlIO_open(name, mode);
2949 SvREFCNT_dec(pmcsv);
2952 fp = PerlIO_open(name, mode);
2956 return PerlIO_open(name, mode);
2957 #endif /* !PERL_DISABLE_PMC */
2963 register PERL_CONTEXT *cx;
2967 char *tryname = Nullch;
2968 SV *namesv = Nullsv;
2970 I32 gimme = GIMME_V;
2971 PerlIO *tryrsfp = 0;
2973 int filter_has_file = 0;
2974 GV *filter_child_proc = 0;
2975 SV *filter_state = 0;
2982 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2983 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2984 UV rev = 0, ver = 0, sver = 0;
2986 U8 *s = (U8*)SvPVX(sv);
2987 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2989 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2992 ver = utf8n_to_uvchr(s, end - s, &len, 0);
2995 sver = utf8n_to_uvchr(s, end - s, &len, 0);
2998 if (PERL_REVISION < rev
2999 || (PERL_REVISION == rev
3000 && (PERL_VERSION < ver
3001 || (PERL_VERSION == ver
3002 && PERL_SUBVERSION < sver))))
3004 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3005 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3006 PERL_VERSION, PERL_SUBVERSION);
3008 if (ckWARN(WARN_PORTABLE))
3009 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3010 "v-string in use/require non-portable");
3013 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3014 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3015 + ((NV)PERL_SUBVERSION/(NV)1000000)
3016 + 0.00000099 < SvNV(sv))
3020 NV nver = (nrev - rev) * 1000;
3021 UV ver = (UV)(nver + 0.0009);
3022 NV nsver = (nver - ver) * 1000;
3023 UV sver = (UV)(nsver + 0.0009);
3025 /* help out with the "use 5.6" confusion */
3026 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3027 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3028 " (did you mean v%"UVuf".%03"UVuf"?)--"
3029 "this is only v%d.%d.%d, stopped",
3030 rev, ver, sver, rev, ver/100,
3031 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3034 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3035 "this is only v%d.%d.%d, stopped",
3036 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3043 name = SvPV(sv, len);
3044 if (!(name && len > 0 && *name))
3045 DIE(aTHX_ "Null filename used");
3046 TAINT_PROPER("require");
3047 if (PL_op->op_type == OP_REQUIRE &&
3048 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3049 *svp != &PL_sv_undef)
3052 /* prepare to compile file */
3054 if (path_is_absolute(name)) {
3056 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3058 #ifdef MACOS_TRADITIONAL
3062 MacPerl_CanonDir(name, newname, 1);
3063 if (path_is_absolute(newname)) {
3065 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3070 AV *ar = GvAVn(PL_incgv);
3074 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3077 namesv = NEWSV(806, 0);
3078 for (i = 0; i <= AvFILL(ar); i++) {
3079 SV *dirsv = *av_fetch(ar, i, TRUE);
3085 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3086 && !sv_isobject(loader))
3088 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3091 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3092 PTR2UV(SvRV(dirsv)), name);
3093 tryname = SvPVX(namesv);
3104 if (sv_isobject(loader))
3105 count = call_method("INC", G_ARRAY);
3107 count = call_sv(loader, G_ARRAY);
3117 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3121 if (SvTYPE(arg) == SVt_PVGV) {
3122 IO *io = GvIO((GV *)arg);
3127 tryrsfp = IoIFP(io);
3128 if (IoTYPE(io) == IoTYPE_PIPE) {
3129 /* reading from a child process doesn't
3130 nest -- when returning from reading
3131 the inner module, the outer one is
3132 unreadable (closed?) I've tried to
3133 save the gv to manage the lifespan of
3134 the pipe, but this didn't help. XXX */
3135 filter_child_proc = (GV *)arg;
3136 (void)SvREFCNT_inc(filter_child_proc);
3139 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3140 PerlIO_close(IoOFP(io));
3152 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3154 (void)SvREFCNT_inc(filter_sub);
3157 filter_state = SP[i];
3158 (void)SvREFCNT_inc(filter_state);
3162 tryrsfp = PerlIO_open("/dev/null",
3177 filter_has_file = 0;
3178 if (filter_child_proc) {
3179 SvREFCNT_dec(filter_child_proc);
3180 filter_child_proc = 0;
3183 SvREFCNT_dec(filter_state);
3187 SvREFCNT_dec(filter_sub);
3192 if (!path_is_absolute(name)
3193 #ifdef MACOS_TRADITIONAL
3194 /* We consider paths of the form :a:b ambiguous and interpret them first
3195 as global then as local
3197 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3200 char *dir = SvPVx(dirsv, n_a);
3201 #ifdef MACOS_TRADITIONAL
3205 MacPerl_CanonDir(name, buf2, 1);
3206 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3210 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3212 sv_setpv(namesv, unixdir);
3213 sv_catpv(namesv, unixname);
3215 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3218 TAINT_PROPER("require");
3219 tryname = SvPVX(namesv);
3220 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3222 if (tryname[0] == '.' && tryname[1] == '/')
3231 SAVECOPFILE_FREE(&PL_compiling);
3232 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3233 SvREFCNT_dec(namesv);
3235 if (PL_op->op_type == OP_REQUIRE) {
3236 char *msgstr = name;
3237 if (namesv) { /* did we lookup @INC? */
3238 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3239 SV *dirmsgsv = NEWSV(0, 0);
3240 AV *ar = GvAVn(PL_incgv);
3242 sv_catpvn(msg, " in @INC", 8);
3243 if (instr(SvPVX(msg), ".h "))
3244 sv_catpv(msg, " (change .h to .ph maybe?)");
3245 if (instr(SvPVX(msg), ".ph "))
3246 sv_catpv(msg, " (did you run h2ph?)");
3247 sv_catpv(msg, " (@INC contains:");
3248 for (i = 0; i <= AvFILL(ar); i++) {
3249 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3250 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3251 sv_catsv(msg, dirmsgsv);
3253 sv_catpvn(msg, ")", 1);
3254 SvREFCNT_dec(dirmsgsv);
3255 msgstr = SvPV_nolen(msg);
3257 DIE(aTHX_ "Can't locate %s", msgstr);
3263 SETERRNO(0, SS_NORMAL);
3265 /* Assume success here to prevent recursive requirement. */
3267 /* Check whether a hook in @INC has already filled %INC */
3268 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3269 (void)hv_store(GvHVn(PL_incgv), name, len,
3270 (hook_sv ? SvREFCNT_inc(hook_sv)
3271 : newSVpv(CopFILE(&PL_compiling), 0)),
3277 lex_start(sv_2mortal(newSVpvn("",0)));
3278 SAVEGENERICSV(PL_rsfp_filters);
3279 PL_rsfp_filters = Nullav;
3284 SAVESPTR(PL_compiling.cop_warnings);
3285 if (PL_dowarn & G_WARN_ALL_ON)
3286 PL_compiling.cop_warnings = pWARN_ALL ;
3287 else if (PL_dowarn & G_WARN_ALL_OFF)
3288 PL_compiling.cop_warnings = pWARN_NONE ;
3289 else if (PL_taint_warn)
3290 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3292 PL_compiling.cop_warnings = pWARN_STD ;
3293 SAVESPTR(PL_compiling.cop_io);
3294 PL_compiling.cop_io = Nullsv;
3296 if (filter_sub || filter_child_proc) {
3297 SV *datasv = filter_add(run_user_filter, Nullsv);
3298 IoLINES(datasv) = filter_has_file;
3299 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3300 IoTOP_GV(datasv) = (GV *)filter_state;
3301 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3304 /* switch to eval mode */
3305 push_return(PL_op->op_next);
3306 PUSHBLOCK(cx, CXt_EVAL, SP);
3307 PUSHEVAL(cx, name, Nullgv);
3309 SAVECOPLINE(&PL_compiling);
3310 CopLINE_set(&PL_compiling, 0);
3314 /* Store and reset encoding. */
3315 encoding = PL_encoding;
3316 PL_encoding = Nullsv;
3318 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3320 /* Restore encoding. */
3321 PL_encoding = encoding;
3328 return pp_require();
3334 register PERL_CONTEXT *cx;
3336 I32 gimme = GIMME_V, was = PL_sub_generation;
3337 char tbuf[TYPE_DIGITS(long) + 12];
3338 char *tmpbuf = tbuf;
3347 TAINT_PROPER("eval");
3353 /* switch to eval mode */
3355 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3356 SV *sv = sv_newmortal();
3357 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3358 (unsigned long)++PL_evalseq,
3359 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3363 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3364 SAVECOPFILE_FREE(&PL_compiling);
3365 CopFILE_set(&PL_compiling, tmpbuf+2);
3366 SAVECOPLINE(&PL_compiling);
3367 CopLINE_set(&PL_compiling, 1);
3368 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3369 deleting the eval's FILEGV from the stash before gv_check() runs
3370 (i.e. before run-time proper). To work around the coredump that
3371 ensues, we always turn GvMULTI_on for any globals that were
3372 introduced within evals. See force_ident(). GSAR 96-10-12 */
3373 safestr = savepv(tmpbuf);
3374 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3376 PL_hints = PL_op->op_targ;
3377 SAVESPTR(PL_compiling.cop_warnings);
3378 if (specialWARN(PL_curcop->cop_warnings))
3379 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3381 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3382 SAVEFREESV(PL_compiling.cop_warnings);
3384 SAVESPTR(PL_compiling.cop_io);
3385 if (specialCopIO(PL_curcop->cop_io))
3386 PL_compiling.cop_io = PL_curcop->cop_io;
3388 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3389 SAVEFREESV(PL_compiling.cop_io);
3391 /* special case: an eval '' executed within the DB package gets lexically
3392 * placed in the first non-DB CV rather than the current CV - this
3393 * allows the debugger to execute code, find lexicals etc, in the
3394 * scope of the code being debugged. Passing &seq gets find_runcv
3395 * to do the dirty work for us */
3396 runcv = find_runcv(&seq);
3398 push_return(PL_op->op_next);
3399 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3400 PUSHEVAL(cx, 0, Nullgv);
3402 /* prepare to compile string */
3404 if (PERLDB_LINE && PL_curstash != PL_debstash)
3405 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3407 ret = doeval(gimme, NULL, runcv, seq);
3408 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3409 && ret != PL_op->op_next) { /* Successive compilation. */
3410 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3412 return DOCATCH(ret);
3422 register PERL_CONTEXT *cx;
3424 U8 save_flags = PL_op -> op_flags;
3429 retop = pop_return();
3432 if (gimme == G_VOID)
3434 else if (gimme == G_SCALAR) {
3437 if (SvFLAGS(TOPs) & SVs_TEMP)
3440 *MARK = sv_mortalcopy(TOPs);
3444 *MARK = &PL_sv_undef;
3449 /* in case LEAVE wipes old return values */
3450 for (mark = newsp + 1; mark <= SP; mark++) {
3451 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3452 *mark = sv_mortalcopy(*mark);
3453 TAINT_NOT; /* Each item is independent */
3457 PL_curpm = newpm; /* Don't pop $1 et al till now */
3460 assert(CvDEPTH(PL_compcv) == 1);
3462 CvDEPTH(PL_compcv) = 0;
3465 if (optype == OP_REQUIRE &&
3466 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3468 /* Unassume the success we assumed earlier. */
3469 SV *nsv = cx->blk_eval.old_namesv;
3470 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3471 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3472 /* die_where() did LEAVE, or we won't be here */
3476 if (!(save_flags & OPf_SPECIAL))
3486 register PERL_CONTEXT *cx;
3487 I32 gimme = GIMME_V;
3492 push_return(cLOGOP->op_other->op_next);
3493 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3496 PL_in_eval = EVAL_INEVAL;
3499 return DOCATCH(PL_op->op_next);
3510 register PERL_CONTEXT *cx;
3515 retop = pop_return();
3518 if (gimme == G_VOID)
3520 else if (gimme == G_SCALAR) {
3523 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3526 *MARK = sv_mortalcopy(TOPs);
3530 *MARK = &PL_sv_undef;
3535 /* in case LEAVE wipes old return values */
3536 for (mark = newsp + 1; mark <= SP; mark++) {
3537 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3538 *mark = sv_mortalcopy(*mark);
3539 TAINT_NOT; /* Each item is independent */
3543 PL_curpm = newpm; /* Don't pop $1 et al till now */
3551 S_doparseform(pTHX_ SV *sv)
3554 register char *s = SvPV_force(sv, len);
3555 register char *send = s + len;
3556 register char *base = Nullch;
3557 register I32 skipspaces = 0;
3558 bool noblank = FALSE;
3559 bool repeat = FALSE;
3560 bool postspace = FALSE;
3566 int maxops = 2; /* FF_LINEMARK + FF_END) */
3569 Perl_croak(aTHX_ "Null picture in formline");
3571 /* estimate the buffer size needed */
3572 for (base = s; s <= send; s++) {
3573 if (*s == '\n' || *s == '@' || *s == '^')
3579 New(804, fops, maxops, U32);
3584 *fpc++ = FF_LINEMARK;
3585 noblank = repeat = FALSE;
3603 case ' ': case '\t':
3614 *fpc++ = FF_LITERAL;
3622 *fpc++ = (U16)skipspaces;
3626 *fpc++ = FF_NEWLINE;
3630 arg = fpc - linepc + 1;
3637 *fpc++ = FF_LINEMARK;
3638 noblank = repeat = FALSE;
3647 ischop = s[-1] == '^';
3653 arg = (s - base) - 1;
3655 *fpc++ = FF_LITERAL;
3664 *fpc++ = FF_LINEGLOB;
3666 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3667 arg = ischop ? 512 : 0;
3677 arg |= 256 + (s - f);
3679 *fpc++ = s - base; /* fieldsize for FETCH */
3680 *fpc++ = FF_DECIMAL;
3683 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3684 arg = ischop ? 512 : 0;
3686 s++; /* skip the '0' first */
3695 arg |= 256 + (s - f);
3697 *fpc++ = s - base; /* fieldsize for FETCH */
3698 *fpc++ = FF_0DECIMAL;
3703 bool ismore = FALSE;
3706 while (*++s == '>') ;
3707 prespace = FF_SPACE;
3709 else if (*s == '|') {
3710 while (*++s == '|') ;
3711 prespace = FF_HALFSPACE;
3716 while (*++s == '<') ;
3719 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3723 *fpc++ = s - base; /* fieldsize for FETCH */
3725 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3728 *fpc++ = (U16)prespace;
3742 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3744 { /* need to jump to the next word */
3746 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3747 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3748 s = SvPVX(sv) + SvCUR(sv) + z;
3750 Copy(fops, s, arg, U32);
3752 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3757 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3759 SV *datasv = FILTER_DATA(idx);
3760 int filter_has_file = IoLINES(datasv);
3761 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3762 SV *filter_state = (SV *)IoTOP_GV(datasv);
3763 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3766 /* I was having segfault trouble under Linux 2.2.5 after a
3767 parse error occured. (Had to hack around it with a test
3768 for PL_error_count == 0.) Solaris doesn't segfault --
3769 not sure where the trouble is yet. XXX */
3771 if (filter_has_file) {
3772 len = FILTER_READ(idx+1, buf_sv, maxlen);
3775 if (filter_sub && len >= 0) {
3786 PUSHs(sv_2mortal(newSViv(maxlen)));
3788 PUSHs(filter_state);
3791 count = call_sv(filter_sub, G_SCALAR);
3807 IoLINES(datasv) = 0;
3808 if (filter_child_proc) {
3809 SvREFCNT_dec(filter_child_proc);
3810 IoFMT_GV(datasv) = Nullgv;
3813 SvREFCNT_dec(filter_state);
3814 IoTOP_GV(datasv) = Nullgv;
3817 SvREFCNT_dec(filter_sub);
3818 IoBOTTOM_GV(datasv) = Nullgv;
3820 filter_del(run_user_filter);
3826 /* perhaps someone can come up with a better name for
3827 this? it is not really "absolute", per se ... */
3829 S_path_is_absolute(pTHX_ char *name)
3831 if (PERL_FILE_IS_ABSOLUTE(name)
3832 #ifdef MACOS_TRADITIONAL
3835 || (*name == '.' && (name[1] == '/' ||
3836 (name[1] == '.' && name[2] == '/'))))