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 SV *nsv = cx->blk_eval.old_namesv;
1406 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1408 DIE(aTHX_ "%sCompilation failed in require",
1409 *msg ? msg : "Unknown error\n");
1411 return pop_return();
1415 message = SvPVx(ERRSV, msglen);
1417 write_to_stderr(message, msglen);
1426 if (SvTRUE(left) != SvTRUE(right))
1438 RETURNOP(cLOGOP->op_other);
1447 RETURNOP(cLOGOP->op_other);
1456 if (!sv || !SvANY(sv)) {
1457 RETURNOP(cLOGOP->op_other);
1460 switch (SvTYPE(sv)) {
1462 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1466 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1470 if (CvROOT(sv) || CvXSUB(sv))
1480 RETURNOP(cLOGOP->op_other);
1486 register I32 cxix = dopoptosub(cxstack_ix);
1487 register PERL_CONTEXT *cx;
1488 register PERL_CONTEXT *ccstack = cxstack;
1489 PERL_SI *top_si = PL_curstackinfo;
1500 /* we may be in a higher stacklevel, so dig down deeper */
1501 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1502 top_si = top_si->si_prev;
1503 ccstack = top_si->si_cxstack;
1504 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1507 if (GIMME != G_ARRAY) {
1513 if (PL_DBsub && cxix >= 0 &&
1514 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1518 cxix = dopoptosub_at(ccstack, cxix - 1);
1521 cx = &ccstack[cxix];
1522 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1523 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1524 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1525 field below is defined for any cx. */
1526 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1527 cx = &ccstack[dbcxix];
1530 stashname = CopSTASHPV(cx->blk_oldcop);
1531 if (GIMME != G_ARRAY) {
1534 PUSHs(&PL_sv_undef);
1537 sv_setpv(TARG, stashname);
1546 PUSHs(&PL_sv_undef);
1548 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1549 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1550 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1553 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1554 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1555 /* So is ccstack[dbcxix]. */
1558 gv_efullname3(sv, cvgv, Nullch);
1559 PUSHs(sv_2mortal(sv));
1560 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1563 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1564 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1568 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1569 PUSHs(sv_2mortal(newSViv(0)));
1571 gimme = (I32)cx->blk_gimme;
1572 if (gimme == G_VOID)
1573 PUSHs(&PL_sv_undef);
1575 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1576 if (CxTYPE(cx) == CXt_EVAL) {
1578 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1579 PUSHs(cx->blk_eval.cur_text);
1583 else if (cx->blk_eval.old_namesv) {
1584 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1587 /* eval BLOCK (try blocks have old_namesv == 0) */
1589 PUSHs(&PL_sv_undef);
1590 PUSHs(&PL_sv_undef);
1594 PUSHs(&PL_sv_undef);
1595 PUSHs(&PL_sv_undef);
1597 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1598 && CopSTASH_eq(PL_curcop, PL_debstash))
1600 AV *ary = cx->blk_sub.argarray;
1601 int off = AvARRAY(ary) - AvALLOC(ary);
1605 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1608 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1611 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1612 av_extend(PL_dbargs, AvFILLp(ary) + off);
1613 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1614 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1616 /* XXX only hints propagated via op_private are currently
1617 * visible (others are not easily accessible, since they
1618 * use the global PL_hints) */
1619 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1620 HINT_PRIVATE_MASK)));
1623 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1625 if (old_warnings == pWARN_NONE ||
1626 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1627 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1628 else if (old_warnings == pWARN_ALL ||
1629 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1630 /* Get the bit mask for $warnings::Bits{all}, because
1631 * it could have been extended by warnings::register */
1633 HV *bits = get_hv("warnings::Bits", FALSE);
1634 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1635 mask = newSVsv(*bits_all);
1638 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1642 mask = newSVsv(old_warnings);
1643 PUSHs(sv_2mortal(mask));
1658 sv_reset(tmps, CopSTASH(PL_curcop));
1668 /* like pp_nextstate, but used instead when the debugger is active */
1672 PL_curcop = (COP*)PL_op;
1673 TAINT_NOT; /* Each statement is presumed innocent */
1674 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1677 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1678 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1682 register PERL_CONTEXT *cx;
1683 I32 gimme = G_ARRAY;
1690 DIE(aTHX_ "No DB::DB routine defined");
1692 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1693 /* don't do recursive DB::DB call */
1705 push_return(PL_op->op_next);
1706 PUSHBLOCK(cx, CXt_SUB, SP);
1709 (void)SvREFCNT_inc(cv);
1710 PAD_SET_CUR(CvPADLIST(cv),1);
1711 RETURNOP(CvSTART(cv));
1725 register PERL_CONTEXT *cx;
1726 I32 gimme = GIMME_V;
1728 U32 cxtype = CXt_LOOP;
1736 if (PL_op->op_targ) {
1737 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1738 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1739 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1740 SVs_PADSTALE, SVs_PADSTALE);
1742 #ifndef USE_ITHREADS
1743 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1746 SAVEPADSV(PL_op->op_targ);
1747 iterdata = INT2PTR(void*, PL_op->op_targ);
1748 cxtype |= CXp_PADVAR;
1753 svp = &GvSV(gv); /* symbol table variable */
1754 SAVEGENERICSV(*svp);
1757 iterdata = (void*)gv;
1763 PUSHBLOCK(cx, cxtype, SP);
1765 PUSHLOOP(cx, iterdata, MARK);
1767 PUSHLOOP(cx, svp, MARK);
1769 if (PL_op->op_flags & OPf_STACKED) {
1770 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1771 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1773 /* See comment in pp_flop() */
1774 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1775 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1776 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1777 looks_like_number((SV*)cx->blk_loop.iterary)))
1779 if (SvNV(sv) < IV_MIN ||
1780 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1781 DIE(aTHX_ "Range iterator outside integer range");
1782 cx->blk_loop.iterix = SvIV(sv);
1783 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1786 cx->blk_loop.iterlval = newSVsv(sv);
1790 cx->blk_loop.iterary = PL_curstack;
1791 AvFILLp(PL_curstack) = SP - PL_stack_base;
1792 cx->blk_loop.iterix = MARK - PL_stack_base;
1801 register PERL_CONTEXT *cx;
1802 I32 gimme = GIMME_V;
1808 PUSHBLOCK(cx, CXt_LOOP, SP);
1809 PUSHLOOP(cx, 0, SP);
1817 register PERL_CONTEXT *cx;
1825 newsp = PL_stack_base + cx->blk_loop.resetsp;
1828 if (gimme == G_VOID)
1830 else if (gimme == G_SCALAR) {
1832 *++newsp = sv_mortalcopy(*SP);
1834 *++newsp = &PL_sv_undef;
1838 *++newsp = sv_mortalcopy(*++mark);
1839 TAINT_NOT; /* Each item is independent */
1845 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1846 PL_curpm = newpm; /* ... and pop $1 et al */
1858 register PERL_CONTEXT *cx;
1859 bool popsub2 = FALSE;
1860 bool clear_errsv = FALSE;
1867 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1868 if (cxstack_ix == PL_sortcxix
1869 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1871 if (cxstack_ix > PL_sortcxix)
1872 dounwind(PL_sortcxix);
1873 AvARRAY(PL_curstack)[1] = *SP;
1874 PL_stack_sp = PL_stack_base + 1;
1879 cxix = dopoptosub(cxstack_ix);
1881 DIE(aTHX_ "Can't return outside a subroutine");
1882 if (cxix < cxstack_ix)
1886 switch (CxTYPE(cx)) {
1889 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1892 if (!(PL_in_eval & EVAL_KEEPERR))
1898 if (optype == OP_REQUIRE &&
1899 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1901 /* Unassume the success we assumed earlier. */
1902 SV *nsv = cx->blk_eval.old_namesv;
1903 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1904 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1911 DIE(aTHX_ "panic: return");
1915 if (gimme == G_SCALAR) {
1918 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1920 *++newsp = SvREFCNT_inc(*SP);
1925 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1927 *++newsp = sv_mortalcopy(sv);
1932 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1935 *++newsp = sv_mortalcopy(*SP);
1938 *++newsp = &PL_sv_undef;
1940 else if (gimme == G_ARRAY) {
1941 while (++MARK <= SP) {
1942 *++newsp = (popsub2 && SvTEMP(*MARK))
1943 ? *MARK : sv_mortalcopy(*MARK);
1944 TAINT_NOT; /* Each item is independent */
1947 PL_stack_sp = newsp;
1950 /* Stack values are safe: */
1953 POPSUB(cx,sv); /* release CV and @_ ... */
1957 PL_curpm = newpm; /* ... and pop $1 et al */
1962 return pop_return();
1969 register PERL_CONTEXT *cx;
1979 if (PL_op->op_flags & OPf_SPECIAL) {
1980 cxix = dopoptoloop(cxstack_ix);
1982 DIE(aTHX_ "Can't \"last\" outside a loop block");
1985 cxix = dopoptolabel(cPVOP->op_pv);
1987 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1989 if (cxix < cxstack_ix)
1993 cxstack_ix++; /* temporarily protect top context */
1995 switch (CxTYPE(cx)) {
1998 newsp = PL_stack_base + cx->blk_loop.resetsp;
1999 nextop = cx->blk_loop.last_op->op_next;
2003 nextop = pop_return();
2007 nextop = pop_return();
2011 nextop = pop_return();
2014 DIE(aTHX_ "panic: last");
2018 if (gimme == G_SCALAR) {
2020 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2021 ? *SP : sv_mortalcopy(*SP);
2023 *++newsp = &PL_sv_undef;
2025 else if (gimme == G_ARRAY) {
2026 while (++MARK <= SP) {
2027 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2028 ? *MARK : sv_mortalcopy(*MARK);
2029 TAINT_NOT; /* Each item is independent */
2037 /* Stack values are safe: */
2040 POPLOOP(cx); /* release loop vars ... */
2044 POPSUB(cx,sv); /* release CV and @_ ... */
2047 PL_curpm = newpm; /* ... and pop $1 et al */
2056 register PERL_CONTEXT *cx;
2059 if (PL_op->op_flags & OPf_SPECIAL) {
2060 cxix = dopoptoloop(cxstack_ix);
2062 DIE(aTHX_ "Can't \"next\" outside a loop block");
2065 cxix = dopoptolabel(cPVOP->op_pv);
2067 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2069 if (cxix < cxstack_ix)
2072 /* clear off anything above the scope we're re-entering, but
2073 * save the rest until after a possible continue block */
2074 inner = PL_scopestack_ix;
2076 if (PL_scopestack_ix < inner)
2077 leave_scope(PL_scopestack[PL_scopestack_ix]);
2078 return cx->blk_loop.next_op;
2084 register PERL_CONTEXT *cx;
2087 if (PL_op->op_flags & OPf_SPECIAL) {
2088 cxix = dopoptoloop(cxstack_ix);
2090 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2093 cxix = dopoptolabel(cPVOP->op_pv);
2095 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2097 if (cxix < cxstack_ix)
2101 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2102 LEAVE_SCOPE(oldsave);
2103 return cx->blk_loop.redo_op;
2107 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2111 static char too_deep[] = "Target of goto is too deeply nested";
2114 Perl_croak(aTHX_ too_deep);
2115 if (o->op_type == OP_LEAVE ||
2116 o->op_type == OP_SCOPE ||
2117 o->op_type == OP_LEAVELOOP ||
2118 o->op_type == OP_LEAVESUB ||
2119 o->op_type == OP_LEAVETRY)
2121 *ops++ = cUNOPo->op_first;
2123 Perl_croak(aTHX_ too_deep);
2126 if (o->op_flags & OPf_KIDS) {
2127 /* First try all the kids at this level, since that's likeliest. */
2128 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2129 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2130 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2133 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2134 if (kid == PL_lastgotoprobe)
2136 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2139 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2140 ops[-1]->op_type == OP_DBSTATE)
2145 if ((o = dofindlabel(kid, label, ops, oplimit)))
2164 register PERL_CONTEXT *cx;
2165 #define GOTO_DEPTH 64
2166 OP *enterops[GOTO_DEPTH];
2168 int do_dump = (PL_op->op_type == OP_DUMP);
2169 static char must_have_label[] = "goto must have label";
2172 if (PL_op->op_flags & OPf_STACKED) {
2176 /* This egregious kludge implements goto &subroutine */
2177 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2179 register PERL_CONTEXT *cx;
2180 CV* cv = (CV*)SvRV(sv);
2186 if (!CvROOT(cv) && !CvXSUB(cv)) {
2191 /* autoloaded stub? */
2192 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2194 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2195 GvNAMELEN(gv), FALSE);
2196 if (autogv && (cv = GvCV(autogv)))
2198 tmpstr = sv_newmortal();
2199 gv_efullname3(tmpstr, gv, Nullch);
2200 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2202 DIE(aTHX_ "Goto undefined subroutine");
2205 /* First do some returnish stuff. */
2206 SvREFCNT_inc(cv); /* avoid premature free during unwind */
2208 cxix = dopoptosub(cxstack_ix);
2210 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2211 if (cxix < cxstack_ix)
2215 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2217 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2218 /* put @_ back onto stack */
2219 AV* av = cx->blk_sub.argarray;
2221 items = AvFILLp(av) + 1;
2223 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2224 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2225 PL_stack_sp += items;
2226 SvREFCNT_dec(GvAV(PL_defgv));
2227 GvAV(PL_defgv) = cx->blk_sub.savearray;
2228 /* abandon @_ if it got reified */
2230 (void)sv_2mortal((SV*)av); /* delay until return */
2232 av_extend(av, items-1);
2233 AvFLAGS(av) = AVf_REIFY;
2234 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2239 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2241 av = GvAV(PL_defgv);
2242 items = AvFILLp(av) + 1;
2244 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2245 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2246 PL_stack_sp += items;
2248 if (CxTYPE(cx) == CXt_SUB &&
2249 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2250 SvREFCNT_dec(cx->blk_sub.cv);
2251 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2252 LEAVE_SCOPE(oldsave);
2254 /* Now do some callish stuff. */
2256 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2258 #ifdef PERL_XSUB_OLDSTYLE
2259 if (CvOLDSTYLE(cv)) {
2260 I32 (*fp3)(int,int,int);
2265 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2266 items = (*fp3)(CvXSUBANY(cv).any_i32,
2267 mark - PL_stack_base + 1,
2269 SP = PL_stack_base + items;
2272 #endif /* PERL_XSUB_OLDSTYLE */
2277 PL_stack_sp--; /* There is no cv arg. */
2278 /* Push a mark for the start of arglist */
2280 (void)(*CvXSUB(cv))(aTHX_ cv);
2281 /* Pop the current context like a decent sub should */
2282 POPBLOCK(cx, PL_curpm);
2283 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2286 return pop_return();
2289 AV* padlist = CvPADLIST(cv);
2290 if (CxTYPE(cx) == CXt_EVAL) {
2291 PL_in_eval = cx->blk_eval.old_in_eval;
2292 PL_eval_root = cx->blk_eval.old_eval_root;
2293 cx->cx_type = CXt_SUB;
2294 cx->blk_sub.hasargs = 0;
2296 cx->blk_sub.cv = cv;
2297 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2300 if (CvDEPTH(cv) < 2)
2301 (void)SvREFCNT_inc(cv);
2303 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2304 sub_crush_depth(cv);
2305 pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2307 PAD_SET_CUR(padlist, CvDEPTH(cv));
2308 if (cx->blk_sub.hasargs)
2310 AV* av = (AV*)PAD_SVl(0);
2313 cx->blk_sub.savearray = GvAV(PL_defgv);
2314 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2315 CX_CURPAD_SAVE(cx->blk_sub);
2316 cx->blk_sub.argarray = av;
2319 if (items >= AvMAX(av) + 1) {
2321 if (AvARRAY(av) != ary) {
2322 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2323 SvPVX(av) = (char*)ary;
2325 if (items >= AvMAX(av) + 1) {
2326 AvMAX(av) = items - 1;
2327 Renew(ary,items+1,SV*);
2329 SvPVX(av) = (char*)ary;
2332 Copy(mark,AvARRAY(av),items,SV*);
2333 AvFILLp(av) = items - 1;
2334 assert(!AvREAL(av));
2341 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2343 * We do not care about using sv to call CV;
2344 * it's for informational purposes only.
2346 SV *sv = GvSV(PL_DBsub);
2349 if (PERLDB_SUB_NN) {
2350 (void)SvUPGRADE(sv, SVt_PVIV);
2353 SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2356 gv_efullname3(sv, CvGV(cv), Nullch);
2359 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2360 PUSHMARK( PL_stack_sp );
2361 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2365 RETURNOP(CvSTART(cv));
2369 label = SvPV(sv,n_a);
2370 if (!(do_dump || *label))
2371 DIE(aTHX_ must_have_label);
2374 else if (PL_op->op_flags & OPf_SPECIAL) {
2376 DIE(aTHX_ must_have_label);
2379 label = cPVOP->op_pv;
2381 if (label && *label) {
2383 bool leaving_eval = FALSE;
2384 bool in_block = FALSE;
2385 PERL_CONTEXT *last_eval_cx = 0;
2389 PL_lastgotoprobe = 0;
2391 for (ix = cxstack_ix; ix >= 0; ix--) {
2393 switch (CxTYPE(cx)) {
2395 leaving_eval = TRUE;
2396 if (!CxTRYBLOCK(cx)) {
2397 gotoprobe = (last_eval_cx ?
2398 last_eval_cx->blk_eval.old_eval_root :
2403 /* else fall through */
2405 gotoprobe = cx->blk_oldcop->op_sibling;
2411 gotoprobe = cx->blk_oldcop->op_sibling;
2414 gotoprobe = PL_main_root;
2417 if (CvDEPTH(cx->blk_sub.cv)) {
2418 gotoprobe = CvROOT(cx->blk_sub.cv);
2424 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2427 DIE(aTHX_ "panic: goto");
2428 gotoprobe = PL_main_root;
2432 retop = dofindlabel(gotoprobe, label,
2433 enterops, enterops + GOTO_DEPTH);
2437 PL_lastgotoprobe = gotoprobe;
2440 DIE(aTHX_ "Can't find label %s", label);
2442 /* if we're leaving an eval, check before we pop any frames
2443 that we're not going to punt, otherwise the error
2446 if (leaving_eval && *enterops && enterops[1]) {
2448 for (i = 1; enterops[i]; i++)
2449 if (enterops[i]->op_type == OP_ENTERITER)
2450 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2453 /* pop unwanted frames */
2455 if (ix < cxstack_ix) {
2462 oldsave = PL_scopestack[PL_scopestack_ix];
2463 LEAVE_SCOPE(oldsave);
2466 /* push wanted frames */
2468 if (*enterops && enterops[1]) {
2470 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2471 for (; enterops[ix]; ix++) {
2472 PL_op = enterops[ix];
2473 /* Eventually we may want to stack the needed arguments
2474 * for each op. For now, we punt on the hard ones. */
2475 if (PL_op->op_type == OP_ENTERITER)
2476 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2477 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2485 if (!retop) retop = PL_main_start;
2487 PL_restartop = retop;
2488 PL_do_undump = TRUE;
2492 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2493 PL_do_undump = FALSE;
2509 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2511 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2514 PL_exit_flags |= PERL_EXIT_EXPECTED;
2516 PUSHs(&PL_sv_undef);
2524 NV value = SvNVx(GvSV(cCOP->cop_gv));
2525 register I32 match = I_32(value);
2528 if (((NV)match) > value)
2529 --match; /* was fractional--truncate other way */
2531 match -= cCOP->uop.scop.scop_offset;
2534 else if (match > cCOP->uop.scop.scop_max)
2535 match = cCOP->uop.scop.scop_max;
2536 PL_op = cCOP->uop.scop.scop_next[match];
2546 PL_op = PL_op->op_next; /* can't assume anything */
2549 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2550 match -= cCOP->uop.scop.scop_offset;
2553 else if (match > cCOP->uop.scop.scop_max)
2554 match = cCOP->uop.scop.scop_max;
2555 PL_op = cCOP->uop.scop.scop_next[match];
2564 S_save_lines(pTHX_ AV *array, SV *sv)
2566 register char *s = SvPVX(sv);
2567 register char *send = SvPVX(sv) + SvCUR(sv);
2569 register I32 line = 1;
2571 while (s && s < send) {
2572 SV *tmpstr = NEWSV(85,0);
2574 sv_upgrade(tmpstr, SVt_PVMG);
2575 t = strchr(s, '\n');
2581 sv_setpvn(tmpstr, s, t - s);
2582 av_store(array, line++, tmpstr);
2587 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2589 S_docatch_body(pTHX_ va_list args)
2591 return docatch_body();
2596 S_docatch_body(pTHX)
2603 S_docatch(pTHX_ OP *o)
2608 volatile PERL_SI *cursi = PL_curstackinfo;
2612 assert(CATCH_GET == TRUE);
2616 /* Normally, the leavetry at the end of this block of ops will
2617 * pop an op off the return stack and continue there. By setting
2618 * the op to Nullop, we force an exit from the inner runops()
2621 retop = pop_return();
2622 push_return(Nullop);
2624 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2626 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2632 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2638 /* die caught by an inner eval - continue inner loop */
2639 if (PL_restartop && cursi == PL_curstackinfo) {
2640 PL_op = PL_restartop;
2644 /* a die in this eval - continue in outer loop */
2660 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2661 /* sv Text to convert to OP tree. */
2662 /* startop op_free() this to undo. */
2663 /* code Short string id of the caller. */
2665 dSP; /* Make POPBLOCK work. */
2668 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2672 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2673 char *tmpbuf = tbuf;
2676 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2681 /* switch to eval mode */
2683 if (IN_PERL_COMPILETIME) {
2684 SAVECOPSTASH_FREE(&PL_compiling);
2685 CopSTASH_set(&PL_compiling, PL_curstash);
2687 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2688 SV *sv = sv_newmortal();
2689 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2690 code, (unsigned long)++PL_evalseq,
2691 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2695 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2696 SAVECOPFILE_FREE(&PL_compiling);
2697 CopFILE_set(&PL_compiling, tmpbuf+2);
2698 SAVECOPLINE(&PL_compiling);
2699 CopLINE_set(&PL_compiling, 1);
2700 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2701 deleting the eval's FILEGV from the stash before gv_check() runs
2702 (i.e. before run-time proper). To work around the coredump that
2703 ensues, we always turn GvMULTI_on for any globals that were
2704 introduced within evals. See force_ident(). GSAR 96-10-12 */
2705 safestr = savepv(tmpbuf);
2706 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2708 #ifdef OP_IN_REGISTER
2713 PL_hints &= HINT_UTF8;
2715 /* we get here either during compilation, or via pp_regcomp at runtime */
2716 runtime = IN_PERL_RUNTIME;
2718 runcv = find_runcv(NULL);
2721 PL_op->op_type = OP_ENTEREVAL;
2722 PL_op->op_flags = 0; /* Avoid uninit warning. */
2723 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2724 PUSHEVAL(cx, 0, Nullgv);
2727 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2729 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2730 POPBLOCK(cx,PL_curpm);
2733 (*startop)->op_type = OP_NULL;
2734 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2736 /* XXX DAPM do this properly one year */
2737 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2739 if (IN_PERL_COMPILETIME)
2740 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2741 #ifdef OP_IN_REGISTER
2749 =for apidoc find_runcv
2751 Locate the CV corresponding to the currently executing sub or eval.
2752 If db_seqp is non_null, skip CVs that are in the DB package and populate
2753 *db_seqp with the cop sequence number at the point that the DB:: code was
2754 entered. (allows debuggers to eval in the scope of the breakpoint rather
2755 than in in the scope of the debuger itself).
2761 Perl_find_runcv(pTHX_ U32 *db_seqp)
2768 *db_seqp = PL_curcop->cop_seq;
2769 for (si = PL_curstackinfo; si; si = si->si_prev) {
2770 for (ix = si->si_cxix; ix >= 0; ix--) {
2771 cx = &(si->si_cxstack[ix]);
2772 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2773 CV *cv = cx->blk_sub.cv;
2774 /* skip DB:: code */
2775 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2776 *db_seqp = cx->blk_oldcop->cop_seq;
2781 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2789 /* Compile a require/do, an eval '', or a /(?{...})/.
2790 * In the last case, startop is non-null, and contains the address of
2791 * a pointer that should be set to the just-compiled code.
2792 * outside is the lexically enclosing CV (if any) that invoked us.
2795 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2797 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2802 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2803 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2808 SAVESPTR(PL_compcv);
2809 PL_compcv = (CV*)NEWSV(1104,0);
2810 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2811 CvEVAL_on(PL_compcv);
2812 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2813 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2815 CvOUTSIDE_SEQ(PL_compcv) = seq;
2816 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2818 /* set up a scratch pad */
2820 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2823 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2825 /* make sure we compile in the right package */
2827 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2828 SAVESPTR(PL_curstash);
2829 PL_curstash = CopSTASH(PL_curcop);
2831 SAVESPTR(PL_beginav);
2832 PL_beginav = newAV();
2833 SAVEFREESV(PL_beginav);
2834 SAVEI32(PL_error_count);
2836 /* try to compile it */
2838 PL_eval_root = Nullop;
2840 PL_curcop = &PL_compiling;
2841 PL_curcop->cop_arybase = 0;
2842 if (saveop && saveop->op_flags & OPf_SPECIAL)
2843 PL_in_eval |= EVAL_KEEPERR;
2846 if (yyparse() || PL_error_count || !PL_eval_root) {
2847 SV **newsp; /* Used by POPBLOCK. */
2848 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2849 I32 optype = 0; /* Might be reset by POPEVAL. */
2854 op_free(PL_eval_root);
2855 PL_eval_root = Nullop;
2857 SP = PL_stack_base + POPMARK; /* pop original mark */
2859 POPBLOCK(cx,PL_curpm);
2865 if (optype == OP_REQUIRE) {
2866 char* msg = SvPVx(ERRSV, n_a);
2867 SV *nsv = cx->blk_eval.old_namesv;
2868 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2870 DIE(aTHX_ "%sCompilation failed in require",
2871 *msg ? msg : "Unknown error\n");
2874 char* msg = SvPVx(ERRSV, n_a);
2876 POPBLOCK(cx,PL_curpm);
2878 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2879 (*msg ? msg : "Unknown error\n"));
2882 char* msg = SvPVx(ERRSV, n_a);
2884 sv_setpv(ERRSV, "Compilation error");
2889 CopLINE_set(&PL_compiling, 0);
2891 *startop = PL_eval_root;
2893 SAVEFREEOP(PL_eval_root);
2895 /* Set the context for this new optree.
2896 * If the last op is an OP_REQUIRE, force scalar context.
2897 * Otherwise, propagate the context from the eval(). */
2898 if (PL_eval_root->op_type == OP_LEAVEEVAL
2899 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2900 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2902 scalar(PL_eval_root);
2903 else if (gimme & G_VOID)
2904 scalarvoid(PL_eval_root);
2905 else if (gimme & G_ARRAY)
2908 scalar(PL_eval_root);
2910 DEBUG_x(dump_eval());
2912 /* Register with debugger: */
2913 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2914 CV *cv = get_cv("DB::postponed", FALSE);
2918 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2920 call_sv((SV*)cv, G_DISCARD);
2924 /* compiled okay, so do it */
2926 CvDEPTH(PL_compcv) = 1;
2927 SP = PL_stack_base + POPMARK; /* pop original mark */
2928 PL_op = saveop; /* The caller may need it. */
2929 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2931 RETURNOP(PL_eval_start);
2935 S_doopen_pm(pTHX_ const char *name, const char *mode)
2937 #ifndef PERL_DISABLE_PMC
2938 STRLEN namelen = strlen(name);
2941 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2942 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2943 char *pmc = SvPV_nolen(pmcsv);
2946 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2947 fp = PerlIO_open(name, mode);
2950 if (PerlLIO_stat(name, &pmstat) < 0 ||
2951 pmstat.st_mtime < pmcstat.st_mtime)
2953 fp = PerlIO_open(pmc, mode);
2956 fp = PerlIO_open(name, mode);
2959 SvREFCNT_dec(pmcsv);
2962 fp = PerlIO_open(name, mode);
2966 return PerlIO_open(name, mode);
2967 #endif /* !PERL_DISABLE_PMC */
2973 register PERL_CONTEXT *cx;
2977 char *tryname = Nullch;
2978 SV *namesv = Nullsv;
2980 I32 gimme = GIMME_V;
2981 PerlIO *tryrsfp = 0;
2983 int filter_has_file = 0;
2984 GV *filter_child_proc = 0;
2985 SV *filter_state = 0;
2992 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2993 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
2994 UV rev = 0, ver = 0, sver = 0;
2996 U8 *s = (U8*)SvPVX(sv);
2997 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2999 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3002 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3005 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3008 if (PERL_REVISION < rev
3009 || (PERL_REVISION == rev
3010 && (PERL_VERSION < ver
3011 || (PERL_VERSION == ver
3012 && PERL_SUBVERSION < sver))))
3014 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3015 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3016 PERL_VERSION, PERL_SUBVERSION);
3018 if (ckWARN(WARN_PORTABLE))
3019 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3020 "v-string in use/require non-portable");
3023 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3024 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3025 + ((NV)PERL_SUBVERSION/(NV)1000000)
3026 + 0.00000099 < SvNV(sv))
3030 NV nver = (nrev - rev) * 1000;
3031 UV ver = (UV)(nver + 0.0009);
3032 NV nsver = (nver - ver) * 1000;
3033 UV sver = (UV)(nsver + 0.0009);
3035 /* help out with the "use 5.6" confusion */
3036 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3037 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3038 " (did you mean v%"UVuf".%03"UVuf"?)--"
3039 "this is only v%d.%d.%d, stopped",
3040 rev, ver, sver, rev, ver/100,
3041 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3044 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3045 "this is only v%d.%d.%d, stopped",
3046 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3053 name = SvPV(sv, len);
3054 if (!(name && len > 0 && *name))
3055 DIE(aTHX_ "Null filename used");
3056 TAINT_PROPER("require");
3057 if (PL_op->op_type == OP_REQUIRE &&
3058 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3059 if (*svp != &PL_sv_undef)
3062 DIE(aTHX_ "Compilation failed in require");
3065 /* prepare to compile file */
3067 if (path_is_absolute(name)) {
3069 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3071 #ifdef MACOS_TRADITIONAL
3075 MacPerl_CanonDir(name, newname, 1);
3076 if (path_is_absolute(newname)) {
3078 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3083 AV *ar = GvAVn(PL_incgv);
3087 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3090 namesv = NEWSV(806, 0);
3091 for (i = 0; i <= AvFILL(ar); i++) {
3092 SV *dirsv = *av_fetch(ar, i, TRUE);
3098 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3099 && !sv_isobject(loader))
3101 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3104 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3105 PTR2UV(SvRV(dirsv)), name);
3106 tryname = SvPVX(namesv);
3117 if (sv_isobject(loader))
3118 count = call_method("INC", G_ARRAY);
3120 count = call_sv(loader, G_ARRAY);
3130 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3134 if (SvTYPE(arg) == SVt_PVGV) {
3135 IO *io = GvIO((GV *)arg);
3140 tryrsfp = IoIFP(io);
3141 if (IoTYPE(io) == IoTYPE_PIPE) {
3142 /* reading from a child process doesn't
3143 nest -- when returning from reading
3144 the inner module, the outer one is
3145 unreadable (closed?) I've tried to
3146 save the gv to manage the lifespan of
3147 the pipe, but this didn't help. XXX */
3148 filter_child_proc = (GV *)arg;
3149 (void)SvREFCNT_inc(filter_child_proc);
3152 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3153 PerlIO_close(IoOFP(io));
3165 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3167 (void)SvREFCNT_inc(filter_sub);
3170 filter_state = SP[i];
3171 (void)SvREFCNT_inc(filter_state);
3175 tryrsfp = PerlIO_open("/dev/null",
3190 filter_has_file = 0;
3191 if (filter_child_proc) {
3192 SvREFCNT_dec(filter_child_proc);
3193 filter_child_proc = 0;
3196 SvREFCNT_dec(filter_state);
3200 SvREFCNT_dec(filter_sub);
3205 if (!path_is_absolute(name)
3206 #ifdef MACOS_TRADITIONAL
3207 /* We consider paths of the form :a:b ambiguous and interpret them first
3208 as global then as local
3210 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3213 char *dir = SvPVx(dirsv, n_a);
3214 #ifdef MACOS_TRADITIONAL
3218 MacPerl_CanonDir(name, buf2, 1);
3219 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3223 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3225 sv_setpv(namesv, unixdir);
3226 sv_catpv(namesv, unixname);
3228 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3231 TAINT_PROPER("require");
3232 tryname = SvPVX(namesv);
3233 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3235 if (tryname[0] == '.' && tryname[1] == '/')
3244 SAVECOPFILE_FREE(&PL_compiling);
3245 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3246 SvREFCNT_dec(namesv);
3248 if (PL_op->op_type == OP_REQUIRE) {
3249 char *msgstr = name;
3250 if (namesv) { /* did we lookup @INC? */
3251 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3252 SV *dirmsgsv = NEWSV(0, 0);
3253 AV *ar = GvAVn(PL_incgv);
3255 sv_catpvn(msg, " in @INC", 8);
3256 if (instr(SvPVX(msg), ".h "))
3257 sv_catpv(msg, " (change .h to .ph maybe?)");
3258 if (instr(SvPVX(msg), ".ph "))
3259 sv_catpv(msg, " (did you run h2ph?)");
3260 sv_catpv(msg, " (@INC contains:");
3261 for (i = 0; i <= AvFILL(ar); i++) {
3262 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3263 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3264 sv_catsv(msg, dirmsgsv);
3266 sv_catpvn(msg, ")", 1);
3267 SvREFCNT_dec(dirmsgsv);
3268 msgstr = SvPV_nolen(msg);
3270 DIE(aTHX_ "Can't locate %s", msgstr);
3276 SETERRNO(0, SS_NORMAL);
3278 /* Assume success here to prevent recursive requirement. */
3280 /* Check whether a hook in @INC has already filled %INC */
3281 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3282 (void)hv_store(GvHVn(PL_incgv), name, len,
3283 (hook_sv ? SvREFCNT_inc(hook_sv)
3284 : newSVpv(CopFILE(&PL_compiling), 0)),
3290 lex_start(sv_2mortal(newSVpvn("",0)));
3291 SAVEGENERICSV(PL_rsfp_filters);
3292 PL_rsfp_filters = Nullav;
3297 SAVESPTR(PL_compiling.cop_warnings);
3298 if (PL_dowarn & G_WARN_ALL_ON)
3299 PL_compiling.cop_warnings = pWARN_ALL ;
3300 else if (PL_dowarn & G_WARN_ALL_OFF)
3301 PL_compiling.cop_warnings = pWARN_NONE ;
3302 else if (PL_taint_warn)
3303 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3305 PL_compiling.cop_warnings = pWARN_STD ;
3306 SAVESPTR(PL_compiling.cop_io);
3307 PL_compiling.cop_io = Nullsv;
3309 if (filter_sub || filter_child_proc) {
3310 SV *datasv = filter_add(run_user_filter, Nullsv);
3311 IoLINES(datasv) = filter_has_file;
3312 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3313 IoTOP_GV(datasv) = (GV *)filter_state;
3314 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3317 /* switch to eval mode */
3318 push_return(PL_op->op_next);
3319 PUSHBLOCK(cx, CXt_EVAL, SP);
3320 PUSHEVAL(cx, name, Nullgv);
3322 SAVECOPLINE(&PL_compiling);
3323 CopLINE_set(&PL_compiling, 0);
3327 /* Store and reset encoding. */
3328 encoding = PL_encoding;
3329 PL_encoding = Nullsv;
3331 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3333 /* Restore encoding. */
3334 PL_encoding = encoding;
3341 return pp_require();
3347 register PERL_CONTEXT *cx;
3349 I32 gimme = GIMME_V, was = PL_sub_generation;
3350 char tbuf[TYPE_DIGITS(long) + 12];
3351 char *tmpbuf = tbuf;
3360 TAINT_PROPER("eval");
3366 /* switch to eval mode */
3368 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3369 SV *sv = sv_newmortal();
3370 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3371 (unsigned long)++PL_evalseq,
3372 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3376 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3377 SAVECOPFILE_FREE(&PL_compiling);
3378 CopFILE_set(&PL_compiling, tmpbuf+2);
3379 SAVECOPLINE(&PL_compiling);
3380 CopLINE_set(&PL_compiling, 1);
3381 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3382 deleting the eval's FILEGV from the stash before gv_check() runs
3383 (i.e. before run-time proper). To work around the coredump that
3384 ensues, we always turn GvMULTI_on for any globals that were
3385 introduced within evals. See force_ident(). GSAR 96-10-12 */
3386 safestr = savepv(tmpbuf);
3387 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3389 PL_hints = PL_op->op_targ;
3390 SAVESPTR(PL_compiling.cop_warnings);
3391 if (specialWARN(PL_curcop->cop_warnings))
3392 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3394 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3395 SAVEFREESV(PL_compiling.cop_warnings);
3397 SAVESPTR(PL_compiling.cop_io);
3398 if (specialCopIO(PL_curcop->cop_io))
3399 PL_compiling.cop_io = PL_curcop->cop_io;
3401 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3402 SAVEFREESV(PL_compiling.cop_io);
3404 /* special case: an eval '' executed within the DB package gets lexically
3405 * placed in the first non-DB CV rather than the current CV - this
3406 * allows the debugger to execute code, find lexicals etc, in the
3407 * scope of the code being debugged. Passing &seq gets find_runcv
3408 * to do the dirty work for us */
3409 runcv = find_runcv(&seq);
3411 push_return(PL_op->op_next);
3412 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3413 PUSHEVAL(cx, 0, Nullgv);
3415 /* prepare to compile string */
3417 if (PERLDB_LINE && PL_curstash != PL_debstash)
3418 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3420 ret = doeval(gimme, NULL, runcv, seq);
3421 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3422 && ret != PL_op->op_next) { /* Successive compilation. */
3423 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3425 return DOCATCH(ret);
3435 register PERL_CONTEXT *cx;
3437 U8 save_flags = PL_op -> op_flags;
3442 retop = pop_return();
3445 if (gimme == G_VOID)
3447 else if (gimme == G_SCALAR) {
3450 if (SvFLAGS(TOPs) & SVs_TEMP)
3453 *MARK = sv_mortalcopy(TOPs);
3457 *MARK = &PL_sv_undef;
3462 /* in case LEAVE wipes old return values */
3463 for (mark = newsp + 1; mark <= SP; mark++) {
3464 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3465 *mark = sv_mortalcopy(*mark);
3466 TAINT_NOT; /* Each item is independent */
3470 PL_curpm = newpm; /* Don't pop $1 et al till now */
3473 assert(CvDEPTH(PL_compcv) == 1);
3475 CvDEPTH(PL_compcv) = 0;
3478 if (optype == OP_REQUIRE &&
3479 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3481 /* Unassume the success we assumed earlier. */
3482 SV *nsv = cx->blk_eval.old_namesv;
3483 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3484 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3485 /* die_where() did LEAVE, or we won't be here */
3489 if (!(save_flags & OPf_SPECIAL))
3499 register PERL_CONTEXT *cx;
3500 I32 gimme = GIMME_V;
3505 push_return(cLOGOP->op_other->op_next);
3506 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3509 PL_in_eval = EVAL_INEVAL;
3512 return DOCATCH(PL_op->op_next);
3523 register PERL_CONTEXT *cx;
3528 retop = pop_return();
3531 if (gimme == G_VOID)
3533 else if (gimme == G_SCALAR) {
3536 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3539 *MARK = sv_mortalcopy(TOPs);
3543 *MARK = &PL_sv_undef;
3548 /* in case LEAVE wipes old return values */
3549 for (mark = newsp + 1; mark <= SP; mark++) {
3550 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3551 *mark = sv_mortalcopy(*mark);
3552 TAINT_NOT; /* Each item is independent */
3556 PL_curpm = newpm; /* Don't pop $1 et al till now */
3564 S_doparseform(pTHX_ SV *sv)
3567 register char *s = SvPV_force(sv, len);
3568 register char *send = s + len;
3569 register char *base = Nullch;
3570 register I32 skipspaces = 0;
3571 bool noblank = FALSE;
3572 bool repeat = FALSE;
3573 bool postspace = FALSE;
3579 int maxops = 2; /* FF_LINEMARK + FF_END) */
3582 Perl_croak(aTHX_ "Null picture in formline");
3584 /* estimate the buffer size needed */
3585 for (base = s; s <= send; s++) {
3586 if (*s == '\n' || *s == '@' || *s == '^')
3592 New(804, fops, maxops, U32);
3597 *fpc++ = FF_LINEMARK;
3598 noblank = repeat = FALSE;
3616 case ' ': case '\t':
3627 *fpc++ = FF_LITERAL;
3635 *fpc++ = (U16)skipspaces;
3639 *fpc++ = FF_NEWLINE;
3643 arg = fpc - linepc + 1;
3650 *fpc++ = FF_LINEMARK;
3651 noblank = repeat = FALSE;
3660 ischop = s[-1] == '^';
3666 arg = (s - base) - 1;
3668 *fpc++ = FF_LITERAL;
3677 *fpc++ = FF_LINEGLOB;
3679 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3680 arg = ischop ? 512 : 0;
3690 arg |= 256 + (s - f);
3692 *fpc++ = s - base; /* fieldsize for FETCH */
3693 *fpc++ = FF_DECIMAL;
3696 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3697 arg = ischop ? 512 : 0;
3699 s++; /* skip the '0' first */
3708 arg |= 256 + (s - f);
3710 *fpc++ = s - base; /* fieldsize for FETCH */
3711 *fpc++ = FF_0DECIMAL;
3716 bool ismore = FALSE;
3719 while (*++s == '>') ;
3720 prespace = FF_SPACE;
3722 else if (*s == '|') {
3723 while (*++s == '|') ;
3724 prespace = FF_HALFSPACE;
3729 while (*++s == '<') ;
3732 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3736 *fpc++ = s - base; /* fieldsize for FETCH */
3738 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3741 *fpc++ = (U16)prespace;
3755 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3757 { /* need to jump to the next word */
3759 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3760 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3761 s = SvPVX(sv) + SvCUR(sv) + z;
3763 Copy(fops, s, arg, U32);
3765 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3770 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3772 SV *datasv = FILTER_DATA(idx);
3773 int filter_has_file = IoLINES(datasv);
3774 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3775 SV *filter_state = (SV *)IoTOP_GV(datasv);
3776 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3779 /* I was having segfault trouble under Linux 2.2.5 after a
3780 parse error occured. (Had to hack around it with a test
3781 for PL_error_count == 0.) Solaris doesn't segfault --
3782 not sure where the trouble is yet. XXX */
3784 if (filter_has_file) {
3785 len = FILTER_READ(idx+1, buf_sv, maxlen);
3788 if (filter_sub && len >= 0) {
3799 PUSHs(sv_2mortal(newSViv(maxlen)));
3801 PUSHs(filter_state);
3804 count = call_sv(filter_sub, G_SCALAR);
3820 IoLINES(datasv) = 0;
3821 if (filter_child_proc) {
3822 SvREFCNT_dec(filter_child_proc);
3823 IoFMT_GV(datasv) = Nullgv;
3826 SvREFCNT_dec(filter_state);
3827 IoTOP_GV(datasv) = Nullgv;
3830 SvREFCNT_dec(filter_sub);
3831 IoBOTTOM_GV(datasv) = Nullgv;
3833 filter_del(run_user_filter);
3839 /* perhaps someone can come up with a better name for
3840 this? it is not really "absolute", per se ... */
3842 S_path_is_absolute(pTHX_ char *name)
3844 if (PERL_FILE_IS_ABSOLUTE(name)
3845 #ifdef MACOS_TRADITIONAL
3848 || (*name == '.' && (name[1] == '/' ||
3849 (name[1] == '.' && name[2] == '/'))))