3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
23 #define WORD_ALIGN sizeof(U16)
26 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
29 #define CALLOP this->*PL_op
32 static void *docatch_body _((va_list args));
33 static OP *docatch _((OP *o));
34 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
35 static void doparseform _((SV *sv));
36 static I32 dopoptoeval _((I32 startingblock));
37 static I32 dopoptolabel _((char *label));
38 static I32 dopoptoloop _((I32 startingblock));
39 static I32 dopoptosub _((I32 startingblock));
40 static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
41 static void save_lines _((AV *array, SV *sv));
42 static I32 sortcv _((SV *a, SV *b));
43 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
44 static OP *doeval _((int gimme, OP** startop));
45 static PerlIO *doopen_pmc _((const char *name, const char *mode));
46 static I32 sv_ncmp _((SV *a, SV *b));
47 static I32 sv_i_ncmp _((SV *a, SV *b));
48 static I32 amagic_ncmp _((SV *a, SV *b));
49 static I32 amagic_i_ncmp _((SV *a, SV *b));
50 static I32 amagic_cmp _((SV *str1, SV *str2));
51 static I32 amagic_cmp_locale _((SV *str1, SV *str2));
52 static void free_closures _((void));
61 cxix = dopoptosub(cxstack_ix);
65 switch (cxstack[cxix].blk_gimme) {
82 /* XXXX Should store the old value to allow for tie/overload - and
83 restore in regcomp, where marked with XXXX. */
91 register PMOP *pm = (PMOP*)cLOGOP->op_other;
95 MAGIC *mg = Null(MAGIC*);
99 SV *sv = SvRV(tmpstr);
101 mg = mg_find(sv, 'r');
104 regexp *re = (regexp *)mg->mg_obj;
105 ReREFCNT_dec(pm->op_pmregexp);
106 pm->op_pmregexp = ReREFCNT_inc(re);
109 t = SvPV(tmpstr, len);
111 /* Check against the last compiled regexp. */
112 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
113 pm->op_pmregexp->prelen != len ||
114 memNE(pm->op_pmregexp->precomp, t, len))
116 if (pm->op_pmregexp) {
117 ReREFCNT_dec(pm->op_pmregexp);
118 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
120 if (PL_op->op_flags & OPf_SPECIAL)
121 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
123 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
124 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
125 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
126 inside tie/overload accessors. */
130 #ifndef INCOMPLETE_TAINTS
133 pm->op_pmdynflags |= PMdf_TAINTED;
135 pm->op_pmdynflags &= ~PMdf_TAINTED;
139 if (!pm->op_pmregexp->prelen && PL_curpm)
141 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
142 pm->op_pmflags |= PMf_WHITE;
144 if (pm->op_pmflags & PMf_KEEP) {
145 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
146 cLOGOP->op_first->op_next = PL_op->op_next;
154 register PMOP *pm = (PMOP*) cLOGOP->op_other;
155 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
156 register SV *dstr = cx->sb_dstr;
157 register char *s = cx->sb_s;
158 register char *m = cx->sb_m;
159 char *orig = cx->sb_orig;
160 register REGEXP *rx = cx->sb_rx;
162 rxres_restore(&cx->sb_rxres, rx);
164 if (cx->sb_iters++) {
165 if (cx->sb_iters > cx->sb_maxiters)
166 DIE("Substitution loop");
168 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
169 cx->sb_rxtainted |= 2;
170 sv_catsv(dstr, POPs);
173 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
174 s == m, cx->sb_targ, NULL,
175 ((cx->sb_rflags & REXEC_COPY_STR)
176 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
177 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
179 SV *targ = cx->sb_targ;
180 sv_catpvn(dstr, s, cx->sb_strend - s);
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 (void)SvOOK_off(targ);
185 Safefree(SvPVX(targ));
186 SvPVX(targ) = SvPVX(dstr);
187 SvCUR_set(targ, SvCUR(dstr));
188 SvLEN_set(targ, SvLEN(dstr));
192 TAINT_IF(cx->sb_rxtainted & 1);
193 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
195 (void)SvPOK_only(targ);
196 TAINT_IF(cx->sb_rxtainted);
200 LEAVE_SCOPE(cx->sb_oldsave);
202 RETURNOP(pm->op_next);
205 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
208 cx->sb_orig = orig = rx->subbeg;
210 cx->sb_strend = s + (cx->sb_strend - m);
212 cx->sb_m = m = rx->startp[0] + orig;
213 sv_catpvn(dstr, s, m-s);
214 cx->sb_s = rx->endp[0] + orig;
215 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
216 rxres_save(&cx->sb_rxres, rx);
217 RETURNOP(pm->op_pmreplstart);
221 rxres_save(void **rsp, REGEXP *rx)
226 if (!p || p[1] < rx->nparens) {
227 i = 6 + rx->nparens * 2;
235 *p++ = (UV)(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
236 RX_MATCH_COPIED_off(rx);
240 *p++ = (UV)rx->subbeg;
241 *p++ = (UV)rx->sublen;
242 for (i = 0; i <= rx->nparens; ++i) {
243 *p++ = (UV)rx->startp[i];
244 *p++ = (UV)rx->endp[i];
249 rxres_restore(void **rsp, REGEXP *rx)
254 if (RX_MATCH_COPIED(rx))
255 Safefree(rx->subbeg);
256 RX_MATCH_COPIED_set(rx, *p);
261 rx->subbeg = (char*)(*p++);
262 rx->sublen = (I32)(*p++);
263 for (i = 0; i <= rx->nparens; ++i) {
264 rx->startp[i] = (I32)(*p++);
265 rx->endp[i] = (I32)(*p++);
270 rxres_free(void **rsp)
275 Safefree((char*)(*p));
283 djSP; dMARK; dORIGMARK;
284 register SV *tmpForm = *++MARK;
296 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
302 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
304 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
305 SvREADONLY_off(tmpForm);
306 doparseform(tmpForm);
309 SvPV_force(PL_formtarget, len);
310 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
312 f = SvPV(tmpForm, len);
313 /* need to jump to the next word */
314 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
323 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
324 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
325 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
326 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
327 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
329 case FF_CHECKNL: name = "CHECKNL"; break;
330 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
331 case FF_SPACE: name = "SPACE"; break;
332 case FF_HALFSPACE: name = "HALFSPACE"; break;
333 case FF_ITEM: name = "ITEM"; break;
334 case FF_CHOP: name = "CHOP"; break;
335 case FF_LINEGLOB: name = "LINEGLOB"; break;
336 case FF_NEWLINE: name = "NEWLINE"; break;
337 case FF_MORE: name = "MORE"; break;
338 case FF_LINEMARK: name = "LINEMARK"; break;
339 case FF_END: name = "END"; break;
342 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
344 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
372 if (ckWARN(WARN_SYNTAX))
373 warner(WARN_SYNTAX, "Not enough format arguments");
378 item = s = SvPV(sv, len);
381 itemsize = sv_len_utf8(sv);
382 if (itemsize != len) {
384 if (itemsize > fieldsize) {
385 itemsize = fieldsize;
386 itembytes = itemsize;
387 sv_pos_u2b(sv, &itembytes, 0);
391 send = chophere = s + itembytes;
400 sv_pos_b2u(sv, &itemsize);
404 if (itemsize > fieldsize)
405 itemsize = fieldsize;
406 send = chophere = s + itemsize;
418 item = s = SvPV(sv, len);
421 itemsize = sv_len_utf8(sv);
422 if (itemsize != len) {
424 if (itemsize <= fieldsize) {
425 send = chophere = s + itemsize;
436 itemsize = fieldsize;
437 itembytes = itemsize;
438 sv_pos_u2b(sv, &itembytes, 0);
439 send = chophere = s + itembytes;
440 while (s < send || (s == send && isSPACE(*s))) {
450 if (strchr(PL_chopset, *s))
455 itemsize = chophere - item;
456 sv_pos_b2u(sv, &itemsize);
461 if (itemsize <= fieldsize) {
462 send = chophere = s + itemsize;
473 itemsize = fieldsize;
474 send = chophere = s + itemsize;
475 while (s < send || (s == send && isSPACE(*s))) {
485 if (strchr(PL_chopset, *s))
490 itemsize = chophere - item;
495 arg = fieldsize - itemsize;
504 arg = fieldsize - itemsize;
519 switch (UTF8SKIP(s)) {
530 if ( !((*t++ = *s++) & ~31) )
538 int ch = *t++ = *s++;
541 if ( !((*t++ = *s++) & ~31) )
550 while (*s && isSPACE(*s))
557 item = s = SvPV(sv, len);
570 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
571 sv_catpvn(PL_formtarget, item, itemsize);
572 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
573 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
578 /* If the field is marked with ^ and the value is undefined,
581 if ((arg & 512) && !SvOK(sv)) {
589 /* Formats aren't yet marked for locales, so assume "yes". */
592 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
594 sprintf(t, "%*.0f", (int) fieldsize, value);
601 while (t-- > linemark && *t == ' ') ;
609 if (arg) { /* repeat until fields exhausted? */
611 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
612 lines += FmLINES(PL_formtarget);
615 if (strnEQ(linemark, linemark - arg, arg))
616 DIE("Runaway format");
618 FmLINES(PL_formtarget) = lines;
620 RETURNOP(cLISTOP->op_first);
633 while (*s && isSPACE(*s) && s < send)
637 arg = fieldsize - itemsize;
644 if (strnEQ(s," ",3)) {
645 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
656 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
657 FmLINES(PL_formtarget) += lines;
669 if (PL_stack_base + *PL_markstack_ptr == SP) {
671 if (GIMME_V == G_SCALAR)
672 XPUSHs(sv_2mortal(newSViv(0)));
673 RETURNOP(PL_op->op_next->op_next);
675 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
676 pp_pushmark(ARGS); /* push dst */
677 pp_pushmark(ARGS); /* push src */
678 ENTER; /* enter outer scope */
681 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
683 ENTER; /* enter inner scope */
686 src = PL_stack_base[*PL_markstack_ptr];
691 if (PL_op->op_type == OP_MAPSTART)
692 pp_pushmark(ARGS); /* push top */
693 return ((LOGOP*)PL_op->op_next)->op_other;
698 DIE("panic: mapstart"); /* uses grepstart */
704 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
710 ++PL_markstack_ptr[-1];
712 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
713 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
714 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
719 PL_markstack_ptr[-1] += shift;
720 *PL_markstack_ptr += shift;
724 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
727 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
729 LEAVE; /* exit inner scope */
732 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
736 (void)POPMARK; /* pop top */
737 LEAVE; /* exit outer scope */
738 (void)POPMARK; /* pop src */
739 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
740 (void)POPMARK; /* pop dst */
741 SP = PL_stack_base + POPMARK; /* pop original mark */
742 if (gimme == G_SCALAR) {
746 else if (gimme == G_ARRAY)
753 ENTER; /* enter inner scope */
756 src = PL_stack_base[PL_markstack_ptr[-1]];
760 RETURNOP(cLOGOP->op_other);
765 sv_ncmp (SV *a, SV *b)
767 double nv1 = SvNV(a);
768 double nv2 = SvNV(b);
769 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
772 sv_i_ncmp (SV *a, SV *b)
776 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
778 #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
780 if (PL_amagic_generation) { \
781 if (SvAMAGIC(left)||SvAMAGIC(right))\
782 *svp = amagic_call(left, \
790 amagic_ncmp(register SV *a, register SV *b)
793 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
798 I32 i = SvIVX(tmpsv);
808 return sv_ncmp(a, b);
812 amagic_i_ncmp(register SV *a, register SV *b)
815 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
820 I32 i = SvIVX(tmpsv);
830 return sv_i_ncmp(a, b);
834 amagic_cmp(register SV *str1, register SV *str2)
837 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
842 I32 i = SvIVX(tmpsv);
852 return sv_cmp(str1, str2);
856 amagic_cmp_locale(register SV *str1, register SV *str2)
859 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
864 I32 i = SvIVX(tmpsv);
874 return sv_cmp_locale(str1, str2);
879 djSP; dMARK; dORIGMARK;
881 SV **myorigmark = ORIGMARK;
887 OP* nextop = PL_op->op_next;
890 if (gimme != G_ARRAY) {
896 SAVEPPTR(PL_sortcop);
897 if (PL_op->op_flags & OPf_STACKED) {
898 if (PL_op->op_flags & OPf_SPECIAL) {
899 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
900 kid = kUNOP->op_first; /* pass rv2gv */
901 kid = kUNOP->op_first; /* pass leave */
902 PL_sortcop = kid->op_next;
903 stash = PL_curcop->cop_stash;
906 cv = sv_2cv(*++MARK, &stash, &gv, 0);
907 if (!(cv && CvROOT(cv))) {
909 SV *tmpstr = sv_newmortal();
910 gv_efullname3(tmpstr, gv, Nullch);
911 if (cv && CvXSUB(cv))
912 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
913 DIE("Undefined sort subroutine \"%s\" called",
918 DIE("Xsub called in sort");
919 DIE("Undefined subroutine in sort");
921 DIE("Not a CODE reference in sort");
923 PL_sortcop = CvSTART(cv);
924 SAVESPTR(CvROOT(cv)->op_ppaddr);
925 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
928 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
933 stash = PL_curcop->cop_stash;
937 while (MARK < SP) { /* This may or may not shift down one here. */
939 if (*up = *++MARK) { /* Weed out nulls. */
941 if (!PL_sortcop && !SvPOK(*up)) {
946 (void)sv_2pv(*up, &n_a);
951 max = --up - myorigmark;
956 bool oldcatch = CATCH_GET;
962 PUSHSTACKi(PERLSI_SORT);
963 if (PL_sortstash != stash) {
964 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
965 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
966 PL_sortstash = stash;
969 SAVESPTR(GvSV(PL_firstgv));
970 SAVESPTR(GvSV(PL_secondgv));
972 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
973 if (!(PL_op->op_flags & OPf_SPECIAL)) {
974 bool hasargs = FALSE;
975 cx->cx_type = CXt_SUB;
976 cx->blk_gimme = G_SCALAR;
979 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
981 PL_sortcxix = cxstack_ix;
982 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
984 POPBLOCK(cx,PL_curpm);
992 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
993 qsortsv(ORIGMARK+1, max,
994 (PL_op->op_private & OPpSORT_NUMERIC)
995 ? ( (PL_op->op_private & OPpSORT_INTEGER)
997 ? FUNC_NAME_TO_PTR(amagic_i_ncmp)
998 : FUNC_NAME_TO_PTR(sv_i_ncmp))
1000 ? FUNC_NAME_TO_PTR(amagic_ncmp)
1001 : FUNC_NAME_TO_PTR(sv_ncmp)))
1002 : ( (PL_op->op_private & OPpLOCALE)
1004 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
1005 : FUNC_NAME_TO_PTR(sv_cmp_locale))
1007 ? FUNC_NAME_TO_PTR(amagic_cmp)
1008 : FUNC_NAME_TO_PTR(sv_cmp) )));
1009 if (PL_op->op_private & OPpSORT_REVERSE) {
1010 SV **p = ORIGMARK+1;
1011 SV **q = ORIGMARK+max;
1021 PL_stack_sp = ORIGMARK + max;
1029 if (GIMME == G_ARRAY)
1030 return cCONDOP->op_true;
1031 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1032 return cCONDOP->op_false;
1034 return cCONDOP->op_true;
1041 if (GIMME == G_ARRAY) {
1042 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1046 SV *targ = PAD_SV(PL_op->op_targ);
1048 if ((PL_op->op_private & OPpFLIP_LINENUM)
1049 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1051 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1052 if (PL_op->op_flags & OPf_SPECIAL) {
1060 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1073 if (GIMME == G_ARRAY) {
1079 if (SvGMAGICAL(left))
1081 if (SvGMAGICAL(right))
1084 if (SvNIOKp(left) || !SvPOKp(left) ||
1085 (looks_like_number(left) && *SvPVX(left) != '0') )
1087 if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1088 croak("Range iterator outside integer range");
1099 sv = sv_2mortal(newSViv(i++));
1104 SV *final = sv_mortalcopy(right);
1106 char *tmps = SvPV(final, len);
1108 sv = sv_mortalcopy(left);
1110 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1112 if (strEQ(SvPVX(sv),tmps))
1114 sv = sv_2mortal(newSVsv(sv));
1121 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1123 if ((PL_op->op_private & OPpFLIP_LINENUM)
1124 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
1126 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1127 sv_catpv(targ, "E0");
1138 dopoptolabel(char *label)
1142 register PERL_CONTEXT *cx;
1144 for (i = cxstack_ix; i >= 0; i--) {
1146 switch (CxTYPE(cx)) {
1148 if (ckWARN(WARN_UNSAFE))
1149 warner(WARN_UNSAFE, "Exiting substitution via %s",
1150 PL_op_name[PL_op->op_type]);
1153 if (ckWARN(WARN_UNSAFE))
1154 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1155 PL_op_name[PL_op->op_type]);
1158 if (ckWARN(WARN_UNSAFE))
1159 warner(WARN_UNSAFE, "Exiting eval via %s",
1160 PL_op_name[PL_op->op_type]);
1163 if (ckWARN(WARN_UNSAFE))
1164 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1165 PL_op_name[PL_op->op_type]);
1168 if (!cx->blk_loop.label ||
1169 strNE(label, cx->blk_loop.label) ) {
1170 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1171 (long)i, cx->blk_loop.label));
1174 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
1184 I32 gimme = block_gimme();
1185 return (gimme == G_VOID) ? G_SCALAR : gimme;
1194 cxix = dopoptosub(cxstack_ix);
1198 switch (cxstack[cxix].blk_gimme) {
1206 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1213 dopoptosub(I32 startingblock)
1216 return dopoptosub_at(cxstack, startingblock);
1220 dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1224 register PERL_CONTEXT *cx;
1225 for (i = startingblock; i >= 0; i--) {
1227 switch (CxTYPE(cx)) {
1232 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
1240 dopoptoeval(I32 startingblock)
1244 register PERL_CONTEXT *cx;
1245 for (i = startingblock; i >= 0; i--) {
1247 switch (CxTYPE(cx)) {
1251 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
1259 dopoptoloop(I32 startingblock)
1263 register PERL_CONTEXT *cx;
1264 for (i = startingblock; i >= 0; i--) {
1266 switch (CxTYPE(cx)) {
1268 if (ckWARN(WARN_UNSAFE))
1269 warner(WARN_UNSAFE, "Exiting substitution via %s",
1270 PL_op_name[PL_op->op_type]);
1273 if (ckWARN(WARN_UNSAFE))
1274 warner(WARN_UNSAFE, "Exiting subroutine via %s",
1275 PL_op_name[PL_op->op_type]);
1278 if (ckWARN(WARN_UNSAFE))
1279 warner(WARN_UNSAFE, "Exiting eval via %s",
1280 PL_op_name[PL_op->op_type]);
1283 if (ckWARN(WARN_UNSAFE))
1284 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
1285 PL_op_name[PL_op->op_type]);
1288 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1299 register PERL_CONTEXT *cx;
1303 while (cxstack_ix > cxix) {
1304 cx = &cxstack[cxstack_ix];
1305 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1306 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1307 /* Note: we don't need to restore the base context info till the end. */
1308 switch (CxTYPE(cx)) {
1311 continue; /* not break */
1329 * Closures mentioned at top level of eval cannot be referenced
1330 * again, and their presence indirectly causes a memory leak.
1331 * (Note that the fact that compcv and friends are still set here
1332 * is, AFAIK, an accident.) --Chip
1334 * XXX need to get comppad et al from eval's cv rather than
1335 * relying on the incidental global values.
1341 SV **svp = AvARRAY(PL_comppad_name);
1343 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
1345 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
1347 svp[ix] = &PL_sv_undef;
1351 SvREFCNT_dec(CvOUTSIDE(sv));
1352 CvOUTSIDE(sv) = Nullcv;
1365 die_where(char *message, STRLEN msglen)
1371 register PERL_CONTEXT *cx;
1376 if (PL_in_eval & EVAL_KEEPERR) {
1379 svp = hv_fetch(ERRHV, message, msglen, TRUE);
1382 static char prefix[] = "\t(in cleanup) ";
1384 sv_upgrade(*svp, SVt_IV);
1385 (void)SvIOK_only(*svp);
1388 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1389 sv_catpvn(err, prefix, sizeof(prefix)-1);
1390 sv_catpvn(err, message, msglen);
1391 if (ckWARN(WARN_UNSAFE)) {
1392 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1393 warner(WARN_UNSAFE, SvPVX(err)+start);
1400 sv_setpvn(ERRSV, message, msglen);
1403 message = SvPVx(ERRSV, msglen);
1405 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
1413 if (cxix < cxstack_ix)
1416 POPBLOCK(cx,PL_curpm);
1417 if (CxTYPE(cx) != CXt_EVAL) {
1418 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1419 PerlIO_write(PerlIO_stderr(), message, msglen);
1424 if (gimme == G_SCALAR)
1425 *++newsp = &PL_sv_undef;
1426 PL_stack_sp = newsp;
1430 if (optype == OP_REQUIRE) {
1431 char* msg = SvPVx(ERRSV, n_a);
1432 DIE("%s", *msg ? msg : "Compilation failed in require");
1434 return pop_return();
1438 message = SvPVx(ERRSV, msglen);
1441 /* SFIO can really mess with your errno */
1444 PerlIO_write(PerlIO_stderr(), message, msglen);
1445 (void)PerlIO_flush(PerlIO_stderr());
1458 if (SvTRUE(left) != SvTRUE(right))
1470 RETURNOP(cLOGOP->op_other);
1479 RETURNOP(cLOGOP->op_other);
1485 register I32 cxix = dopoptosub(cxstack_ix);
1486 register PERL_CONTEXT *cx;
1487 register PERL_CONTEXT *ccstack = cxstack;
1488 PERL_SI *top_si = PL_curstackinfo;
1499 /* we may be in a higher stacklevel, so dig down deeper */
1500 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1501 top_si = top_si->si_prev;
1502 ccstack = top_si->si_cxstack;
1503 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1506 if (GIMME != G_ARRAY)
1510 if (PL_DBsub && cxix >= 0 &&
1511 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1515 cxix = dopoptosub_at(ccstack, cxix - 1);
1518 cx = &ccstack[cxix];
1519 if (CxTYPE(cx) == CXt_SUB) {
1520 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1521 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1522 field below is defined for any cx. */
1523 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1524 cx = &ccstack[dbcxix];
1527 if (GIMME != G_ARRAY) {
1528 hv = cx->blk_oldcop->cop_stash;
1530 PUSHs(&PL_sv_undef);
1533 sv_setpv(TARG, HvNAME(hv));
1539 hv = cx->blk_oldcop->cop_stash;
1541 PUSHs(&PL_sv_undef);
1543 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1544 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1545 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
1546 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1549 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
1551 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
1552 PUSHs(sv_2mortal(sv));
1553 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1556 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1557 PUSHs(sv_2mortal(newSViv(0)));
1559 gimme = (I32)cx->blk_gimme;
1560 if (gimme == G_VOID)
1561 PUSHs(&PL_sv_undef);
1563 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1564 if (CxTYPE(cx) == CXt_EVAL) {
1565 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1566 PUSHs(cx->blk_eval.cur_text);
1569 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1570 /* Require, put the name. */
1571 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1575 else if (CxTYPE(cx) == CXt_SUB &&
1576 cx->blk_sub.hasargs &&
1577 PL_curcop->cop_stash == PL_debstash)
1579 AV *ary = cx->blk_sub.argarray;
1580 int off = AvARRAY(ary) - AvALLOC(ary);
1584 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1587 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
1590 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1591 av_extend(PL_dbargs, AvFILLp(ary) + off);
1592 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1593 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1599 sortcv(SV *a, SV *b)
1602 I32 oldsaveix = PL_savestack_ix;
1603 I32 oldscopeix = PL_scopestack_ix;
1605 GvSV(PL_firstgv) = a;
1606 GvSV(PL_secondgv) = b;
1607 PL_stack_sp = PL_stack_base;
1610 if (PL_stack_sp != PL_stack_base + 1)
1611 croak("Sort subroutine didn't return single value");
1612 if (!SvNIOKp(*PL_stack_sp))
1613 croak("Sort subroutine didn't return a numeric value");
1614 result = SvIV(*PL_stack_sp);
1615 while (PL_scopestack_ix > oldscopeix) {
1618 leave_scope(oldsaveix);
1632 sv_reset(tmps, PL_curcop->cop_stash);
1644 PL_curcop = (COP*)PL_op;
1645 TAINT_NOT; /* Each statement is presumed innocent */
1646 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1649 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1653 register PERL_CONTEXT *cx;
1654 I32 gimme = G_ARRAY;
1661 DIE("No DB::DB routine defined");
1663 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
1675 push_return(PL_op->op_next);
1676 PUSHBLOCK(cx, CXt_SUB, SP);
1679 (void)SvREFCNT_inc(cv);
1680 SAVESPTR(PL_curpad);
1681 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1682 RETURNOP(CvSTART(cv));
1696 register PERL_CONTEXT *cx;
1697 I32 gimme = GIMME_V;
1704 if (PL_op->op_flags & OPf_SPECIAL) {
1706 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1707 SAVEGENERICSV(*svp);
1711 #endif /* USE_THREADS */
1712 if (PL_op->op_targ) {
1713 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
1717 svp = &GvSV((GV*)POPs); /* symbol table variable */
1718 SAVEGENERICSV(*svp);
1724 PUSHBLOCK(cx, CXt_LOOP, SP);
1725 PUSHLOOP(cx, svp, MARK);
1726 if (PL_op->op_flags & OPf_STACKED) {
1727 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1728 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1730 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1731 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1732 if (SvNV(sv) < IV_MIN ||
1733 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1734 croak("Range iterator outside integer range");
1735 cx->blk_loop.iterix = SvIV(sv);
1736 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1739 cx->blk_loop.iterlval = newSVsv(sv);
1743 cx->blk_loop.iterary = PL_curstack;
1744 AvFILLp(PL_curstack) = SP - PL_stack_base;
1745 cx->blk_loop.iterix = MARK - PL_stack_base;
1754 register PERL_CONTEXT *cx;
1755 I32 gimme = GIMME_V;
1761 PUSHBLOCK(cx, CXt_LOOP, SP);
1762 PUSHLOOP(cx, 0, SP);
1770 register PERL_CONTEXT *cx;
1771 struct block_loop cxloop;
1779 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1782 if (gimme == G_VOID)
1784 else if (gimme == G_SCALAR) {
1786 *++newsp = sv_mortalcopy(*SP);
1788 *++newsp = &PL_sv_undef;
1792 *++newsp = sv_mortalcopy(*++mark);
1793 TAINT_NOT; /* Each item is independent */
1799 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1800 PL_curpm = newpm; /* ... and pop $1 et al */
1812 register PERL_CONTEXT *cx;
1813 struct block_sub cxsub;
1814 bool popsub2 = FALSE;
1820 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1821 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1822 if (cxstack_ix > PL_sortcxix)
1823 dounwind(PL_sortcxix);
1824 AvARRAY(PL_curstack)[1] = *SP;
1825 PL_stack_sp = PL_stack_base + 1;
1830 cxix = dopoptosub(cxstack_ix);
1832 DIE("Can't return outside a subroutine");
1833 if (cxix < cxstack_ix)
1837 switch (CxTYPE(cx)) {
1839 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1844 if (AvFILLp(PL_comppad_name) >= 0)
1847 if (optype == OP_REQUIRE &&
1848 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1850 /* Unassume the success we assumed earlier. */
1851 char *name = cx->blk_eval.old_name;
1852 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1853 DIE("%s did not return a true value", name);
1857 DIE("panic: return");
1861 if (gimme == G_SCALAR) {
1864 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1866 *++newsp = SvREFCNT_inc(*SP);
1871 *++newsp = sv_mortalcopy(*SP);
1874 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1876 *++newsp = sv_mortalcopy(*SP);
1878 *++newsp = &PL_sv_undef;
1880 else if (gimme == G_ARRAY) {
1881 while (++MARK <= SP) {
1882 *++newsp = (popsub2 && SvTEMP(*MARK))
1883 ? *MARK : sv_mortalcopy(*MARK);
1884 TAINT_NOT; /* Each item is independent */
1887 PL_stack_sp = newsp;
1889 /* Stack values are safe: */
1891 POPSUB2(); /* release CV and @_ ... */
1893 PL_curpm = newpm; /* ... and pop $1 et al */
1896 return pop_return();
1903 register PERL_CONTEXT *cx;
1904 struct block_loop cxloop;
1905 struct block_sub cxsub;
1912 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1914 if (PL_op->op_flags & OPf_SPECIAL) {
1915 cxix = dopoptoloop(cxstack_ix);
1917 DIE("Can't \"last\" outside a block");
1920 cxix = dopoptolabel(cPVOP->op_pv);
1922 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1924 if (cxix < cxstack_ix)
1928 switch (CxTYPE(cx)) {
1930 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1932 nextop = cxloop.last_op->op_next;
1935 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1937 nextop = pop_return();
1941 nextop = pop_return();
1948 if (gimme == G_SCALAR) {
1950 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1951 ? *SP : sv_mortalcopy(*SP);
1953 *++newsp = &PL_sv_undef;
1955 else if (gimme == G_ARRAY) {
1956 while (++MARK <= SP) {
1957 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1958 ? *MARK : sv_mortalcopy(*MARK);
1959 TAINT_NOT; /* Each item is independent */
1965 /* Stack values are safe: */
1968 POPLOOP2(); /* release loop vars ... */
1972 POPSUB2(); /* release CV and @_ ... */
1975 PL_curpm = newpm; /* ... and pop $1 et al */
1984 register PERL_CONTEXT *cx;
1987 if (PL_op->op_flags & OPf_SPECIAL) {
1988 cxix = dopoptoloop(cxstack_ix);
1990 DIE("Can't \"next\" outside a block");
1993 cxix = dopoptolabel(cPVOP->op_pv);
1995 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1997 if (cxix < cxstack_ix)
2001 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2002 LEAVE_SCOPE(oldsave);
2003 return cx->blk_loop.next_op;
2009 register PERL_CONTEXT *cx;
2012 if (PL_op->op_flags & OPf_SPECIAL) {
2013 cxix = dopoptoloop(cxstack_ix);
2015 DIE("Can't \"redo\" outside a block");
2018 cxix = dopoptolabel(cPVOP->op_pv);
2020 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
2022 if (cxix < cxstack_ix)
2026 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2027 LEAVE_SCOPE(oldsave);
2028 return cx->blk_loop.redo_op;
2032 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
2036 static char too_deep[] = "Target of goto is too deeply nested";
2040 if (o->op_type == OP_LEAVE ||
2041 o->op_type == OP_SCOPE ||
2042 o->op_type == OP_LEAVELOOP ||
2043 o->op_type == OP_LEAVETRY)
2045 *ops++ = cUNOPo->op_first;
2050 if (o->op_flags & OPf_KIDS) {
2052 /* First try all the kids at this level, since that's likeliest. */
2053 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2054 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2055 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2058 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2059 if (kid == PL_lastgotoprobe)
2061 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2063 (ops[-1]->op_type != OP_NEXTSTATE &&
2064 ops[-1]->op_type != OP_DBSTATE)))
2066 if (o = dofindlabel(kid, label, ops, oplimit))
2076 return pp_goto(ARGS);
2085 register PERL_CONTEXT *cx;
2086 #define GOTO_DEPTH 64
2087 OP *enterops[GOTO_DEPTH];
2089 int do_dump = (PL_op->op_type == OP_DUMP);
2090 static char must_have_label[] = "goto must have label";
2093 if (PL_op->op_flags & OPf_STACKED) {
2097 /* This egregious kludge implements goto &subroutine */
2098 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2100 register PERL_CONTEXT *cx;
2101 CV* cv = (CV*)SvRV(sv);
2105 int arg_was_real = 0;
2108 if (!CvROOT(cv) && !CvXSUB(cv)) {
2113 /* autoloaded stub? */
2114 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2116 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2117 GvNAMELEN(gv), FALSE);
2118 if (autogv && (cv = GvCV(autogv)))
2120 tmpstr = sv_newmortal();
2121 gv_efullname3(tmpstr, gv, Nullch);
2122 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2124 DIE("Goto undefined subroutine");
2127 /* First do some returnish stuff. */
2128 cxix = dopoptosub(cxstack_ix);
2130 DIE("Can't goto subroutine outside a subroutine");
2131 if (cxix < cxstack_ix)
2134 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
2135 DIE("Can't goto subroutine from an eval-string");
2137 if (CxTYPE(cx) == CXt_SUB &&
2138 cx->blk_sub.hasargs) { /* put @_ back onto stack */
2139 AV* av = cx->blk_sub.argarray;
2141 items = AvFILLp(av) + 1;
2143 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2144 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2145 PL_stack_sp += items;
2147 SvREFCNT_dec(GvAV(PL_defgv));
2148 GvAV(PL_defgv) = cx->blk_sub.savearray;
2149 #endif /* USE_THREADS */
2152 AvREAL_off(av); /* so av_clear() won't clobber elts */
2156 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2160 av = (AV*)PL_curpad[0];
2162 av = GvAV(PL_defgv);
2164 items = AvFILLp(av) + 1;
2166 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2167 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2168 PL_stack_sp += items;
2170 if (CxTYPE(cx) == CXt_SUB &&
2171 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2172 SvREFCNT_dec(cx->blk_sub.cv);
2173 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2174 LEAVE_SCOPE(oldsave);
2176 /* Now do some callish stuff. */
2179 #ifdef PERL_XSUB_OLDSTYLE
2180 if (CvOLDSTYLE(cv)) {
2181 I32 (*fp3)_((int,int,int));
2186 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2187 items = (*fp3)(CvXSUBANY(cv).any_i32,
2188 mark - PL_stack_base + 1,
2190 SP = PL_stack_base + items;
2193 #endif /* PERL_XSUB_OLDSTYLE */
2198 PL_stack_sp--; /* There is no cv arg. */
2199 /* Push a mark for the start of arglist */
2201 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
2202 /* Pop the current context like a decent sub should */
2203 POPBLOCK(cx, PL_curpm);
2204 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2207 return pop_return();
2210 AV* padlist = CvPADLIST(cv);
2211 SV** svp = AvARRAY(padlist);
2212 if (CxTYPE(cx) == CXt_EVAL) {
2213 PL_in_eval = cx->blk_eval.old_in_eval;
2214 PL_eval_root = cx->blk_eval.old_eval_root;
2215 cx->cx_type = CXt_SUB;
2216 cx->blk_sub.hasargs = 0;
2218 cx->blk_sub.cv = cv;
2219 cx->blk_sub.olddepth = CvDEPTH(cv);
2221 if (CvDEPTH(cv) < 2)
2222 (void)SvREFCNT_inc(cv);
2223 else { /* save temporaries on recursion? */
2224 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2225 sub_crush_depth(cv);
2226 if (CvDEPTH(cv) > AvFILLp(padlist)) {
2227 AV *newpad = newAV();
2228 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2229 I32 ix = AvFILLp((AV*)svp[1]);
2230 svp = AvARRAY(svp[0]);
2231 for ( ;ix > 0; ix--) {
2232 if (svp[ix] != &PL_sv_undef) {
2233 char *name = SvPVX(svp[ix]);
2234 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2237 /* outer lexical or anon code */
2238 av_store(newpad, ix,
2239 SvREFCNT_inc(oldpad[ix]) );
2241 else { /* our own lexical */
2243 av_store(newpad, ix, sv = (SV*)newAV());
2244 else if (*name == '%')
2245 av_store(newpad, ix, sv = (SV*)newHV());
2247 av_store(newpad, ix, sv = NEWSV(0,0));
2252 av_store(newpad, ix, sv = NEWSV(0,0));
2256 if (cx->blk_sub.hasargs) {
2259 av_store(newpad, 0, (SV*)av);
2260 AvFLAGS(av) = AVf_REIFY;
2262 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2263 AvFILLp(padlist) = CvDEPTH(cv);
2264 svp = AvARRAY(padlist);
2268 if (!cx->blk_sub.hasargs) {
2269 AV* av = (AV*)PL_curpad[0];
2271 items = AvFILLp(av) + 1;
2273 /* Mark is at the end of the stack. */
2275 Copy(AvARRAY(av), SP + 1, items, SV*);
2280 #endif /* USE_THREADS */
2281 SAVESPTR(PL_curpad);
2282 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2284 if (cx->blk_sub.hasargs)
2285 #endif /* USE_THREADS */
2287 AV* av = (AV*)PL_curpad[0];
2291 cx->blk_sub.savearray = GvAV(PL_defgv);
2292 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2293 #endif /* USE_THREADS */
2294 cx->blk_sub.argarray = av;
2297 if (items >= AvMAX(av) + 1) {
2299 if (AvARRAY(av) != ary) {
2300 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2301 SvPVX(av) = (char*)ary;
2303 if (items >= AvMAX(av) + 1) {
2304 AvMAX(av) = items - 1;
2305 Renew(ary,items+1,SV*);
2307 SvPVX(av) = (char*)ary;
2310 Copy(mark,AvARRAY(av),items,SV*);
2311 AvFILLp(av) = items - 1;
2312 /* preserve @_ nature */
2323 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2325 * We do not care about using sv to call CV;
2326 * it's for informational purposes only.
2328 SV *sv = GvSV(PL_DBsub);
2331 if (PERLDB_SUB_NN) {
2332 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2335 gv_efullname3(sv, CvGV(cv), Nullch);
2338 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
2339 PUSHMARK( PL_stack_sp );
2340 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2344 RETURNOP(CvSTART(cv));
2348 label = SvPV(sv,n_a);
2349 if (!(do_dump || *label))
2350 DIE(must_have_label);
2353 else if (PL_op->op_flags & OPf_SPECIAL) {
2355 DIE(must_have_label);
2358 label = cPVOP->op_pv;
2360 if (label && *label) {
2365 PL_lastgotoprobe = 0;
2367 for (ix = cxstack_ix; ix >= 0; ix--) {
2369 switch (CxTYPE(cx)) {
2371 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
2374 gotoprobe = cx->blk_oldcop->op_sibling;
2380 gotoprobe = cx->blk_oldcop->op_sibling;
2382 gotoprobe = PL_main_root;
2385 if (CvDEPTH(cx->blk_sub.cv)) {
2386 gotoprobe = CvROOT(cx->blk_sub.cv);
2391 DIE("Can't \"goto\" outside a block");
2395 gotoprobe = PL_main_root;
2398 retop = dofindlabel(gotoprobe, label,
2399 enterops, enterops + GOTO_DEPTH);
2402 PL_lastgotoprobe = gotoprobe;
2405 DIE("Can't find label %s", label);
2407 /* pop unwanted frames */
2409 if (ix < cxstack_ix) {
2416 oldsave = PL_scopestack[PL_scopestack_ix];
2417 LEAVE_SCOPE(oldsave);
2420 /* push wanted frames */
2422 if (*enterops && enterops[1]) {
2424 for (ix = 1; enterops[ix]; ix++) {
2425 PL_op = enterops[ix];
2426 /* Eventually we may want to stack the needed arguments
2427 * for each op. For now, we punt on the hard ones. */
2428 if (PL_op->op_type == OP_ENTERITER)
2429 DIE("Can't \"goto\" into the middle of a foreach loop",
2431 (CALLOP->op_ppaddr)(ARGS);
2439 if (!retop) retop = PL_main_start;
2441 PL_restartop = retop;
2442 PL_do_undump = TRUE;
2446 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2447 PL_do_undump = FALSE;
2463 if (anum == 1 && VMSISH_EXIT)
2468 PUSHs(&PL_sv_undef);
2476 double value = SvNVx(GvSV(cCOP->cop_gv));
2477 register I32 match = I_32(value);
2480 if (((double)match) > value)
2481 --match; /* was fractional--truncate other way */
2483 match -= cCOP->uop.scop.scop_offset;
2486 else if (match > cCOP->uop.scop.scop_max)
2487 match = cCOP->uop.scop.scop_max;
2488 PL_op = cCOP->uop.scop.scop_next[match];
2498 PL_op = PL_op->op_next; /* can't assume anything */
2501 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2502 match -= cCOP->uop.scop.scop_offset;
2505 else if (match > cCOP->uop.scop.scop_max)
2506 match = cCOP->uop.scop.scop_max;
2507 PL_op = cCOP->uop.scop.scop_next[match];
2516 save_lines(AV *array, SV *sv)
2518 register char *s = SvPVX(sv);
2519 register char *send = SvPVX(sv) + SvCUR(sv);
2521 register I32 line = 1;
2523 while (s && s < send) {
2524 SV *tmpstr = NEWSV(85,0);
2526 sv_upgrade(tmpstr, SVt_PVMG);
2527 t = strchr(s, '\n');
2533 sv_setpvn(tmpstr, s, t - s);
2534 av_store(array, line++, tmpstr);
2540 docatch_body(va_list args)
2554 assert(CATCH_GET == TRUE);
2558 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body));
2564 PL_op = PL_restartop;
2579 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2580 /* sv Text to convert to OP tree. */
2581 /* startop op_free() this to undo. */
2582 /* code Short string id of the caller. */
2584 dSP; /* Make POPBLOCK work. */
2587 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2590 OP *oop = PL_op, *rop;
2591 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2597 /* switch to eval mode */
2599 if (PL_curcop == &PL_compiling) {
2600 SAVESPTR(PL_compiling.cop_stash);
2601 PL_compiling.cop_stash = PL_curstash;
2603 SAVESPTR(PL_compiling.cop_filegv);
2604 SAVEI16(PL_compiling.cop_line);
2605 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2606 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2607 PL_compiling.cop_line = 1;
2608 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2609 deleting the eval's FILEGV from the stash before gv_check() runs
2610 (i.e. before run-time proper). To work around the coredump that
2611 ensues, we always turn GvMULTI_on for any globals that were
2612 introduced within evals. See force_ident(). GSAR 96-10-12 */
2613 safestr = savepv(tmpbuf);
2614 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2616 #ifdef OP_IN_REGISTER
2624 PL_op->op_type = OP_ENTEREVAL;
2625 PL_op->op_flags = 0; /* Avoid uninit warning. */
2626 PUSHBLOCK(cx, CXt_EVAL, SP);
2627 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
2628 rop = doeval(G_SCALAR, startop);
2629 POPBLOCK(cx,PL_curpm);
2632 (*startop)->op_type = OP_NULL;
2633 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2635 *avp = (AV*)SvREFCNT_inc(PL_comppad);
2637 if (PL_curcop == &PL_compiling)
2638 PL_compiling.op_private = PL_hints;
2639 #ifdef OP_IN_REGISTER
2645 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2647 doeval(int gimme, OP** startop)
2656 PL_in_eval = EVAL_INEVAL;
2660 /* set up a scratch pad */
2663 SAVESPTR(PL_curpad);
2664 SAVESPTR(PL_comppad);
2665 SAVESPTR(PL_comppad_name);
2666 SAVEI32(PL_comppad_name_fill);
2667 SAVEI32(PL_min_intro_pending);
2668 SAVEI32(PL_max_intro_pending);
2671 for (i = cxstack_ix - 1; i >= 0; i--) {
2672 PERL_CONTEXT *cx = &cxstack[i];
2673 if (CxTYPE(cx) == CXt_EVAL)
2675 else if (CxTYPE(cx) == CXt_SUB) {
2676 caller = cx->blk_sub.cv;
2681 SAVESPTR(PL_compcv);
2682 PL_compcv = (CV*)NEWSV(1104,0);
2683 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2684 CvEVAL_on(PL_compcv);
2686 CvOWNER(PL_compcv) = 0;
2687 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2688 MUTEX_INIT(CvMUTEXP(PL_compcv));
2689 #endif /* USE_THREADS */
2691 PL_comppad = newAV();
2692 av_push(PL_comppad, Nullsv);
2693 PL_curpad = AvARRAY(PL_comppad);
2694 PL_comppad_name = newAV();
2695 PL_comppad_name_fill = 0;
2696 PL_min_intro_pending = 0;
2699 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2700 PL_curpad[0] = (SV*)newAV();
2701 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
2702 #endif /* USE_THREADS */
2704 comppadlist = newAV();
2705 AvREAL_off(comppadlist);
2706 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2707 av_store(comppadlist, 1, (SV*)PL_comppad);
2708 CvPADLIST(PL_compcv) = comppadlist;
2710 if (!saveop || saveop->op_type != OP_REQUIRE)
2711 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2713 SAVEFREESV(PL_compcv);
2715 /* make sure we compile in the right package */
2717 newstash = PL_curcop->cop_stash;
2718 if (PL_curstash != newstash) {
2719 SAVESPTR(PL_curstash);
2720 PL_curstash = newstash;
2722 SAVESPTR(PL_beginav);
2723 PL_beginav = newAV();
2724 SAVEFREESV(PL_beginav);
2726 /* try to compile it */
2728 PL_eval_root = Nullop;
2730 PL_curcop = &PL_compiling;
2731 PL_curcop->cop_arybase = 0;
2732 SvREFCNT_dec(PL_rs);
2733 PL_rs = newSVpvn("\n", 1);
2734 if (saveop && saveop->op_flags & OPf_SPECIAL)
2735 PL_in_eval |= EVAL_KEEPERR;
2738 if (yyparse() || PL_error_count || !PL_eval_root) {
2742 I32 optype = 0; /* Might be reset by POPEVAL. */
2747 op_free(PL_eval_root);
2748 PL_eval_root = Nullop;
2750 SP = PL_stack_base + POPMARK; /* pop original mark */
2752 POPBLOCK(cx,PL_curpm);
2758 if (optype == OP_REQUIRE) {
2759 char* msg = SvPVx(ERRSV, n_a);
2760 DIE("%s", *msg ? msg : "Compilation failed in require");
2761 } else if (startop) {
2762 char* msg = SvPVx(ERRSV, n_a);
2764 POPBLOCK(cx,PL_curpm);
2766 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2768 SvREFCNT_dec(PL_rs);
2769 PL_rs = SvREFCNT_inc(PL_nrs);
2771 MUTEX_LOCK(&PL_eval_mutex);
2773 COND_SIGNAL(&PL_eval_cond);
2774 MUTEX_UNLOCK(&PL_eval_mutex);
2775 #endif /* USE_THREADS */
2778 SvREFCNT_dec(PL_rs);
2779 PL_rs = SvREFCNT_inc(PL_nrs);
2780 PL_compiling.cop_line = 0;
2782 *startop = PL_eval_root;
2783 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2784 CvOUTSIDE(PL_compcv) = Nullcv;
2786 SAVEFREEOP(PL_eval_root);
2788 scalarvoid(PL_eval_root);
2789 else if (gimme & G_ARRAY)
2792 scalar(PL_eval_root);
2794 DEBUG_x(dump_eval());
2796 /* Register with debugger: */
2797 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2798 CV *cv = perl_get_cv("DB::postponed", FALSE);
2802 XPUSHs((SV*)PL_compiling.cop_filegv);
2804 perl_call_sv((SV*)cv, G_DISCARD);
2808 /* compiled okay, so do it */
2810 CvDEPTH(PL_compcv) = 1;
2811 SP = PL_stack_base + POPMARK; /* pop original mark */
2812 PL_op = saveop; /* The caller may need it. */
2814 MUTEX_LOCK(&PL_eval_mutex);
2816 COND_SIGNAL(&PL_eval_cond);
2817 MUTEX_UNLOCK(&PL_eval_mutex);
2818 #endif /* USE_THREADS */
2820 RETURNOP(PL_eval_start);
2824 doopen_pmc(const char *name, const char *mode)
2826 STRLEN namelen = strlen(name);
2829 if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
2830 SV *pmcsv = newSVpvf("%s%c", name, 'c');
2831 char *pmc = SvPV_nolen(pmcsv);
2834 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2835 fp = PerlIO_open(name, mode);
2838 if (PerlLIO_stat(name, &pmstat) < 0 ||
2839 pmstat.st_mtime < pmcstat.st_mtime)
2841 fp = PerlIO_open(pmc, mode);
2844 fp = PerlIO_open(name, mode);
2847 SvREFCNT_dec(pmcsv);
2850 fp = PerlIO_open(name, mode);
2858 register PERL_CONTEXT *cx;
2863 SV *namesv = Nullsv;
2865 I32 gimme = G_SCALAR;
2866 PerlIO *tryrsfp = 0;
2870 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2871 SET_NUMERIC_STANDARD();
2872 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
2873 DIE("Perl %s required--this is only version %s, stopped",
2874 SvPV(sv,n_a),PL_patchlevel);
2877 name = SvPV(sv, len);
2878 if (!(name && len > 0 && *name))
2879 DIE("Null filename used");
2880 TAINT_PROPER("require");
2881 if (PL_op->op_type == OP_REQUIRE &&
2882 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2883 *svp != &PL_sv_undef)
2886 /* prepare to compile file */
2891 (name[1] == '.' && name[2] == '/')))
2893 || (name[0] && name[1] == ':')
2896 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2899 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2900 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2905 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2908 AV *ar = GvAVn(PL_incgv);
2912 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2915 namesv = NEWSV(806, 0);
2916 for (i = 0; i <= AvFILL(ar); i++) {
2917 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2920 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2922 sv_setpv(namesv, unixdir);
2923 sv_catpv(namesv, unixname);
2925 sv_setpvf(namesv, "%s/%s", dir, name);
2927 TAINT_PROPER("require");
2928 tryname = SvPVX(namesv);
2929 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2931 if (tryname[0] == '.' && tryname[1] == '/')
2938 SAVESPTR(PL_compiling.cop_filegv);
2939 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2940 SvREFCNT_dec(namesv);
2942 if (PL_op->op_type == OP_REQUIRE) {
2943 char *msgstr = name;
2944 if (namesv) { /* did we lookup @INC? */
2945 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2946 SV *dirmsgsv = NEWSV(0, 0);
2947 AV *ar = GvAVn(PL_incgv);
2949 sv_catpvn(msg, " in @INC", 8);
2950 if (instr(SvPVX(msg), ".h "))
2951 sv_catpv(msg, " (change .h to .ph maybe?)");
2952 if (instr(SvPVX(msg), ".ph "))
2953 sv_catpv(msg, " (did you run h2ph?)");
2954 sv_catpv(msg, " (@INC contains:");
2955 for (i = 0; i <= AvFILL(ar); i++) {
2956 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
2957 sv_setpvf(dirmsgsv, " %s", dir);
2958 sv_catsv(msg, dirmsgsv);
2960 sv_catpvn(msg, ")", 1);
2961 SvREFCNT_dec(dirmsgsv);
2962 msgstr = SvPV_nolen(msg);
2964 DIE("Can't locate %s", msgstr);
2970 SETERRNO(0, SS$_NORMAL);
2972 /* Assume success here to prevent recursive requirement. */
2973 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2974 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
2978 lex_start(sv_2mortal(newSVpvn("",0)));
2979 SAVEGENERICSV(PL_rsfp_filters);
2980 PL_rsfp_filters = Nullav;
2983 name = savepv(name);
2987 SAVEPPTR(PL_compiling.cop_warnings);
2988 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2991 /* switch to eval mode */
2993 push_return(PL_op->op_next);
2994 PUSHBLOCK(cx, CXt_EVAL, SP);
2995 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
2997 SAVEI16(PL_compiling.cop_line);
2998 PL_compiling.cop_line = 0;
3002 MUTEX_LOCK(&PL_eval_mutex);
3003 if (PL_eval_owner && PL_eval_owner != thr)
3004 while (PL_eval_owner)
3005 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3006 PL_eval_owner = thr;
3007 MUTEX_UNLOCK(&PL_eval_mutex);
3008 #endif /* USE_THREADS */
3009 return DOCATCH(doeval(G_SCALAR, NULL));
3014 return pp_require(ARGS);
3020 register PERL_CONTEXT *cx;
3022 I32 gimme = GIMME_V, was = PL_sub_generation;
3023 char tmpbuf[TYPE_DIGITS(long) + 12];
3028 if (!SvPV(sv,len) || !len)
3030 TAINT_PROPER("eval");
3036 /* switch to eval mode */
3038 SAVESPTR(PL_compiling.cop_filegv);
3039 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3040 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3041 PL_compiling.cop_line = 1;
3042 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3043 deleting the eval's FILEGV from the stash before gv_check() runs
3044 (i.e. before run-time proper). To work around the coredump that
3045 ensues, we always turn GvMULTI_on for any globals that were
3046 introduced within evals. See force_ident(). GSAR 96-10-12 */
3047 safestr = savepv(tmpbuf);
3048 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3050 PL_hints = PL_op->op_targ;
3051 SAVEPPTR(PL_compiling.cop_warnings);
3052 if (PL_compiling.cop_warnings != WARN_ALL
3053 && PL_compiling.cop_warnings != WARN_NONE){
3054 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3055 SAVEFREESV(PL_compiling.cop_warnings) ;
3058 push_return(PL_op->op_next);
3059 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3060 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
3062 /* prepare to compile string */
3064 if (PERLDB_LINE && PL_curstash != PL_debstash)
3065 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
3068 MUTEX_LOCK(&PL_eval_mutex);
3069 if (PL_eval_owner && PL_eval_owner != thr)
3070 while (PL_eval_owner)
3071 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3072 PL_eval_owner = thr;
3073 MUTEX_UNLOCK(&PL_eval_mutex);
3074 #endif /* USE_THREADS */
3075 ret = doeval(gimme, NULL);
3076 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3077 && ret != PL_op->op_next) { /* Successive compilation. */
3078 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3080 return DOCATCH(ret);
3090 register PERL_CONTEXT *cx;
3092 U8 save_flags = PL_op -> op_flags;
3097 retop = pop_return();
3100 if (gimme == G_VOID)
3102 else if (gimme == G_SCALAR) {
3105 if (SvFLAGS(TOPs) & SVs_TEMP)
3108 *MARK = sv_mortalcopy(TOPs);
3112 *MARK = &PL_sv_undef;
3116 /* in case LEAVE wipes old return values */
3117 for (mark = newsp + 1; mark <= SP; mark++) {
3118 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3119 *mark = sv_mortalcopy(*mark);
3120 TAINT_NOT; /* Each item is independent */
3124 PL_curpm = newpm; /* Don't pop $1 et al till now */
3126 if (AvFILLp(PL_comppad_name) >= 0)
3130 assert(CvDEPTH(PL_compcv) == 1);
3132 CvDEPTH(PL_compcv) = 0;
3135 if (optype == OP_REQUIRE &&
3136 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3138 /* Unassume the success we assumed earlier. */
3139 char *name = cx->blk_eval.old_name;
3140 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
3141 retop = die("%s did not return a true value", name);
3142 /* die_where() did LEAVE, or we won't be here */
3146 if (!(save_flags & OPf_SPECIAL))
3156 register PERL_CONTEXT *cx;
3157 I32 gimme = GIMME_V;
3162 push_return(cLOGOP->op_other->op_next);
3163 PUSHBLOCK(cx, CXt_EVAL, SP);
3165 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3167 PL_in_eval = EVAL_INEVAL;
3170 return DOCATCH(PL_op->op_next);
3180 register PERL_CONTEXT *cx;
3188 if (gimme == G_VOID)
3190 else if (gimme == G_SCALAR) {
3193 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3196 *MARK = sv_mortalcopy(TOPs);
3200 *MARK = &PL_sv_undef;
3205 /* in case LEAVE wipes old return values */
3206 for (mark = newsp + 1; mark <= SP; mark++) {
3207 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3208 *mark = sv_mortalcopy(*mark);
3209 TAINT_NOT; /* Each item is independent */
3213 PL_curpm = newpm; /* Don't pop $1 et al till now */
3224 register char *s = SvPV_force(sv, len);
3225 register char *send = s + len;
3226 register char *base;
3227 register I32 skipspaces = 0;
3230 bool postspace = FALSE;
3238 croak("Null picture in formline");
3240 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
3245 *fpc++ = FF_LINEMARK;
3246 noblank = repeat = FALSE;
3264 case ' ': case '\t':
3275 *fpc++ = FF_LITERAL;
3283 *fpc++ = skipspaces;
3287 *fpc++ = FF_NEWLINE;
3291 arg = fpc - linepc + 1;
3298 *fpc++ = FF_LINEMARK;
3299 noblank = repeat = FALSE;
3308 ischop = s[-1] == '^';
3314 arg = (s - base) - 1;
3316 *fpc++ = FF_LITERAL;
3325 *fpc++ = FF_LINEGLOB;
3327 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3328 arg = ischop ? 512 : 0;
3338 arg |= 256 + (s - f);
3340 *fpc++ = s - base; /* fieldsize for FETCH */
3341 *fpc++ = FF_DECIMAL;
3346 bool ismore = FALSE;
3349 while (*++s == '>') ;
3350 prespace = FF_SPACE;
3352 else if (*s == '|') {
3353 while (*++s == '|') ;
3354 prespace = FF_HALFSPACE;
3359 while (*++s == '<') ;
3362 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3366 *fpc++ = s - base; /* fieldsize for FETCH */
3368 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3386 { /* need to jump to the next word */
3388 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3389 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3390 s = SvPVX(sv) + SvCUR(sv) + z;
3392 Copy(fops, s, arg, U16);
3394 sv_magic(sv, Nullsv, 'f', Nullch, 0);
3399 * The rest of this file was derived from source code contributed
3402 * NOTE: this code was derived from Tom Horsley's qsort replacement
3403 * and should not be confused with the original code.
3406 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3408 Permission granted to distribute under the same terms as perl which are
3411 This program is free software; you can redistribute it and/or modify
3412 it under the terms of either:
3414 a) the GNU General Public License as published by the Free
3415 Software Foundation; either version 1, or (at your option) any
3418 b) the "Artistic License" which comes with this Kit.
3420 Details on the perl license can be found in the perl source code which
3421 may be located via the www.perl.com web page.
3423 This is the most wonderfulest possible qsort I can come up with (and
3424 still be mostly portable) My (limited) tests indicate it consistently
3425 does about 20% fewer calls to compare than does the qsort in the Visual
3426 C++ library, other vendors may vary.
3428 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3429 others I invented myself (or more likely re-invented since they seemed
3430 pretty obvious once I watched the algorithm operate for a while).
3432 Most of this code was written while watching the Marlins sweep the Giants
3433 in the 1997 National League Playoffs - no Braves fans allowed to use this
3434 code (just kidding :-).
3436 I realize that if I wanted to be true to the perl tradition, the only
3437 comment in this file would be something like:
3439 ...they shuffled back towards the rear of the line. 'No, not at the
3440 rear!' the slave-driver shouted. 'Three files up. And stay there...
3442 However, I really needed to violate that tradition just so I could keep
3443 track of what happens myself, not to mention some poor fool trying to
3444 understand this years from now :-).
3447 /* ********************************************************** Configuration */
3449 #ifndef QSORT_ORDER_GUESS
3450 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3453 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3454 future processing - a good max upper bound is log base 2 of memory size
3455 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3456 safely be smaller than that since the program is taking up some space and
3457 most operating systems only let you grab some subset of contiguous
3458 memory (not to mention that you are normally sorting data larger than
3459 1 byte element size :-).
3461 #ifndef QSORT_MAX_STACK
3462 #define QSORT_MAX_STACK 32
3465 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3466 Anything bigger and we use qsort. If you make this too small, the qsort
3467 will probably break (or become less efficient), because it doesn't expect
3468 the middle element of a partition to be the same as the right or left -
3469 you have been warned).
3471 #ifndef QSORT_BREAK_EVEN
3472 #define QSORT_BREAK_EVEN 6
3475 /* ************************************************************* Data Types */
3477 /* hold left and right index values of a partition waiting to be sorted (the
3478 partition includes both left and right - right is NOT one past the end or
3479 anything like that).
3481 struct partition_stack_entry {
3484 #ifdef QSORT_ORDER_GUESS
3485 int qsort_break_even;
3489 /* ******************************************************* Shorthand Macros */
3491 /* Note that these macros will be used from inside the qsort function where
3492 we happen to know that the variable 'elt_size' contains the size of an
3493 array element and the variable 'temp' points to enough space to hold a
3494 temp element and the variable 'array' points to the array being sorted
3495 and 'compare' is the pointer to the compare routine.
3497 Also note that there are very many highly architecture specific ways
3498 these might be sped up, but this is simply the most generally portable
3499 code I could think of.
3502 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3505 #define qsort_cmp(elt1, elt2) \
3506 ((this->*compare)(array[elt1], array[elt2]))
3508 #define qsort_cmp(elt1, elt2) \
3509 ((*compare)(array[elt1], array[elt2]))
3512 #ifdef QSORT_ORDER_GUESS
3513 #define QSORT_NOTICE_SWAP swapped++;
3515 #define QSORT_NOTICE_SWAP
3518 /* swaps contents of array elements elt1, elt2.
3520 #define qsort_swap(elt1, elt2) \
3523 temp = array[elt1]; \
3524 array[elt1] = array[elt2]; \
3525 array[elt2] = temp; \
3528 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3529 elt3 and elt3 gets elt1.
3531 #define qsort_rotate(elt1, elt2, elt3) \
3534 temp = array[elt1]; \
3535 array[elt1] = array[elt2]; \
3536 array[elt2] = array[elt3]; \
3537 array[elt3] = temp; \
3540 /* ************************************************************ Debug stuff */
3547 return; /* good place to set a breakpoint */
3550 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3553 doqsort_all_asserts(
3557 int (*compare)(const void * elt1, const void * elt2),
3558 int pc_left, int pc_right, int u_left, int u_right)
3562 qsort_assert(pc_left <= pc_right);
3563 qsort_assert(u_right < pc_left);
3564 qsort_assert(pc_right < u_left);
3565 for (i = u_right + 1; i < pc_left; ++i) {
3566 qsort_assert(qsort_cmp(i, pc_left) < 0);
3568 for (i = pc_left; i < pc_right; ++i) {
3569 qsort_assert(qsort_cmp(i, pc_right) == 0);
3571 for (i = pc_right + 1; i < u_left; ++i) {
3572 qsort_assert(qsort_cmp(pc_right, i) < 0);
3576 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3577 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3578 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3582 #define qsort_assert(t) ((void)0)
3584 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3588 /* ****************************************************************** qsort */
3592 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3594 qsortsv(SV ** array, size_t num_elts, I32 (*compare)(SV *a, SV *b))
3599 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3600 int next_stack_entry = 0;
3604 #ifdef QSORT_ORDER_GUESS
3605 int qsort_break_even;
3609 /* Make sure we actually have work to do.
3611 if (num_elts <= 1) {
3615 /* Setup the initial partition definition and fall into the sorting loop
3618 part_right = (int)(num_elts - 1);
3619 #ifdef QSORT_ORDER_GUESS
3620 qsort_break_even = QSORT_BREAK_EVEN;
3622 #define qsort_break_even QSORT_BREAK_EVEN
3625 if ((part_right - part_left) >= qsort_break_even) {
3626 /* OK, this is gonna get hairy, so lets try to document all the
3627 concepts and abbreviations and variables and what they keep
3630 pc: pivot chunk - the set of array elements we accumulate in the
3631 middle of the partition, all equal in value to the original
3632 pivot element selected. The pc is defined by:
3634 pc_left - the leftmost array index of the pc
3635 pc_right - the rightmost array index of the pc
3637 we start with pc_left == pc_right and only one element
3638 in the pivot chunk (but it can grow during the scan).
3640 u: uncompared elements - the set of elements in the partition
3641 we have not yet compared to the pivot value. There are two
3642 uncompared sets during the scan - one to the left of the pc
3643 and one to the right.
3645 u_right - the rightmost index of the left side's uncompared set
3646 u_left - the leftmost index of the right side's uncompared set
3648 The leftmost index of the left sides's uncompared set
3649 doesn't need its own variable because it is always defined
3650 by the leftmost edge of the whole partition (part_left). The
3651 same goes for the rightmost edge of the right partition
3654 We know there are no uncompared elements on the left once we
3655 get u_right < part_left and no uncompared elements on the
3656 right once u_left > part_right. When both these conditions
3657 are met, we have completed the scan of the partition.
3659 Any elements which are between the pivot chunk and the
3660 uncompared elements should be less than the pivot value on
3661 the left side and greater than the pivot value on the right
3662 side (in fact, the goal of the whole algorithm is to arrange
3663 for that to be true and make the groups of less-than and
3664 greater-then elements into new partitions to sort again).
3666 As you marvel at the complexity of the code and wonder why it
3667 has to be so confusing. Consider some of the things this level
3668 of confusion brings:
3670 Once I do a compare, I squeeze every ounce of juice out of it. I
3671 never do compare calls I don't have to do, and I certainly never
3674 I also never swap any elements unless I can prove there is a
3675 good reason. Many sort algorithms will swap a known value with
3676 an uncompared value just to get things in the right place (or
3677 avoid complexity :-), but that uncompared value, once it gets
3678 compared, may then have to be swapped again. A lot of the
3679 complexity of this code is due to the fact that it never swaps
3680 anything except compared values, and it only swaps them when the
3681 compare shows they are out of position.
3683 int pc_left, pc_right;
3684 int u_right, u_left;
3688 pc_left = ((part_left + part_right) / 2);
3690 u_right = pc_left - 1;
3691 u_left = pc_right + 1;
3693 /* Qsort works best when the pivot value is also the median value
3694 in the partition (unfortunately you can't find the median value
3695 without first sorting :-), so to give the algorithm a helping
3696 hand, we pick 3 elements and sort them and use the median value
3697 of that tiny set as the pivot value.
3699 Some versions of qsort like to use the left middle and right as
3700 the 3 elements to sort so they can insure the ends of the
3701 partition will contain values which will stop the scan in the
3702 compare loop, but when you have to call an arbitrarily complex
3703 routine to do a compare, its really better to just keep track of
3704 array index values to know when you hit the edge of the
3705 partition and avoid the extra compare. An even better reason to
3706 avoid using a compare call is the fact that you can drop off the
3707 edge of the array if someone foolishly provides you with an
3708 unstable compare function that doesn't always provide consistent
3711 So, since it is simpler for us to compare the three adjacent
3712 elements in the middle of the partition, those are the ones we
3713 pick here (conveniently pointed at by u_right, pc_left, and
3714 u_left). The values of the left, center, and right elements
3715 are refered to as l c and r in the following comments.
3718 #ifdef QSORT_ORDER_GUESS
3721 s = qsort_cmp(u_right, pc_left);
3724 s = qsort_cmp(pc_left, u_left);
3725 /* if l < c, c < r - already in order - nothing to do */
3727 /* l < c, c == r - already in order, pc grows */
3729 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3731 /* l < c, c > r - need to know more */
3732 s = qsort_cmp(u_right, u_left);
3734 /* l < c, c > r, l < r - swap c & r to get ordered */
3735 qsort_swap(pc_left, u_left);
3736 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3737 } else if (s == 0) {
3738 /* l < c, c > r, l == r - swap c&r, grow pc */
3739 qsort_swap(pc_left, u_left);
3741 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3743 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3744 qsort_rotate(pc_left, u_right, u_left);
3745 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3748 } else if (s == 0) {
3750 s = qsort_cmp(pc_left, u_left);
3752 /* l == c, c < r - already in order, grow pc */
3754 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3755 } else if (s == 0) {
3756 /* l == c, c == r - already in order, grow pc both ways */
3759 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3761 /* l == c, c > r - swap l & r, grow pc */
3762 qsort_swap(u_right, u_left);
3764 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3768 s = qsort_cmp(pc_left, u_left);
3770 /* l > c, c < r - need to know more */
3771 s = qsort_cmp(u_right, u_left);
3773 /* l > c, c < r, l < r - swap l & c to get ordered */
3774 qsort_swap(u_right, pc_left);
3775 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3776 } else if (s == 0) {
3777 /* l > c, c < r, l == r - swap l & c, grow pc */
3778 qsort_swap(u_right, pc_left);
3780 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3782 /* l > c, c < r, l > r - rotate lcr into crl to order */
3783 qsort_rotate(u_right, pc_left, u_left);
3784 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3786 } else if (s == 0) {
3787 /* l > c, c == r - swap ends, grow pc */
3788 qsort_swap(u_right, u_left);
3790 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3792 /* l > c, c > r - swap ends to get in order */
3793 qsort_swap(u_right, u_left);
3794 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3797 /* We now know the 3 middle elements have been compared and
3798 arranged in the desired order, so we can shrink the uncompared
3803 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3805 /* The above massive nested if was the simple part :-). We now have
3806 the middle 3 elements ordered and we need to scan through the
3807 uncompared sets on either side, swapping elements that are on
3808 the wrong side or simply shuffling equal elements around to get
3809 all equal elements into the pivot chunk.
3813 int still_work_on_left;
3814 int still_work_on_right;
3816 /* Scan the uncompared values on the left. If I find a value
3817 equal to the pivot value, move it over so it is adjacent to
3818 the pivot chunk and expand the pivot chunk. If I find a value
3819 less than the pivot value, then just leave it - its already
3820 on the correct side of the partition. If I find a greater
3821 value, then stop the scan.
3823 while (still_work_on_left = (u_right >= part_left)) {
3824 s = qsort_cmp(u_right, pc_left);
3827 } else if (s == 0) {
3829 if (pc_left != u_right) {
3830 qsort_swap(u_right, pc_left);
3836 qsort_assert(u_right < pc_left);
3837 qsort_assert(pc_left <= pc_right);
3838 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3839 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3842 /* Do a mirror image scan of uncompared values on the right
3844 while (still_work_on_right = (u_left <= part_right)) {
3845 s = qsort_cmp(pc_right, u_left);
3848 } else if (s == 0) {
3850 if (pc_right != u_left) {
3851 qsort_swap(pc_right, u_left);
3857 qsort_assert(u_left > pc_right);
3858 qsort_assert(pc_left <= pc_right);
3859 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3860 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3863 if (still_work_on_left) {
3864 /* I know I have a value on the left side which needs to be
3865 on the right side, but I need to know more to decide
3866 exactly the best thing to do with it.
3868 if (still_work_on_right) {
3869 /* I know I have values on both side which are out of
3870 position. This is a big win because I kill two birds
3871 with one swap (so to speak). I can advance the
3872 uncompared pointers on both sides after swapping both
3873 of them into the right place.
3875 qsort_swap(u_right, u_left);
3878 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3880 /* I have an out of position value on the left, but the
3881 right is fully scanned, so I "slide" the pivot chunk
3882 and any less-than values left one to make room for the
3883 greater value over on the right. If the out of position
3884 value is immediately adjacent to the pivot chunk (there
3885 are no less-than values), I can do that with a swap,
3886 otherwise, I have to rotate one of the less than values
3887 into the former position of the out of position value
3888 and the right end of the pivot chunk into the left end
3892 if (pc_left == u_right) {
3893 qsort_swap(u_right, pc_right);
3894 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3896 qsort_rotate(u_right, pc_left, pc_right);
3897 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3902 } else if (still_work_on_right) {
3903 /* Mirror image of complex case above: I have an out of
3904 position value on the right, but the left is fully
3905 scanned, so I need to shuffle things around to make room
3906 for the right value on the left.
3909 if (pc_right == u_left) {
3910 qsort_swap(u_left, pc_left);
3911 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3913 qsort_rotate(pc_right, pc_left, u_left);
3914 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3919 /* No more scanning required on either side of partition,
3920 break out of loop and figure out next set of partitions
3926 /* The elements in the pivot chunk are now in the right place. They
3927 will never move or be compared again. All I have to do is decide
3928 what to do with the stuff to the left and right of the pivot
3931 Notes on the QSORT_ORDER_GUESS ifdef code:
3933 1. If I just built these partitions without swapping any (or
3934 very many) elements, there is a chance that the elements are
3935 already ordered properly (being properly ordered will
3936 certainly result in no swapping, but the converse can't be
3939 2. A (properly written) insertion sort will run faster on
3940 already ordered data than qsort will.
3942 3. Perhaps there is some way to make a good guess about
3943 switching to an insertion sort earlier than partition size 6
3944 (for instance - we could save the partition size on the stack
3945 and increase the size each time we find we didn't swap, thus
3946 switching to insertion sort earlier for partitions with a
3947 history of not swapping).
3949 4. Naturally, if I just switch right away, it will make
3950 artificial benchmarks with pure ascending (or descending)
3951 data look really good, but is that a good reason in general?
3955 #ifdef QSORT_ORDER_GUESS
3957 #if QSORT_ORDER_GUESS == 1
3958 qsort_break_even = (part_right - part_left) + 1;
3960 #if QSORT_ORDER_GUESS == 2
3961 qsort_break_even *= 2;
3963 #if QSORT_ORDER_GUESS == 3
3964 int prev_break = qsort_break_even;
3965 qsort_break_even *= qsort_break_even;
3966 if (qsort_break_even < prev_break) {
3967 qsort_break_even = (part_right - part_left) + 1;
3971 qsort_break_even = QSORT_BREAK_EVEN;
3975 if (part_left < pc_left) {
3976 /* There are elements on the left which need more processing.
3977 Check the right as well before deciding what to do.
3979 if (pc_right < part_right) {
3980 /* We have two partitions to be sorted. Stack the biggest one
3981 and process the smallest one on the next iteration. This
3982 minimizes the stack height by insuring that any additional
3983 stack entries must come from the smallest partition which
3984 (because it is smallest) will have the fewest
3985 opportunities to generate additional stack entries.
3987 if ((part_right - pc_right) > (pc_left - part_left)) {
3988 /* stack the right partition, process the left */
3989 partition_stack[next_stack_entry].left = pc_right + 1;
3990 partition_stack[next_stack_entry].right = part_right;
3991 #ifdef QSORT_ORDER_GUESS
3992 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3994 part_right = pc_left - 1;
3996 /* stack the left partition, process the right */
3997 partition_stack[next_stack_entry].left = part_left;
3998 partition_stack[next_stack_entry].right = pc_left - 1;
3999 #ifdef QSORT_ORDER_GUESS
4000 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4002 part_left = pc_right + 1;
4004 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4007 /* The elements on the left are the only remaining elements
4008 that need sorting, arrange for them to be processed as the
4011 part_right = pc_left - 1;
4013 } else if (pc_right < part_right) {
4014 /* There is only one chunk on the right to be sorted, make it
4015 the new partition and loop back around.
4017 part_left = pc_right + 1;
4019 /* This whole partition wound up in the pivot chunk, so
4020 we need to get a new partition off the stack.
4022 if (next_stack_entry == 0) {
4023 /* the stack is empty - we are done */
4027 part_left = partition_stack[next_stack_entry].left;
4028 part_right = partition_stack[next_stack_entry].right;
4029 #ifdef QSORT_ORDER_GUESS
4030 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4034 /* This partition is too small to fool with qsort complexity, just
4035 do an ordinary insertion sort to minimize overhead.
4038 /* Assume 1st element is in right place already, and start checking
4039 at 2nd element to see where it should be inserted.
4041 for (i = part_left + 1; i <= part_right; ++i) {
4043 /* Scan (backwards - just in case 'i' is already in right place)
4044 through the elements already sorted to see if the ith element
4045 belongs ahead of one of them.
4047 for (j = i - 1; j >= part_left; --j) {
4048 if (qsort_cmp(i, j) >= 0) {
4049 /* i belongs right after j
4056 /* Looks like we really need to move some things
4060 for (k = i - 1; k >= j; --k)
4061 array[k + 1] = array[k];
4066 /* That partition is now sorted, grab the next one, or get out
4067 of the loop if there aren't any more.
4070 if (next_stack_entry == 0) {
4071 /* the stack is empty - we are done */
4075 part_left = partition_stack[next_stack_entry].left;
4076 part_right = partition_stack[next_stack_entry].right;
4077 #ifdef QSORT_ORDER_GUESS
4078 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4083 /* Believe it or not, the array is sorted at this point! */