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",
3191 filter_has_file = 0;
3192 if (filter_child_proc) {
3193 SvREFCNT_dec(filter_child_proc);
3194 filter_child_proc = 0;
3197 SvREFCNT_dec(filter_state);
3201 SvREFCNT_dec(filter_sub);
3206 if (!path_is_absolute(name)
3207 #ifdef MACOS_TRADITIONAL
3208 /* We consider paths of the form :a:b ambiguous and interpret them first
3209 as global then as local
3211 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3214 char *dir = SvPVx(dirsv, n_a);
3215 #ifdef MACOS_TRADITIONAL
3219 MacPerl_CanonDir(name, buf2, 1);
3220 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3224 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3226 sv_setpv(namesv, unixdir);
3227 sv_catpv(namesv, unixname);
3229 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3232 TAINT_PROPER("require");
3233 tryname = SvPVX(namesv);
3234 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3236 if (tryname[0] == '.' && tryname[1] == '/')
3245 SAVECOPFILE_FREE(&PL_compiling);
3246 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3247 SvREFCNT_dec(namesv);
3249 if (PL_op->op_type == OP_REQUIRE) {
3250 char *msgstr = name;
3251 if (namesv) { /* did we lookup @INC? */
3252 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3253 SV *dirmsgsv = NEWSV(0, 0);
3254 AV *ar = GvAVn(PL_incgv);
3256 sv_catpvn(msg, " in @INC", 8);
3257 if (instr(SvPVX(msg), ".h "))
3258 sv_catpv(msg, " (change .h to .ph maybe?)");
3259 if (instr(SvPVX(msg), ".ph "))
3260 sv_catpv(msg, " (did you run h2ph?)");
3261 sv_catpv(msg, " (@INC contains:");
3262 for (i = 0; i <= AvFILL(ar); i++) {
3263 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3264 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3265 sv_catsv(msg, dirmsgsv);
3267 sv_catpvn(msg, ")", 1);
3268 SvREFCNT_dec(dirmsgsv);
3269 msgstr = SvPV_nolen(msg);
3271 DIE(aTHX_ "Can't locate %s", msgstr);
3277 SETERRNO(0, SS_NORMAL);
3279 /* Assume success here to prevent recursive requirement. */
3281 /* Check whether a hook in @INC has already filled %INC */
3282 if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3283 (void)hv_store(GvHVn(PL_incgv), name, len,
3284 (hook_sv ? SvREFCNT_inc(hook_sv)
3285 : newSVpv(CopFILE(&PL_compiling), 0)),
3291 lex_start(sv_2mortal(newSVpvn("",0)));
3292 SAVEGENERICSV(PL_rsfp_filters);
3293 PL_rsfp_filters = Nullav;
3298 SAVESPTR(PL_compiling.cop_warnings);
3299 if (PL_dowarn & G_WARN_ALL_ON)
3300 PL_compiling.cop_warnings = pWARN_ALL ;
3301 else if (PL_dowarn & G_WARN_ALL_OFF)
3302 PL_compiling.cop_warnings = pWARN_NONE ;
3303 else if (PL_taint_warn)
3304 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3306 PL_compiling.cop_warnings = pWARN_STD ;
3307 SAVESPTR(PL_compiling.cop_io);
3308 PL_compiling.cop_io = Nullsv;
3310 if (filter_sub || filter_child_proc) {
3311 SV *datasv = filter_add(run_user_filter, Nullsv);
3312 IoLINES(datasv) = filter_has_file;
3313 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3314 IoTOP_GV(datasv) = (GV *)filter_state;
3315 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3318 /* switch to eval mode */
3319 push_return(PL_op->op_next);
3320 PUSHBLOCK(cx, CXt_EVAL, SP);
3321 PUSHEVAL(cx, name, Nullgv);
3323 SAVECOPLINE(&PL_compiling);
3324 CopLINE_set(&PL_compiling, 0);
3328 /* Store and reset encoding. */
3329 encoding = PL_encoding;
3330 PL_encoding = Nullsv;
3332 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3334 /* Restore encoding. */
3335 PL_encoding = encoding;
3342 return pp_require();
3348 register PERL_CONTEXT *cx;
3350 I32 gimme = GIMME_V, was = PL_sub_generation;
3351 char tbuf[TYPE_DIGITS(long) + 12];
3352 char *tmpbuf = tbuf;
3361 TAINT_PROPER("eval");
3367 /* switch to eval mode */
3369 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3370 SV *sv = sv_newmortal();
3371 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3372 (unsigned long)++PL_evalseq,
3373 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3377 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3378 SAVECOPFILE_FREE(&PL_compiling);
3379 CopFILE_set(&PL_compiling, tmpbuf+2);
3380 SAVECOPLINE(&PL_compiling);
3381 CopLINE_set(&PL_compiling, 1);
3382 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3383 deleting the eval's FILEGV from the stash before gv_check() runs
3384 (i.e. before run-time proper). To work around the coredump that
3385 ensues, we always turn GvMULTI_on for any globals that were
3386 introduced within evals. See force_ident(). GSAR 96-10-12 */
3387 safestr = savepv(tmpbuf);
3388 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3390 PL_hints = PL_op->op_targ;
3391 SAVESPTR(PL_compiling.cop_warnings);
3392 if (specialWARN(PL_curcop->cop_warnings))
3393 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3395 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3396 SAVEFREESV(PL_compiling.cop_warnings);
3398 SAVESPTR(PL_compiling.cop_io);
3399 if (specialCopIO(PL_curcop->cop_io))
3400 PL_compiling.cop_io = PL_curcop->cop_io;
3402 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3403 SAVEFREESV(PL_compiling.cop_io);
3405 /* special case: an eval '' executed within the DB package gets lexically
3406 * placed in the first non-DB CV rather than the current CV - this
3407 * allows the debugger to execute code, find lexicals etc, in the
3408 * scope of the code being debugged. Passing &seq gets find_runcv
3409 * to do the dirty work for us */
3410 runcv = find_runcv(&seq);
3412 push_return(PL_op->op_next);
3413 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3414 PUSHEVAL(cx, 0, Nullgv);
3416 /* prepare to compile string */
3418 if (PERLDB_LINE && PL_curstash != PL_debstash)
3419 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3421 ret = doeval(gimme, NULL, runcv, seq);
3422 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3423 && ret != PL_op->op_next) { /* Successive compilation. */
3424 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3426 return DOCATCH(ret);
3436 register PERL_CONTEXT *cx;
3438 U8 save_flags = PL_op -> op_flags;
3443 retop = pop_return();
3446 if (gimme == G_VOID)
3448 else if (gimme == G_SCALAR) {
3451 if (SvFLAGS(TOPs) & SVs_TEMP)
3454 *MARK = sv_mortalcopy(TOPs);
3458 *MARK = &PL_sv_undef;
3463 /* in case LEAVE wipes old return values */
3464 for (mark = newsp + 1; mark <= SP; mark++) {
3465 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3466 *mark = sv_mortalcopy(*mark);
3467 TAINT_NOT; /* Each item is independent */
3471 PL_curpm = newpm; /* Don't pop $1 et al till now */
3474 assert(CvDEPTH(PL_compcv) == 1);
3476 CvDEPTH(PL_compcv) = 0;
3479 if (optype == OP_REQUIRE &&
3480 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3482 /* Unassume the success we assumed earlier. */
3483 SV *nsv = cx->blk_eval.old_namesv;
3484 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3485 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3486 /* die_where() did LEAVE, or we won't be here */
3490 if (!(save_flags & OPf_SPECIAL))
3500 register PERL_CONTEXT *cx;
3501 I32 gimme = GIMME_V;
3506 push_return(cLOGOP->op_other->op_next);
3507 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3510 PL_in_eval = EVAL_INEVAL;
3513 return DOCATCH(PL_op->op_next);
3524 register PERL_CONTEXT *cx;
3529 retop = pop_return();
3532 if (gimme == G_VOID)
3534 else if (gimme == G_SCALAR) {
3537 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3540 *MARK = sv_mortalcopy(TOPs);
3544 *MARK = &PL_sv_undef;
3549 /* in case LEAVE wipes old return values */
3550 for (mark = newsp + 1; mark <= SP; mark++) {
3551 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3552 *mark = sv_mortalcopy(*mark);
3553 TAINT_NOT; /* Each item is independent */
3557 PL_curpm = newpm; /* Don't pop $1 et al till now */
3565 S_doparseform(pTHX_ SV *sv)
3568 register char *s = SvPV_force(sv, len);
3569 register char *send = s + len;
3570 register char *base = Nullch;
3571 register I32 skipspaces = 0;
3572 bool noblank = FALSE;
3573 bool repeat = FALSE;
3574 bool postspace = FALSE;
3580 int maxops = 2; /* FF_LINEMARK + FF_END) */
3583 Perl_croak(aTHX_ "Null picture in formline");
3585 /* estimate the buffer size needed */
3586 for (base = s; s <= send; s++) {
3587 if (*s == '\n' || *s == '@' || *s == '^')
3593 New(804, fops, maxops, U32);
3598 *fpc++ = FF_LINEMARK;
3599 noblank = repeat = FALSE;
3617 case ' ': case '\t':
3628 *fpc++ = FF_LITERAL;
3636 *fpc++ = (U16)skipspaces;
3640 *fpc++ = FF_NEWLINE;
3644 arg = fpc - linepc + 1;
3651 *fpc++ = FF_LINEMARK;
3652 noblank = repeat = FALSE;
3661 ischop = s[-1] == '^';
3667 arg = (s - base) - 1;
3669 *fpc++ = FF_LITERAL;
3678 *fpc++ = FF_LINEGLOB;
3680 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3681 arg = ischop ? 512 : 0;
3691 arg |= 256 + (s - f);
3693 *fpc++ = s - base; /* fieldsize for FETCH */
3694 *fpc++ = FF_DECIMAL;
3697 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3698 arg = ischop ? 512 : 0;
3700 s++; /* skip the '0' first */
3709 arg |= 256 + (s - f);
3711 *fpc++ = s - base; /* fieldsize for FETCH */
3712 *fpc++ = FF_0DECIMAL;
3717 bool ismore = FALSE;
3720 while (*++s == '>') ;
3721 prespace = FF_SPACE;
3723 else if (*s == '|') {
3724 while (*++s == '|') ;
3725 prespace = FF_HALFSPACE;
3730 while (*++s == '<') ;
3733 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3737 *fpc++ = s - base; /* fieldsize for FETCH */
3739 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3742 *fpc++ = (U16)prespace;
3756 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3758 { /* need to jump to the next word */
3760 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3761 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3762 s = SvPVX(sv) + SvCUR(sv) + z;
3764 Copy(fops, s, arg, U32);
3766 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3771 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3773 SV *datasv = FILTER_DATA(idx);
3774 int filter_has_file = IoLINES(datasv);
3775 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3776 SV *filter_state = (SV *)IoTOP_GV(datasv);
3777 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3780 /* I was having segfault trouble under Linux 2.2.5 after a
3781 parse error occured. (Had to hack around it with a test
3782 for PL_error_count == 0.) Solaris doesn't segfault --
3783 not sure where the trouble is yet. XXX */
3785 if (filter_has_file) {
3786 len = FILTER_READ(idx+1, buf_sv, maxlen);
3789 if (filter_sub && len >= 0) {
3800 PUSHs(sv_2mortal(newSViv(maxlen)));
3802 PUSHs(filter_state);
3805 count = call_sv(filter_sub, G_SCALAR);
3821 IoLINES(datasv) = 0;
3822 if (filter_child_proc) {
3823 SvREFCNT_dec(filter_child_proc);
3824 IoFMT_GV(datasv) = Nullgv;
3827 SvREFCNT_dec(filter_state);
3828 IoTOP_GV(datasv) = Nullgv;
3831 SvREFCNT_dec(filter_sub);
3832 IoBOTTOM_GV(datasv) = Nullgv;
3834 filter_del(run_user_filter);
3840 /* perhaps someone can come up with a better name for
3841 this? it is not really "absolute", per se ... */
3843 S_path_is_absolute(pTHX_ char *name)
3845 if (PERL_FILE_IS_ABSOLUTE(name)
3846 #ifdef MACOS_TRADITIONAL
3849 || (*name == '.' && (name[1] == '/' ||
3850 (name[1] == '.' && name[2] == '/'))))