3 * Copyright (c) 1991-1997, 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->*op
32 static OP *docatch _((OP *o));
33 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
34 static void doparseform _((SV *sv));
35 static I32 dopoptoeval _((I32 startingblock));
36 static I32 dopoptolabel _((char *label));
37 static I32 dopoptoloop _((I32 startingblock));
38 static I32 dopoptosub _((I32 startingblock));
39 static void save_lines _((AV *array, SV *sv));
40 static I32 sortcv _((SV *a, SV *b));
41 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
42 static OP *doeval _((int gimme, OP** startop));
51 cxix = dopoptosub(cxstack_ix);
55 switch (cxstack[cxix].blk_gimme) {
73 register PMOP *pm = (PMOP*)cLOGOP->op_other;
77 MAGIC *mg = Null(MAGIC*);
81 SV *sv = SvRV(tmpstr);
83 mg = mg_find(sv, 'r');
86 regexp *re = (regexp *)mg->mg_obj;
87 ReREFCNT_dec(pm->op_pmregexp);
88 pm->op_pmregexp = ReREFCNT_inc(re);
91 t = SvPV(tmpstr, len);
93 /* Check against the last compiled regexp. */
94 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
95 pm->op_pmregexp->prelen != len ||
96 memNE(pm->op_pmregexp->precomp, t, len))
98 if (pm->op_pmregexp) {
99 ReREFCNT_dec(pm->op_pmregexp);
100 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
103 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
104 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
108 #ifndef INCOMPLETE_TAINTS
111 pm->op_pmdynflags |= PMdf_TAINTED;
113 pm->op_pmdynflags &= ~PMdf_TAINTED;
117 if (!pm->op_pmregexp->prelen && curpm)
119 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
120 pm->op_pmflags |= PMf_WHITE;
122 if (pm->op_pmflags & PMf_KEEP) {
123 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
124 cLOGOP->op_first->op_next = op->op_next;
132 register PMOP *pm = (PMOP*) cLOGOP->op_other;
133 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
134 register SV *dstr = cx->sb_dstr;
135 register char *s = cx->sb_s;
136 register char *m = cx->sb_m;
137 char *orig = cx->sb_orig;
138 register REGEXP *rx = cx->sb_rx;
140 rxres_restore(&cx->sb_rxres, rx);
142 if (cx->sb_iters++) {
143 if (cx->sb_iters > cx->sb_maxiters)
144 DIE("Substitution loop");
146 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
147 cx->sb_rxtainted |= 2;
148 sv_catsv(dstr, POPs);
151 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
152 s == m, Nullsv, NULL,
153 cx->sb_safebase ? 0 : REXEC_COPY_STR))
155 SV *targ = cx->sb_targ;
156 sv_catpvn(dstr, s, cx->sb_strend - s);
158 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
160 (void)SvOOK_off(targ);
161 Safefree(SvPVX(targ));
162 SvPVX(targ) = SvPVX(dstr);
163 SvCUR_set(targ, SvCUR(dstr));
164 SvLEN_set(targ, SvLEN(dstr));
168 TAINT_IF(cx->sb_rxtainted & 1);
169 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
171 (void)SvPOK_only(targ);
172 TAINT_IF(cx->sb_rxtainted);
176 LEAVE_SCOPE(cx->sb_oldsave);
178 RETURNOP(pm->op_next);
181 if (rx->subbase && rx->subbase != orig) {
184 cx->sb_orig = orig = rx->subbase;
186 cx->sb_strend = s + (cx->sb_strend - m);
188 cx->sb_m = m = rx->startp[0];
189 sv_catpvn(dstr, s, m-s);
190 cx->sb_s = rx->endp[0];
191 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
192 rxres_save(&cx->sb_rxres, rx);
193 RETURNOP(pm->op_pmreplstart);
197 rxres_save(void **rsp, REGEXP *rx)
202 if (!p || p[1] < rx->nparens) {
203 i = 6 + rx->nparens * 2;
211 *p++ = (UV)rx->subbase;
212 rx->subbase = Nullch;
216 *p++ = (UV)rx->subbeg;
217 *p++ = (UV)rx->subend;
218 for (i = 0; i <= rx->nparens; ++i) {
219 *p++ = (UV)rx->startp[i];
220 *p++ = (UV)rx->endp[i];
225 rxres_restore(void **rsp, REGEXP *rx)
230 Safefree(rx->subbase);
231 rx->subbase = (char*)(*p);
236 rx->subbeg = (char*)(*p++);
237 rx->subend = (char*)(*p++);
238 for (i = 0; i <= rx->nparens; ++i) {
239 rx->startp[i] = (char*)(*p++);
240 rx->endp[i] = (char*)(*p++);
245 rxres_free(void **rsp)
250 Safefree((char*)(*p));
258 djSP; dMARK; dORIGMARK;
259 register SV *tmpForm = *++MARK;
271 bool chopspace = (strchr(chopset, ' ') != Nullch);
278 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
279 SvREADONLY_off(tmpForm);
280 doparseform(tmpForm);
283 SvPV_force(formtarget, len);
284 t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */
286 f = SvPV(tmpForm, len);
287 /* need to jump to the next word */
288 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
297 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
298 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
299 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
300 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
301 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
303 case FF_CHECKNL: name = "CHECKNL"; break;
304 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
305 case FF_SPACE: name = "SPACE"; break;
306 case FF_HALFSPACE: name = "HALFSPACE"; break;
307 case FF_ITEM: name = "ITEM"; break;
308 case FF_CHOP: name = "CHOP"; break;
309 case FF_LINEGLOB: name = "LINEGLOB"; break;
310 case FF_NEWLINE: name = "NEWLINE"; break;
311 case FF_MORE: name = "MORE"; break;
312 case FF_LINEMARK: name = "LINEMARK"; break;
313 case FF_END: name = "END"; break;
316 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
318 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
347 warn("Not enough format arguments");
352 item = s = SvPV(sv, len);
354 if (itemsize > fieldsize)
355 itemsize = fieldsize;
356 send = chophere = s + itemsize;
368 item = s = SvPV(sv, len);
370 if (itemsize <= fieldsize) {
371 send = chophere = s + itemsize;
382 itemsize = fieldsize;
383 send = chophere = s + itemsize;
384 while (s < send || (s == send && isSPACE(*s))) {
394 if (strchr(chopset, *s))
399 itemsize = chophere - item;
404 arg = fieldsize - itemsize;
413 arg = fieldsize - itemsize;
427 int ch = *t++ = *s++;
431 if ( !((*t++ = *s++) & ~31) )
441 while (*s && isSPACE(*s))
448 item = s = SvPV(sv, len);
461 SvCUR_set(formtarget, t - SvPVX(formtarget));
462 sv_catpvn(formtarget, item, itemsize);
463 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1);
464 t = SvPVX(formtarget) + SvCUR(formtarget);
469 /* If the field is marked with ^ and the value is undefined,
472 if ((arg & 512) && !SvOK(sv)) {
480 /* Formats aren't yet marked for locales, so assume "yes". */
483 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
485 sprintf(t, "%*.0f", (int) fieldsize, value);
492 while (t-- > linemark && *t == ' ') ;
500 if (arg) { /* repeat until fields exhausted? */
502 SvCUR_set(formtarget, t - SvPVX(formtarget));
503 lines += FmLINES(formtarget);
506 if (strnEQ(linemark, linemark - arg, arg))
507 DIE("Runaway format");
509 FmLINES(formtarget) = lines;
511 RETURNOP(cLISTOP->op_first);
522 arg = fieldsize - itemsize;
529 if (strnEQ(s," ",3)) {
530 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
541 SvCUR_set(formtarget, t - SvPVX(formtarget));
542 FmLINES(formtarget) += lines;
554 if (stack_base + *markstack_ptr == SP) {
556 if (GIMME_V == G_SCALAR)
558 RETURNOP(op->op_next->op_next);
560 stack_sp = stack_base + *markstack_ptr + 1;
561 pp_pushmark(ARGS); /* push dst */
562 pp_pushmark(ARGS); /* push src */
563 ENTER; /* enter outer scope */
567 /* SAVE_DEFSV does *not* suffice here */
568 save_sptr(&THREADSV(0));
570 SAVESPTR(GvSV(defgv));
571 #endif /* USE_THREADS */
572 ENTER; /* enter inner scope */
575 src = stack_base[*markstack_ptr];
580 if (op->op_type == OP_MAPSTART)
581 pp_pushmark(ARGS); /* push top */
582 return ((LOGOP*)op->op_next)->op_other;
587 DIE("panic: mapstart"); /* uses grepstart */
593 I32 diff = (SP - stack_base) - *markstack_ptr;
601 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
602 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
603 count = (SP - stack_base) - markstack_ptr[-1] + 2;
608 markstack_ptr[-1] += shift;
609 *markstack_ptr += shift;
613 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
616 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
618 LEAVE; /* exit inner scope */
621 if (markstack_ptr[-1] > *markstack_ptr) {
625 (void)POPMARK; /* pop top */
626 LEAVE; /* exit outer scope */
627 (void)POPMARK; /* pop src */
628 items = --*markstack_ptr - markstack_ptr[-1];
629 (void)POPMARK; /* pop dst */
630 SP = stack_base + POPMARK; /* pop original mark */
631 if (gimme == G_SCALAR) {
635 else if (gimme == G_ARRAY)
642 ENTER; /* enter inner scope */
645 src = stack_base[markstack_ptr[-1]];
649 RETURNOP(cLOGOP->op_other);
655 djSP; dMARK; dORIGMARK;
657 SV **myorigmark = ORIGMARK;
663 OP* nextop = op->op_next;
665 if (gimme != G_ARRAY) {
672 if (op->op_flags & OPf_STACKED) {
673 if (op->op_flags & OPf_SPECIAL) {
674 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
675 kid = kUNOP->op_first; /* pass rv2gv */
676 kid = kUNOP->op_first; /* pass leave */
677 sortcop = kid->op_next;
678 stash = curcop->cop_stash;
681 cv = sv_2cv(*++MARK, &stash, &gv, 0);
682 if (!(cv && CvROOT(cv))) {
684 SV *tmpstr = sv_newmortal();
685 gv_efullname3(tmpstr, gv, Nullch);
686 if (cv && CvXSUB(cv))
687 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
688 DIE("Undefined sort subroutine \"%s\" called",
693 DIE("Xsub called in sort");
694 DIE("Undefined subroutine in sort");
696 DIE("Not a CODE reference in sort");
698 sortcop = CvSTART(cv);
699 SAVESPTR(CvROOT(cv)->op_ppaddr);
700 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
703 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
708 stash = curcop->cop_stash;
712 while (MARK < SP) { /* This may or may not shift down one here. */
714 if (*up = *++MARK) { /* Weed out nulls. */
716 if (!sortcop && !SvPOK(*up))
717 (void)sv_2pv(*up, &na);
721 max = --up - myorigmark;
726 bool oldcatch = CATCH_GET;
732 PUSHSTACKi(PERLSI_SORT);
733 if (sortstash != stash) {
734 firstgv = gv_fetchpv("a", TRUE, SVt_PV);
735 secondgv = gv_fetchpv("b", TRUE, SVt_PV);
739 SAVESPTR(GvSV(firstgv));
740 SAVESPTR(GvSV(secondgv));
742 PUSHBLOCK(cx, CXt_NULL, stack_base);
743 if (!(op->op_flags & OPf_SPECIAL)) {
744 bool hasargs = FALSE;
745 cx->cx_type = CXt_SUB;
746 cx->blk_gimme = G_SCALAR;
749 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
751 sortcxix = cxstack_ix;
752 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
761 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
762 qsortsv(ORIGMARK+1, max,
763 (op->op_private & OPpLOCALE)
764 ? FUNC_NAME_TO_PTR(sv_cmp_locale)
765 : FUNC_NAME_TO_PTR(sv_cmp));
769 stack_sp = ORIGMARK + max;
777 if (GIMME == G_ARRAY)
778 return cCONDOP->op_true;
779 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
786 if (GIMME == G_ARRAY) {
787 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
791 SV *targ = PAD_SV(op->op_targ);
793 if ((op->op_private & OPpFLIP_LINENUM)
794 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
796 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
797 if (op->op_flags & OPf_SPECIAL) {
805 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
818 if (GIMME == G_ARRAY) {
824 if (SvNIOKp(left) || !SvPOKp(left) ||
825 (looks_like_number(left) && *SvPVX(left) != '0') )
827 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
828 croak("Range iterator outside integer range");
832 EXTEND_MORTAL(max - i + 1);
833 EXTEND(SP, max - i + 1);
836 sv = sv_2mortal(newSViv(i++));
841 SV *final = sv_mortalcopy(right);
843 char *tmps = SvPV(final, len);
845 sv = sv_mortalcopy(left);
846 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
848 if (strEQ(SvPVX(sv),tmps))
850 sv = sv_2mortal(newSVsv(sv));
857 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
859 if ((op->op_private & OPpFLIP_LINENUM)
860 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
862 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
863 sv_catpv(targ, "E0");
874 dopoptolabel(char *label)
878 register PERL_CONTEXT *cx;
880 for (i = cxstack_ix; i >= 0; i--) {
882 switch (cx->cx_type) {
885 warn("Exiting substitution via %s", op_name[op->op_type]);
889 warn("Exiting subroutine via %s", op_name[op->op_type]);
893 warn("Exiting eval via %s", op_name[op->op_type]);
897 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
900 if (!cx->blk_loop.label ||
901 strNE(label, cx->blk_loop.label) ) {
902 DEBUG_l(deb("(Skipping label #%ld %s)\n",
903 (long)i, cx->blk_loop.label));
906 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
916 I32 gimme = block_gimme();
917 return (gimme == G_VOID) ? G_SCALAR : gimme;
926 cxix = dopoptosub(cxstack_ix);
930 switch (cxstack[cxix].blk_gimme) {
938 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
945 dopoptosub(I32 startingblock)
949 register PERL_CONTEXT *cx;
950 for (i = startingblock; i >= 0; i--) {
952 switch (cx->cx_type) {
957 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
965 dopoptoeval(I32 startingblock)
969 register PERL_CONTEXT *cx;
970 for (i = startingblock; i >= 0; i--) {
972 switch (cx->cx_type) {
976 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
984 dopoptoloop(I32 startingblock)
988 register PERL_CONTEXT *cx;
989 for (i = startingblock; i >= 0; i--) {
991 switch (cx->cx_type) {
994 warn("Exiting substitution via %s", op_name[op->op_type]);
998 warn("Exiting subroutine via %s", op_name[op->op_type]);
1002 warn("Exiting eval via %s", op_name[op->op_type]);
1006 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
1009 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1020 register PERL_CONTEXT *cx;
1024 while (cxstack_ix > cxix) {
1025 cx = &cxstack[cxstack_ix];
1026 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1027 (long) cxstack_ix, block_type[cx->cx_type]));
1028 /* Note: we don't need to restore the base context info till the end. */
1029 switch (cx->cx_type) {
1032 continue; /* not break */
1050 die_where(char *message)
1055 register PERL_CONTEXT *cx;
1062 STRLEN klen = strlen(message);
1064 svp = hv_fetch(ERRHV, message, klen, TRUE);
1067 static char prefix[] = "\t(in cleanup) ";
1069 sv_upgrade(*svp, SVt_IV);
1070 (void)SvIOK_only(*svp);
1073 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1074 sv_catpvn(err, prefix, sizeof(prefix)-1);
1075 sv_catpvn(err, message, klen);
1081 sv_setpv(ERRSV, message);
1084 message = SvPVx(ERRSV, na);
1086 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
1094 if (cxix < cxstack_ix)
1098 if (cx->cx_type != CXt_EVAL) {
1099 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1104 if (gimme == G_SCALAR)
1105 *++newsp = &sv_undef;
1110 if (optype == OP_REQUIRE) {
1111 char* msg = SvPVx(ERRSV, na);
1112 DIE("%s", *msg ? msg : "Compilation failed in require");
1114 return pop_return();
1117 PerlIO_printf(PerlIO_stderr(), "%s",message);
1118 PerlIO_flush(PerlIO_stderr());
1127 if (SvTRUE(left) != SvTRUE(right))
1139 RETURNOP(cLOGOP->op_other);
1148 RETURNOP(cLOGOP->op_other);
1154 register I32 cxix = dopoptosub(cxstack_ix);
1155 register PERL_CONTEXT *cx;
1167 if (GIMME != G_ARRAY)
1171 if (DBsub && cxix >= 0 &&
1172 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1176 cxix = dopoptosub(cxix - 1);
1178 cx = &cxstack[cxix];
1179 if (cxstack[cxix].cx_type == CXt_SUB) {
1180 dbcxix = dopoptosub(cxix - 1);
1181 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1182 field below is defined for any cx. */
1183 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1184 cx = &cxstack[dbcxix];
1187 if (GIMME != G_ARRAY) {
1188 hv = cx->blk_oldcop->cop_stash;
1193 sv_setpv(TARG, HvNAME(hv));
1199 hv = cx->blk_oldcop->cop_stash;
1203 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1204 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1205 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1208 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1210 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1211 PUSHs(sv_2mortal(sv));
1212 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1215 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1216 PUSHs(sv_2mortal(newSViv(0)));
1218 gimme = (I32)cx->blk_gimme;
1219 if (gimme == G_VOID)
1222 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1223 if (cx->cx_type == CXt_EVAL) {
1224 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1225 PUSHs(cx->blk_eval.cur_text);
1228 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1229 /* Require, put the name. */
1230 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1234 else if (cx->cx_type == CXt_SUB &&
1235 cx->blk_sub.hasargs &&
1236 curcop->cop_stash == debstash)
1238 AV *ary = cx->blk_sub.argarray;
1239 int off = AvARRAY(ary) - AvALLOC(ary);
1243 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1246 AvREAL_off(dbargs); /* XXX Should be REIFY */
1249 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1250 av_extend(dbargs, AvFILLp(ary) + off);
1251 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1252 AvFILLp(dbargs) = AvFILLp(ary) + off;
1258 sortcv(SV *a, SV *b)
1261 I32 oldsaveix = savestack_ix;
1262 I32 oldscopeix = scopestack_ix;
1266 stack_sp = stack_base;
1269 if (stack_sp != stack_base + 1)
1270 croak("Sort subroutine didn't return single value");
1271 if (!SvNIOKp(*stack_sp))
1272 croak("Sort subroutine didn't return a numeric value");
1273 result = SvIV(*stack_sp);
1274 while (scopestack_ix > oldscopeix) {
1277 leave_scope(oldsaveix);
1290 sv_reset(tmps, curcop->cop_stash);
1303 TAINT_NOT; /* Each statement is presumed innocent */
1304 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1307 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1311 register PERL_CONTEXT *cx;
1312 I32 gimme = G_ARRAY;
1319 DIE("No DB::DB routine defined");
1321 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1333 push_return(op->op_next);
1334 PUSHBLOCK(cx, CXt_SUB, SP);
1337 (void)SvREFCNT_inc(cv);
1339 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1340 RETURNOP(CvSTART(cv));
1354 register PERL_CONTEXT *cx;
1355 I32 gimme = GIMME_V;
1362 if (op->op_flags & OPf_SPECIAL)
1363 svp = save_threadsv(op->op_targ); /* per-thread variable */
1365 #endif /* USE_THREADS */
1367 svp = &curpad[op->op_targ]; /* "my" variable */
1372 (void)save_scalar(gv);
1373 svp = &GvSV(gv); /* symbol table variable */
1378 PUSHBLOCK(cx, CXt_LOOP, SP);
1379 PUSHLOOP(cx, svp, MARK);
1380 if (op->op_flags & OPf_STACKED) {
1381 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1382 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1384 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1385 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1386 if (SvNV(sv) < IV_MIN ||
1387 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1388 croak("Range iterator outside integer range");
1389 cx->blk_loop.iterix = SvIV(sv);
1390 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1393 cx->blk_loop.iterlval = newSVsv(sv);
1397 cx->blk_loop.iterary = curstack;
1398 AvFILLp(curstack) = SP - stack_base;
1399 cx->blk_loop.iterix = MARK - stack_base;
1408 register PERL_CONTEXT *cx;
1409 I32 gimme = GIMME_V;
1415 PUSHBLOCK(cx, CXt_LOOP, SP);
1416 PUSHLOOP(cx, 0, SP);
1424 register PERL_CONTEXT *cx;
1425 struct block_loop cxloop;
1433 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1436 if (gimme == G_VOID)
1438 else if (gimme == G_SCALAR) {
1440 *++newsp = sv_mortalcopy(*SP);
1442 *++newsp = &sv_undef;
1446 *++newsp = sv_mortalcopy(*++mark);
1447 TAINT_NOT; /* Each item is independent */
1453 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1454 curpm = newpm; /* ... and pop $1 et al */
1466 register PERL_CONTEXT *cx;
1467 struct block_sub cxsub;
1468 bool popsub2 = FALSE;
1474 if (curstackinfo->si_type == PERLSI_SORT) {
1475 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1476 if (cxstack_ix > sortcxix)
1478 AvARRAY(curstack)[1] = *SP;
1479 stack_sp = stack_base + 1;
1484 cxix = dopoptosub(cxstack_ix);
1486 DIE("Can't return outside a subroutine");
1487 if (cxix < cxstack_ix)
1491 switch (cx->cx_type) {
1493 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1498 if (optype == OP_REQUIRE &&
1499 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1501 /* Unassume the success we assumed earlier. */
1502 char *name = cx->blk_eval.old_name;
1503 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1504 DIE("%s did not return a true value", name);
1508 DIE("panic: return");
1512 if (gimme == G_SCALAR) {
1515 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1517 *++newsp = SvREFCNT_inc(*SP);
1522 *++newsp = sv_mortalcopy(*SP);
1525 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1527 *++newsp = sv_mortalcopy(*SP);
1529 *++newsp = &sv_undef;
1531 else if (gimme == G_ARRAY) {
1532 while (++MARK <= SP) {
1533 *++newsp = (popsub2 && SvTEMP(*MARK))
1534 ? *MARK : sv_mortalcopy(*MARK);
1535 TAINT_NOT; /* Each item is independent */
1540 /* Stack values are safe: */
1542 POPSUB2(); /* release CV and @_ ... */
1544 curpm = newpm; /* ... and pop $1 et al */
1547 return pop_return();
1554 register PERL_CONTEXT *cx;
1555 struct block_loop cxloop;
1556 struct block_sub cxsub;
1563 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1565 if (op->op_flags & OPf_SPECIAL) {
1566 cxix = dopoptoloop(cxstack_ix);
1568 DIE("Can't \"last\" outside a block");
1571 cxix = dopoptolabel(cPVOP->op_pv);
1573 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1575 if (cxix < cxstack_ix)
1579 switch (cx->cx_type) {
1581 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1583 nextop = cxloop.last_op->op_next;
1586 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1588 nextop = pop_return();
1592 nextop = pop_return();
1599 if (gimme == G_SCALAR) {
1601 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1602 ? *SP : sv_mortalcopy(*SP);
1604 *++newsp = &sv_undef;
1606 else if (gimme == G_ARRAY) {
1607 while (++MARK <= SP) {
1608 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1609 ? *MARK : sv_mortalcopy(*MARK);
1610 TAINT_NOT; /* Each item is independent */
1616 /* Stack values are safe: */
1619 POPLOOP2(); /* release loop vars ... */
1623 POPSUB2(); /* release CV and @_ ... */
1626 curpm = newpm; /* ... and pop $1 et al */
1635 register PERL_CONTEXT *cx;
1638 if (op->op_flags & OPf_SPECIAL) {
1639 cxix = dopoptoloop(cxstack_ix);
1641 DIE("Can't \"next\" outside a block");
1644 cxix = dopoptolabel(cPVOP->op_pv);
1646 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1648 if (cxix < cxstack_ix)
1652 oldsave = scopestack[scopestack_ix - 1];
1653 LEAVE_SCOPE(oldsave);
1654 return cx->blk_loop.next_op;
1660 register PERL_CONTEXT *cx;
1663 if (op->op_flags & OPf_SPECIAL) {
1664 cxix = dopoptoloop(cxstack_ix);
1666 DIE("Can't \"redo\" outside a block");
1669 cxix = dopoptolabel(cPVOP->op_pv);
1671 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1673 if (cxix < cxstack_ix)
1677 oldsave = scopestack[scopestack_ix - 1];
1678 LEAVE_SCOPE(oldsave);
1679 return cx->blk_loop.redo_op;
1683 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1687 static char too_deep[] = "Target of goto is too deeply nested";
1691 if (o->op_type == OP_LEAVE ||
1692 o->op_type == OP_SCOPE ||
1693 o->op_type == OP_LEAVELOOP ||
1694 o->op_type == OP_LEAVETRY)
1696 *ops++ = cUNOPo->op_first;
1701 if (o->op_flags & OPf_KIDS) {
1702 /* First try all the kids at this level, since that's likeliest. */
1703 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1704 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1705 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1708 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1709 if (kid == lastgotoprobe)
1711 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1713 (ops[-1]->op_type != OP_NEXTSTATE &&
1714 ops[-1]->op_type != OP_DBSTATE)))
1716 if (o = dofindlabel(kid, label, ops, oplimit))
1726 return pp_goto(ARGS);
1735 register PERL_CONTEXT *cx;
1736 #define GOTO_DEPTH 64
1737 OP *enterops[GOTO_DEPTH];
1739 int do_dump = (op->op_type == OP_DUMP);
1742 if (op->op_flags & OPf_STACKED) {
1745 /* This egregious kludge implements goto &subroutine */
1746 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1748 register PERL_CONTEXT *cx;
1749 CV* cv = (CV*)SvRV(sv);
1754 if (!CvROOT(cv) && !CvXSUB(cv)) {
1756 SV *tmpstr = sv_newmortal();
1757 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1758 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1760 DIE("Goto undefined subroutine");
1763 /* First do some returnish stuff. */
1764 cxix = dopoptosub(cxstack_ix);
1766 DIE("Can't goto subroutine outside a subroutine");
1767 if (cxix < cxstack_ix)
1770 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1771 DIE("Can't goto subroutine from an eval-string");
1773 if (cx->cx_type == CXt_SUB &&
1774 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1775 AV* av = cx->blk_sub.argarray;
1777 items = AvFILLp(av) + 1;
1779 EXTEND(stack_sp, items); /* @_ could have been extended. */
1780 Copy(AvARRAY(av), stack_sp, items, SV*);
1783 SvREFCNT_dec(GvAV(defgv));
1784 GvAV(defgv) = cx->blk_sub.savearray;
1785 #endif /* USE_THREADS */
1789 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1793 av = (AV*)curpad[0];
1797 items = AvFILLp(av) + 1;
1799 EXTEND(stack_sp, items); /* @_ could have been extended. */
1800 Copy(AvARRAY(av), stack_sp, items, SV*);
1803 if (cx->cx_type == CXt_SUB &&
1804 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1805 SvREFCNT_dec(cx->blk_sub.cv);
1806 oldsave = scopestack[scopestack_ix - 1];
1807 LEAVE_SCOPE(oldsave);
1809 /* Now do some callish stuff. */
1812 if (CvOLDSTYLE(cv)) {
1813 I32 (*fp3)_((int,int,int));
1818 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1819 items = (*fp3)(CvXSUBANY(cv).any_i32,
1820 mark - stack_base + 1,
1822 SP = stack_base + items;
1828 stack_sp--; /* There is no cv arg. */
1829 /* Push a mark for the start of arglist */
1831 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1832 /* Pop the current context like a decent sub should */
1833 POPBLOCK(cx, curpm);
1834 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1837 return pop_return();
1840 AV* padlist = CvPADLIST(cv);
1841 SV** svp = AvARRAY(padlist);
1842 if (cx->cx_type == CXt_EVAL) {
1843 in_eval = cx->blk_eval.old_in_eval;
1844 eval_root = cx->blk_eval.old_eval_root;
1845 cx->cx_type = CXt_SUB;
1846 cx->blk_sub.hasargs = 0;
1848 cx->blk_sub.cv = cv;
1849 cx->blk_sub.olddepth = CvDEPTH(cv);
1851 if (CvDEPTH(cv) < 2)
1852 (void)SvREFCNT_inc(cv);
1853 else { /* save temporaries on recursion? */
1854 if (CvDEPTH(cv) == 100 && dowarn)
1855 sub_crush_depth(cv);
1856 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1857 AV *newpad = newAV();
1858 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1859 I32 ix = AvFILLp((AV*)svp[1]);
1860 svp = AvARRAY(svp[0]);
1861 for ( ;ix > 0; ix--) {
1862 if (svp[ix] != &sv_undef) {
1863 char *name = SvPVX(svp[ix]);
1864 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1867 /* outer lexical or anon code */
1868 av_store(newpad, ix,
1869 SvREFCNT_inc(oldpad[ix]) );
1871 else { /* our own lexical */
1873 av_store(newpad, ix, sv = (SV*)newAV());
1874 else if (*name == '%')
1875 av_store(newpad, ix, sv = (SV*)newHV());
1877 av_store(newpad, ix, sv = NEWSV(0,0));
1882 av_store(newpad, ix, sv = NEWSV(0,0));
1886 if (cx->blk_sub.hasargs) {
1889 av_store(newpad, 0, (SV*)av);
1890 AvFLAGS(av) = AVf_REIFY;
1892 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1893 AvFILLp(padlist) = CvDEPTH(cv);
1894 svp = AvARRAY(padlist);
1898 if (!cx->blk_sub.hasargs) {
1899 AV* av = (AV*)curpad[0];
1901 items = AvFILLp(av) + 1;
1903 /* Mark is at the end of the stack. */
1905 Copy(AvARRAY(av), SP + 1, items, SV*);
1910 #endif /* USE_THREADS */
1912 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1914 if (cx->blk_sub.hasargs)
1915 #endif /* USE_THREADS */
1917 AV* av = (AV*)curpad[0];
1921 cx->blk_sub.savearray = GvAV(defgv);
1922 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1923 #endif /* USE_THREADS */
1924 cx->blk_sub.argarray = av;
1927 if (items >= AvMAX(av) + 1) {
1929 if (AvARRAY(av) != ary) {
1930 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1931 SvPVX(av) = (char*)ary;
1933 if (items >= AvMAX(av) + 1) {
1934 AvMAX(av) = items - 1;
1935 Renew(ary,items+1,SV*);
1937 SvPVX(av) = (char*)ary;
1940 Copy(mark,AvARRAY(av),items,SV*);
1941 AvFILLp(av) = items - 1;
1949 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1951 * We do not care about using sv to call CV;
1952 * it's for informational purposes only.
1954 SV *sv = GvSV(DBsub);
1957 if (PERLDB_SUB_NN) {
1958 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1961 gv_efullname3(sv, CvGV(cv), Nullch);
1964 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1965 PUSHMARK( stack_sp );
1966 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1970 RETURNOP(CvSTART(cv));
1974 label = SvPV(sv,na);
1976 else if (op->op_flags & OPf_SPECIAL) {
1978 DIE("goto must have label");
1981 label = cPVOP->op_pv;
1983 if (label && *label) {
1990 for (ix = cxstack_ix; ix >= 0; ix--) {
1992 switch (cx->cx_type) {
1994 gotoprobe = eval_root; /* XXX not good for nested eval */
1997 gotoprobe = cx->blk_oldcop->op_sibling;
2003 gotoprobe = cx->blk_oldcop->op_sibling;
2005 gotoprobe = main_root;
2008 if (CvDEPTH(cx->blk_sub.cv)) {
2009 gotoprobe = CvROOT(cx->blk_sub.cv);
2014 DIE("Can't \"goto\" outside a block");
2018 gotoprobe = main_root;
2021 retop = dofindlabel(gotoprobe, label,
2022 enterops, enterops + GOTO_DEPTH);
2025 lastgotoprobe = gotoprobe;
2028 DIE("Can't find label %s", label);
2030 /* pop unwanted frames */
2032 if (ix < cxstack_ix) {
2039 oldsave = scopestack[scopestack_ix];
2040 LEAVE_SCOPE(oldsave);
2043 /* push wanted frames */
2045 if (*enterops && enterops[1]) {
2047 for (ix = 1; enterops[ix]; ix++) {
2049 /* Eventually we may want to stack the needed arguments
2050 * for each op. For now, we punt on the hard ones. */
2051 if (op->op_type == OP_ENTERITER)
2052 DIE("Can't \"goto\" into the middle of a foreach loop",
2054 (CALLOP->op_ppaddr)(ARGS);
2062 if (!retop) retop = main_start;
2069 restartop = 0; /* hmm, must be GNU unexec().. */
2073 if (top_env->je_prev) {
2091 if (anum == 1 && VMSISH_EXIT)
2104 double value = SvNVx(GvSV(cCOP->cop_gv));
2105 register I32 match = I_32(value);
2108 if (((double)match) > value)
2109 --match; /* was fractional--truncate other way */
2111 match -= cCOP->uop.scop.scop_offset;
2114 else if (match > cCOP->uop.scop.scop_max)
2115 match = cCOP->uop.scop.scop_max;
2116 op = cCOP->uop.scop.scop_next[match];
2126 op = op->op_next; /* can't assume anything */
2128 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2129 match -= cCOP->uop.scop.scop_offset;
2132 else if (match > cCOP->uop.scop.scop_max)
2133 match = cCOP->uop.scop.scop_max;
2134 op = cCOP->uop.scop.scop_next[match];
2143 save_lines(AV *array, SV *sv)
2145 register char *s = SvPVX(sv);
2146 register char *send = SvPVX(sv) + SvCUR(sv);
2148 register I32 line = 1;
2150 while (s && s < send) {
2151 SV *tmpstr = NEWSV(85,0);
2153 sv_upgrade(tmpstr, SVt_PVMG);
2154 t = strchr(s, '\n');
2160 sv_setpvn(tmpstr, s, t - s);
2161 av_store(array, line++, tmpstr);
2176 assert(CATCH_GET == TRUE);
2177 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2181 default: /* topmost level handles it */
2188 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2204 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2205 /* sv Text to convert to OP tree. */
2206 /* startop op_free() this to undo. */
2207 /* code Short string id of the caller. */
2209 dSP; /* Make POPBLOCK work. */
2212 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2216 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2222 /* switch to eval mode */
2224 SAVESPTR(compiling.cop_filegv);
2225 SAVEI16(compiling.cop_line);
2226 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2227 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2228 compiling.cop_line = 1;
2229 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2230 deleting the eval's FILEGV from the stash before gv_check() runs
2231 (i.e. before run-time proper). To work around the coredump that
2232 ensues, we always turn GvMULTI_on for any globals that were
2233 introduced within evals. See force_ident(). GSAR 96-10-12 */
2234 safestr = savepv(tmpbuf);
2235 SAVEDELETE(defstash, safestr, strlen(safestr));
2237 #ifdef OP_IN_REGISTER
2245 op->op_type = 0; /* Avoid uninit warning. */
2246 op->op_flags = 0; /* Avoid uninit warning. */
2247 PUSHBLOCK(cx, CXt_EVAL, SP);
2248 PUSHEVAL(cx, 0, compiling.cop_filegv);
2249 rop = doeval(G_SCALAR, startop);
2253 (*startop)->op_type = OP_NULL;
2254 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2256 *avp = (AV*)SvREFCNT_inc(comppad);
2258 #ifdef OP_IN_REGISTER
2264 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2266 doeval(int gimme, OP** startop)
2279 /* set up a scratch pad */
2284 SAVESPTR(comppad_name);
2285 SAVEI32(comppad_name_fill);
2286 SAVEI32(min_intro_pending);
2287 SAVEI32(max_intro_pending);
2290 for (i = cxstack_ix - 1; i >= 0; i--) {
2291 PERL_CONTEXT *cx = &cxstack[i];
2292 if (cx->cx_type == CXt_EVAL)
2294 else if (cx->cx_type == CXt_SUB) {
2295 caller = cx->blk_sub.cv;
2301 compcv = (CV*)NEWSV(1104,0);
2302 sv_upgrade((SV *)compcv, SVt_PVCV);
2303 CvUNIQUE_on(compcv);
2305 CvOWNER(compcv) = 0;
2306 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2307 MUTEX_INIT(CvMUTEXP(compcv));
2308 #endif /* USE_THREADS */
2311 av_push(comppad, Nullsv);
2312 curpad = AvARRAY(comppad);
2313 comppad_name = newAV();
2314 comppad_name_fill = 0;
2315 min_intro_pending = 0;
2318 av_store(comppad_name, 0, newSVpv("@_", 2));
2319 curpad[0] = (SV*)newAV();
2320 SvPADMY_on(curpad[0]); /* XXX Needed? */
2321 #endif /* USE_THREADS */
2323 comppadlist = newAV();
2324 AvREAL_off(comppadlist);
2325 av_store(comppadlist, 0, (SV*)comppad_name);
2326 av_store(comppadlist, 1, (SV*)comppad);
2327 CvPADLIST(compcv) = comppadlist;
2329 if (!saveop || saveop->op_type != OP_REQUIRE)
2330 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2334 /* make sure we compile in the right package */
2336 newstash = curcop->cop_stash;
2337 if (curstash != newstash) {
2339 curstash = newstash;
2343 SAVEFREESV(beginav);
2345 /* try to compile it */
2349 curcop = &compiling;
2350 curcop->cop_arybase = 0;
2352 rs = newSVpv("\n", 1);
2353 if (saveop && saveop->op_flags & OPf_SPECIAL)
2357 if (yyparse() || error_count || !eval_root) {
2361 I32 optype = 0; /* Might be reset by POPEVAL. */
2368 SP = stack_base + POPMARK; /* pop original mark */
2376 if (optype == OP_REQUIRE) {
2377 char* msg = SvPVx(ERRSV, na);
2378 DIE("%s", *msg ? msg : "Compilation failed in require");
2379 } else if (startop) {
2380 char* msg = SvPVx(ERRSV, na);
2384 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2387 rs = SvREFCNT_inc(nrs);
2389 MUTEX_LOCK(&eval_mutex);
2391 COND_SIGNAL(&eval_cond);
2392 MUTEX_UNLOCK(&eval_mutex);
2393 #endif /* USE_THREADS */
2397 rs = SvREFCNT_inc(nrs);
2398 compiling.cop_line = 0;
2400 *startop = eval_root;
2401 SvREFCNT_dec(CvOUTSIDE(compcv));
2402 CvOUTSIDE(compcv) = Nullcv;
2404 SAVEFREEOP(eval_root);
2406 scalarvoid(eval_root);
2407 else if (gimme & G_ARRAY)
2412 DEBUG_x(dump_eval());
2414 /* Register with debugger: */
2415 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2416 CV *cv = perl_get_cv("DB::postponed", FALSE);
2420 XPUSHs((SV*)compiling.cop_filegv);
2422 perl_call_sv((SV*)cv, G_DISCARD);
2426 /* compiled okay, so do it */
2428 CvDEPTH(compcv) = 1;
2429 SP = stack_base + POPMARK; /* pop original mark */
2430 op = saveop; /* The caller may need it. */
2432 MUTEX_LOCK(&eval_mutex);
2434 COND_SIGNAL(&eval_cond);
2435 MUTEX_UNLOCK(&eval_mutex);
2436 #endif /* USE_THREADS */
2438 RETURNOP(eval_start);
2444 register PERL_CONTEXT *cx;
2449 SV *namesv = Nullsv;
2451 I32 gimme = G_SCALAR;
2452 PerlIO *tryrsfp = 0;
2455 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2456 SET_NUMERIC_STANDARD();
2457 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2458 DIE("Perl %s required--this is only version %s, stopped",
2459 SvPV(sv,na),patchlevel);
2462 name = SvPV(sv, len);
2463 if (!(name && len > 0 && *name))
2464 DIE("Null filename used");
2465 TAINT_PROPER("require");
2466 if (op->op_type == OP_REQUIRE &&
2467 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2471 /* prepare to compile file */
2476 (name[1] == '.' && name[2] == '/')))
2478 || (name[0] && name[1] == ':')
2481 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2484 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2485 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2490 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2493 AV *ar = GvAVn(incgv);
2497 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2500 namesv = NEWSV(806, 0);
2501 for (i = 0; i <= AvFILL(ar); i++) {
2502 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2505 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2507 sv_setpv(namesv, unixdir);
2508 sv_catpv(namesv, unixname);
2510 sv_setpvf(namesv, "%s/%s", dir, name);
2512 tryname = SvPVX(namesv);
2513 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2515 if (tryname[0] == '.' && tryname[1] == '/')
2522 SAVESPTR(compiling.cop_filegv);
2523 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2524 SvREFCNT_dec(namesv);
2526 if (op->op_type == OP_REQUIRE) {
2527 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2528 SV *dirmsgsv = NEWSV(0, 0);
2529 AV *ar = GvAVn(incgv);
2531 if (instr(SvPVX(msg), ".h "))
2532 sv_catpv(msg, " (change .h to .ph maybe?)");
2533 if (instr(SvPVX(msg), ".ph "))
2534 sv_catpv(msg, " (did you run h2ph?)");
2535 sv_catpv(msg, " (@INC contains:");
2536 for (i = 0; i <= AvFILL(ar); i++) {
2537 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2538 sv_setpvf(dirmsgsv, " %s", dir);
2539 sv_catsv(msg, dirmsgsv);
2541 sv_catpvn(msg, ")", 1);
2542 SvREFCNT_dec(dirmsgsv);
2549 /* Assume success here to prevent recursive requirement. */
2550 (void)hv_store(GvHVn(incgv), name, strlen(name),
2551 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2555 lex_start(sv_2mortal(newSVpv("",0)));
2557 save_aptr(&rsfp_filters);
2558 rsfp_filters = NULL;
2562 name = savepv(name);
2567 /* switch to eval mode */
2569 push_return(op->op_next);
2570 PUSHBLOCK(cx, CXt_EVAL, SP);
2571 PUSHEVAL(cx, name, compiling.cop_filegv);
2573 compiling.cop_line = 0;
2577 MUTEX_LOCK(&eval_mutex);
2578 if (eval_owner && eval_owner != thr)
2580 COND_WAIT(&eval_cond, &eval_mutex);
2582 MUTEX_UNLOCK(&eval_mutex);
2583 #endif /* USE_THREADS */
2584 return DOCATCH(doeval(G_SCALAR, NULL));
2589 return pp_require(ARGS);
2595 register PERL_CONTEXT *cx;
2597 I32 gimme = GIMME_V, was = sub_generation;
2598 char tmpbuf[TYPE_DIGITS(long) + 12];
2603 if (!SvPV(sv,len) || !len)
2605 TAINT_PROPER("eval");
2611 /* switch to eval mode */
2613 SAVESPTR(compiling.cop_filegv);
2614 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2615 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2616 compiling.cop_line = 1;
2617 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2618 deleting the eval's FILEGV from the stash before gv_check() runs
2619 (i.e. before run-time proper). To work around the coredump that
2620 ensues, we always turn GvMULTI_on for any globals that were
2621 introduced within evals. See force_ident(). GSAR 96-10-12 */
2622 safestr = savepv(tmpbuf);
2623 SAVEDELETE(defstash, safestr, strlen(safestr));
2625 hints = op->op_targ;
2627 push_return(op->op_next);
2628 PUSHBLOCK(cx, CXt_EVAL, SP);
2629 PUSHEVAL(cx, 0, compiling.cop_filegv);
2631 /* prepare to compile string */
2633 if (PERLDB_LINE && curstash != debstash)
2634 save_lines(GvAV(compiling.cop_filegv), linestr);
2637 MUTEX_LOCK(&eval_mutex);
2638 if (eval_owner && eval_owner != thr)
2640 COND_WAIT(&eval_cond, &eval_mutex);
2642 MUTEX_UNLOCK(&eval_mutex);
2643 #endif /* USE_THREADS */
2644 ret = doeval(gimme, NULL);
2645 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2646 && ret != op->op_next) { /* Successive compilation. */
2647 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2649 return DOCATCH(ret);
2659 register PERL_CONTEXT *cx;
2661 U8 save_flags = op -> op_flags;
2666 retop = pop_return();
2669 if (gimme == G_VOID)
2671 else if (gimme == G_SCALAR) {
2674 if (SvFLAGS(TOPs) & SVs_TEMP)
2677 *MARK = sv_mortalcopy(TOPs);
2685 /* in case LEAVE wipes old return values */
2686 for (mark = newsp + 1; mark <= SP; mark++) {
2687 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2688 *mark = sv_mortalcopy(*mark);
2689 TAINT_NOT; /* Each item is independent */
2693 curpm = newpm; /* Don't pop $1 et al till now */
2696 * Closures mentioned at top level of eval cannot be referenced
2697 * again, and their presence indirectly causes a memory leak.
2698 * (Note that the fact that compcv and friends are still set here
2699 * is, AFAIK, an accident.) --Chip
2701 if (AvFILLp(comppad_name) >= 0) {
2702 SV **svp = AvARRAY(comppad_name);
2704 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2706 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2708 svp[ix] = &sv_undef;
2712 SvREFCNT_dec(CvOUTSIDE(sv));
2713 CvOUTSIDE(sv) = Nullcv;
2726 assert(CvDEPTH(compcv) == 1);
2728 CvDEPTH(compcv) = 0;
2731 if (optype == OP_REQUIRE &&
2732 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2734 /* Unassume the success we assumed earlier. */
2735 char *name = cx->blk_eval.old_name;
2736 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2737 retop = die("%s did not return a true value", name);
2738 /* die_where() did LEAVE, or we won't be here */
2742 if (!(save_flags & OPf_SPECIAL))
2752 register PERL_CONTEXT *cx;
2753 I32 gimme = GIMME_V;
2758 push_return(cLOGOP->op_other->op_next);
2759 PUSHBLOCK(cx, CXt_EVAL, SP);
2761 eval_root = op; /* Only needed so that goto works right. */
2766 return DOCATCH(op->op_next);
2776 register PERL_CONTEXT *cx;
2784 if (gimme == G_VOID)
2786 else if (gimme == G_SCALAR) {
2789 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2792 *MARK = sv_mortalcopy(TOPs);
2801 /* in case LEAVE wipes old return values */
2802 for (mark = newsp + 1; mark <= SP; mark++) {
2803 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2804 *mark = sv_mortalcopy(*mark);
2805 TAINT_NOT; /* Each item is independent */
2809 curpm = newpm; /* Don't pop $1 et al till now */
2820 register char *s = SvPV_force(sv, len);
2821 register char *send = s + len;
2822 register char *base;
2823 register I32 skipspaces = 0;
2826 bool postspace = FALSE;
2834 croak("Null picture in formline");
2836 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2841 *fpc++ = FF_LINEMARK;
2842 noblank = repeat = FALSE;
2860 case ' ': case '\t':
2871 *fpc++ = FF_LITERAL;
2879 *fpc++ = skipspaces;
2883 *fpc++ = FF_NEWLINE;
2887 arg = fpc - linepc + 1;
2894 *fpc++ = FF_LINEMARK;
2895 noblank = repeat = FALSE;
2904 ischop = s[-1] == '^';
2910 arg = (s - base) - 1;
2912 *fpc++ = FF_LITERAL;
2921 *fpc++ = FF_LINEGLOB;
2923 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2924 arg = ischop ? 512 : 0;
2934 arg |= 256 + (s - f);
2936 *fpc++ = s - base; /* fieldsize for FETCH */
2937 *fpc++ = FF_DECIMAL;
2942 bool ismore = FALSE;
2945 while (*++s == '>') ;
2946 prespace = FF_SPACE;
2948 else if (*s == '|') {
2949 while (*++s == '|') ;
2950 prespace = FF_HALFSPACE;
2955 while (*++s == '<') ;
2958 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2962 *fpc++ = s - base; /* fieldsize for FETCH */
2964 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2982 { /* need to jump to the next word */
2984 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2985 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2986 s = SvPVX(sv) + SvCUR(sv) + z;
2988 Copy(fops, s, arg, U16);
2990 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2995 * The rest of this file was derived from source code contributed
2998 * NOTE: this code was derived from Tom Horsley's qsort replacement
2999 * and should not be confused with the original code.
3002 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3004 Permission granted to distribute under the same terms as perl which are
3007 This program is free software; you can redistribute it and/or modify
3008 it under the terms of either:
3010 a) the GNU General Public License as published by the Free
3011 Software Foundation; either version 1, or (at your option) any
3014 b) the "Artistic License" which comes with this Kit.
3016 Details on the perl license can be found in the perl source code which
3017 may be located via the www.perl.com web page.
3019 This is the most wonderfulest possible qsort I can come up with (and
3020 still be mostly portable) My (limited) tests indicate it consistently
3021 does about 20% fewer calls to compare than does the qsort in the Visual
3022 C++ library, other vendors may vary.
3024 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3025 others I invented myself (or more likely re-invented since they seemed
3026 pretty obvious once I watched the algorithm operate for a while).
3028 Most of this code was written while watching the Marlins sweep the Giants
3029 in the 1997 National League Playoffs - no Braves fans allowed to use this
3030 code (just kidding :-).
3032 I realize that if I wanted to be true to the perl tradition, the only
3033 comment in this file would be something like:
3035 ...they shuffled back towards the rear of the line. 'No, not at the
3036 rear!' the slave-driver shouted. 'Three files up. And stay there...
3038 However, I really needed to violate that tradition just so I could keep
3039 track of what happens myself, not to mention some poor fool trying to
3040 understand this years from now :-).
3043 /* ********************************************************** Configuration */
3045 #ifndef QSORT_ORDER_GUESS
3046 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3049 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3050 future processing - a good max upper bound is log base 2 of memory size
3051 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3052 safely be smaller than that since the program is taking up some space and
3053 most operating systems only let you grab some subset of contiguous
3054 memory (not to mention that you are normally sorting data larger than
3055 1 byte element size :-).
3057 #ifndef QSORT_MAX_STACK
3058 #define QSORT_MAX_STACK 32
3061 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3062 Anything bigger and we use qsort. If you make this too small, the qsort
3063 will probably break (or become less efficient), because it doesn't expect
3064 the middle element of a partition to be the same as the right or left -
3065 you have been warned).
3067 #ifndef QSORT_BREAK_EVEN
3068 #define QSORT_BREAK_EVEN 6
3071 /* ************************************************************* Data Types */
3073 /* hold left and right index values of a partition waiting to be sorted (the
3074 partition includes both left and right - right is NOT one past the end or
3075 anything like that).
3077 struct partition_stack_entry {
3080 #ifdef QSORT_ORDER_GUESS
3081 int qsort_break_even;
3085 /* ******************************************************* Shorthand Macros */
3087 /* Note that these macros will be used from inside the qsort function where
3088 we happen to know that the variable 'elt_size' contains the size of an
3089 array element and the variable 'temp' points to enough space to hold a
3090 temp element and the variable 'array' points to the array being sorted
3091 and 'compare' is the pointer to the compare routine.
3093 Also note that there are very many highly architecture specific ways
3094 these might be sped up, but this is simply the most generally portable
3095 code I could think of.
3098 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3101 #define qsort_cmp(elt1, elt2) \
3102 ((this->*compare)(array[elt1], array[elt2]))
3104 #define qsort_cmp(elt1, elt2) \
3105 ((*compare)(array[elt1], array[elt2]))
3108 #ifdef QSORT_ORDER_GUESS
3109 #define QSORT_NOTICE_SWAP swapped++;
3111 #define QSORT_NOTICE_SWAP
3114 /* swaps contents of array elements elt1, elt2.
3116 #define qsort_swap(elt1, elt2) \
3119 temp = array[elt1]; \
3120 array[elt1] = array[elt2]; \
3121 array[elt2] = temp; \
3124 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3125 elt3 and elt3 gets elt1.
3127 #define qsort_rotate(elt1, elt2, elt3) \
3130 temp = array[elt1]; \
3131 array[elt1] = array[elt2]; \
3132 array[elt2] = array[elt3]; \
3133 array[elt3] = temp; \
3136 /* ************************************************************ Debug stuff */
3143 return; /* good place to set a breakpoint */
3146 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3149 doqsort_all_asserts(
3153 int (*compare)(const void * elt1, const void * elt2),
3154 int pc_left, int pc_right, int u_left, int u_right)
3158 qsort_assert(pc_left <= pc_right);
3159 qsort_assert(u_right < pc_left);
3160 qsort_assert(pc_right < u_left);
3161 for (i = u_right + 1; i < pc_left; ++i) {
3162 qsort_assert(qsort_cmp(i, pc_left) < 0);
3164 for (i = pc_left; i < pc_right; ++i) {
3165 qsort_assert(qsort_cmp(i, pc_right) == 0);
3167 for (i = pc_right + 1; i < u_left; ++i) {
3168 qsort_assert(qsort_cmp(pc_right, i) < 0);
3172 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3173 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3174 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3178 #define qsort_assert(t) ((void)0)
3180 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3184 /* ****************************************************************** qsort */
3188 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3193 I32 (*compare)(SV *a, SV *b))
3198 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3199 int next_stack_entry = 0;
3203 #ifdef QSORT_ORDER_GUESS
3204 int qsort_break_even;
3208 /* Make sure we actually have work to do.
3210 if (num_elts <= 1) {
3214 /* Setup the initial partition definition and fall into the sorting loop
3217 part_right = (int)(num_elts - 1);
3218 #ifdef QSORT_ORDER_GUESS
3219 qsort_break_even = QSORT_BREAK_EVEN;
3221 #define qsort_break_even QSORT_BREAK_EVEN
3224 if ((part_right - part_left) >= qsort_break_even) {
3225 /* OK, this is gonna get hairy, so lets try to document all the
3226 concepts and abbreviations and variables and what they keep
3229 pc: pivot chunk - the set of array elements we accumulate in the
3230 middle of the partition, all equal in value to the original
3231 pivot element selected. The pc is defined by:
3233 pc_left - the leftmost array index of the pc
3234 pc_right - the rightmost array index of the pc
3236 we start with pc_left == pc_right and only one element
3237 in the pivot chunk (but it can grow during the scan).
3239 u: uncompared elements - the set of elements in the partition
3240 we have not yet compared to the pivot value. There are two
3241 uncompared sets during the scan - one to the left of the pc
3242 and one to the right.
3244 u_right - the rightmost index of the left side's uncompared set
3245 u_left - the leftmost index of the right side's uncompared set
3247 The leftmost index of the left sides's uncompared set
3248 doesn't need its own variable because it is always defined
3249 by the leftmost edge of the whole partition (part_left). The
3250 same goes for the rightmost edge of the right partition
3253 We know there are no uncompared elements on the left once we
3254 get u_right < part_left and no uncompared elements on the
3255 right once u_left > part_right. When both these conditions
3256 are met, we have completed the scan of the partition.
3258 Any elements which are between the pivot chunk and the
3259 uncompared elements should be less than the pivot value on
3260 the left side and greater than the pivot value on the right
3261 side (in fact, the goal of the whole algorithm is to arrange
3262 for that to be true and make the groups of less-than and
3263 greater-then elements into new partitions to sort again).
3265 As you marvel at the complexity of the code and wonder why it
3266 has to be so confusing. Consider some of the things this level
3267 of confusion brings:
3269 Once I do a compare, I squeeze every ounce of juice out of it. I
3270 never do compare calls I don't have to do, and I certainly never
3273 I also never swap any elements unless I can prove there is a
3274 good reason. Many sort algorithms will swap a known value with
3275 an uncompared value just to get things in the right place (or
3276 avoid complexity :-), but that uncompared value, once it gets
3277 compared, may then have to be swapped again. A lot of the
3278 complexity of this code is due to the fact that it never swaps
3279 anything except compared values, and it only swaps them when the
3280 compare shows they are out of position.
3282 int pc_left, pc_right;
3283 int u_right, u_left;
3287 pc_left = ((part_left + part_right) / 2);
3289 u_right = pc_left - 1;
3290 u_left = pc_right + 1;
3292 /* Qsort works best when the pivot value is also the median value
3293 in the partition (unfortunately you can't find the median value
3294 without first sorting :-), so to give the algorithm a helping
3295 hand, we pick 3 elements and sort them and use the median value
3296 of that tiny set as the pivot value.
3298 Some versions of qsort like to use the left middle and right as
3299 the 3 elements to sort so they can insure the ends of the
3300 partition will contain values which will stop the scan in the
3301 compare loop, but when you have to call an arbitrarily complex
3302 routine to do a compare, its really better to just keep track of
3303 array index values to know when you hit the edge of the
3304 partition and avoid the extra compare. An even better reason to
3305 avoid using a compare call is the fact that you can drop off the
3306 edge of the array if someone foolishly provides you with an
3307 unstable compare function that doesn't always provide consistent
3310 So, since it is simpler for us to compare the three adjacent
3311 elements in the middle of the partition, those are the ones we
3312 pick here (conveniently pointed at by u_right, pc_left, and
3313 u_left). The values of the left, center, and right elements
3314 are refered to as l c and r in the following comments.
3317 #ifdef QSORT_ORDER_GUESS
3320 s = qsort_cmp(u_right, pc_left);
3323 s = qsort_cmp(pc_left, u_left);
3324 /* if l < c, c < r - already in order - nothing to do */
3326 /* l < c, c == r - already in order, pc grows */
3328 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3330 /* l < c, c > r - need to know more */
3331 s = qsort_cmp(u_right, u_left);
3333 /* l < c, c > r, l < r - swap c & r to get ordered */
3334 qsort_swap(pc_left, u_left);
3335 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3336 } else if (s == 0) {
3337 /* l < c, c > r, l == r - swap c&r, grow pc */
3338 qsort_swap(pc_left, u_left);
3340 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3342 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3343 qsort_rotate(pc_left, u_right, u_left);
3344 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3347 } else if (s == 0) {
3349 s = qsort_cmp(pc_left, u_left);
3351 /* l == c, c < r - already in order, grow pc */
3353 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3354 } else if (s == 0) {
3355 /* l == c, c == r - already in order, grow pc both ways */
3358 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3360 /* l == c, c > r - swap l & r, grow pc */
3361 qsort_swap(u_right, u_left);
3363 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3367 s = qsort_cmp(pc_left, u_left);
3369 /* l > c, c < r - need to know more */
3370 s = qsort_cmp(u_right, u_left);
3372 /* l > c, c < r, l < r - swap l & c to get ordered */
3373 qsort_swap(u_right, pc_left);
3374 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3375 } else if (s == 0) {
3376 /* l > c, c < r, l == r - swap l & c, grow pc */
3377 qsort_swap(u_right, pc_left);
3379 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3381 /* l > c, c < r, l > r - rotate lcr into crl to order */
3382 qsort_rotate(u_right, pc_left, u_left);
3383 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3385 } else if (s == 0) {
3386 /* l > c, c == r - swap ends, grow pc */
3387 qsort_swap(u_right, u_left);
3389 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3391 /* l > c, c > r - swap ends to get in order */
3392 qsort_swap(u_right, u_left);
3393 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3396 /* We now know the 3 middle elements have been compared and
3397 arranged in the desired order, so we can shrink the uncompared
3402 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3404 /* The above massive nested if was the simple part :-). We now have
3405 the middle 3 elements ordered and we need to scan through the
3406 uncompared sets on either side, swapping elements that are on
3407 the wrong side or simply shuffling equal elements around to get
3408 all equal elements into the pivot chunk.
3412 int still_work_on_left;
3413 int still_work_on_right;
3415 /* Scan the uncompared values on the left. If I find a value
3416 equal to the pivot value, move it over so it is adjacent to
3417 the pivot chunk and expand the pivot chunk. If I find a value
3418 less than the pivot value, then just leave it - its already
3419 on the correct side of the partition. If I find a greater
3420 value, then stop the scan.
3422 while (still_work_on_left = (u_right >= part_left)) {
3423 s = qsort_cmp(u_right, pc_left);
3426 } else if (s == 0) {
3428 if (pc_left != u_right) {
3429 qsort_swap(u_right, pc_left);
3435 qsort_assert(u_right < pc_left);
3436 qsort_assert(pc_left <= pc_right);
3437 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3438 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3441 /* Do a mirror image scan of uncompared values on the right
3443 while (still_work_on_right = (u_left <= part_right)) {
3444 s = qsort_cmp(pc_right, u_left);
3447 } else if (s == 0) {
3449 if (pc_right != u_left) {
3450 qsort_swap(pc_right, u_left);
3456 qsort_assert(u_left > pc_right);
3457 qsort_assert(pc_left <= pc_right);
3458 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3459 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3462 if (still_work_on_left) {
3463 /* I know I have a value on the left side which needs to be
3464 on the right side, but I need to know more to decide
3465 exactly the best thing to do with it.
3467 if (still_work_on_right) {
3468 /* I know I have values on both side which are out of
3469 position. This is a big win because I kill two birds
3470 with one swap (so to speak). I can advance the
3471 uncompared pointers on both sides after swapping both
3472 of them into the right place.
3474 qsort_swap(u_right, u_left);
3477 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3479 /* I have an out of position value on the left, but the
3480 right is fully scanned, so I "slide" the pivot chunk
3481 and any less-than values left one to make room for the
3482 greater value over on the right. If the out of position
3483 value is immediately adjacent to the pivot chunk (there
3484 are no less-than values), I can do that with a swap,
3485 otherwise, I have to rotate one of the less than values
3486 into the former position of the out of position value
3487 and the right end of the pivot chunk into the left end
3491 if (pc_left == u_right) {
3492 qsort_swap(u_right, pc_right);
3493 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3495 qsort_rotate(u_right, pc_left, pc_right);
3496 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3501 } else if (still_work_on_right) {
3502 /* Mirror image of complex case above: I have an out of
3503 position value on the right, but the left is fully
3504 scanned, so I need to shuffle things around to make room
3505 for the right value on the left.
3508 if (pc_right == u_left) {
3509 qsort_swap(u_left, pc_left);
3510 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3512 qsort_rotate(pc_right, pc_left, u_left);
3513 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3518 /* No more scanning required on either side of partition,
3519 break out of loop and figure out next set of partitions
3525 /* The elements in the pivot chunk are now in the right place. They
3526 will never move or be compared again. All I have to do is decide
3527 what to do with the stuff to the left and right of the pivot
3530 Notes on the QSORT_ORDER_GUESS ifdef code:
3532 1. If I just built these partitions without swapping any (or
3533 very many) elements, there is a chance that the elements are
3534 already ordered properly (being properly ordered will
3535 certainly result in no swapping, but the converse can't be
3538 2. A (properly written) insertion sort will run faster on
3539 already ordered data than qsort will.
3541 3. Perhaps there is some way to make a good guess about
3542 switching to an insertion sort earlier than partition size 6
3543 (for instance - we could save the partition size on the stack
3544 and increase the size each time we find we didn't swap, thus
3545 switching to insertion sort earlier for partitions with a
3546 history of not swapping).
3548 4. Naturally, if I just switch right away, it will make
3549 artificial benchmarks with pure ascending (or descending)
3550 data look really good, but is that a good reason in general?
3554 #ifdef QSORT_ORDER_GUESS
3556 #if QSORT_ORDER_GUESS == 1
3557 qsort_break_even = (part_right - part_left) + 1;
3559 #if QSORT_ORDER_GUESS == 2
3560 qsort_break_even *= 2;
3562 #if QSORT_ORDER_GUESS == 3
3563 int prev_break = qsort_break_even;
3564 qsort_break_even *= qsort_break_even;
3565 if (qsort_break_even < prev_break) {
3566 qsort_break_even = (part_right - part_left) + 1;
3570 qsort_break_even = QSORT_BREAK_EVEN;
3574 if (part_left < pc_left) {
3575 /* There are elements on the left which need more processing.
3576 Check the right as well before deciding what to do.
3578 if (pc_right < part_right) {
3579 /* We have two partitions to be sorted. Stack the biggest one
3580 and process the smallest one on the next iteration. This
3581 minimizes the stack height by insuring that any additional
3582 stack entries must come from the smallest partition which
3583 (because it is smallest) will have the fewest
3584 opportunities to generate additional stack entries.
3586 if ((part_right - pc_right) > (pc_left - part_left)) {
3587 /* stack the right partition, process the left */
3588 partition_stack[next_stack_entry].left = pc_right + 1;
3589 partition_stack[next_stack_entry].right = part_right;
3590 #ifdef QSORT_ORDER_GUESS
3591 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3593 part_right = pc_left - 1;
3595 /* stack the left partition, process the right */
3596 partition_stack[next_stack_entry].left = part_left;
3597 partition_stack[next_stack_entry].right = pc_left - 1;
3598 #ifdef QSORT_ORDER_GUESS
3599 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3601 part_left = pc_right + 1;
3603 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3606 /* The elements on the left are the only remaining elements
3607 that need sorting, arrange for them to be processed as the
3610 part_right = pc_left - 1;
3612 } else if (pc_right < part_right) {
3613 /* There is only one chunk on the right to be sorted, make it
3614 the new partition and loop back around.
3616 part_left = pc_right + 1;
3618 /* This whole partition wound up in the pivot chunk, so
3619 we need to get a new partition off the stack.
3621 if (next_stack_entry == 0) {
3622 /* the stack is empty - we are done */
3626 part_left = partition_stack[next_stack_entry].left;
3627 part_right = partition_stack[next_stack_entry].right;
3628 #ifdef QSORT_ORDER_GUESS
3629 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3633 /* This partition is too small to fool with qsort complexity, just
3634 do an ordinary insertion sort to minimize overhead.
3637 /* Assume 1st element is in right place already, and start checking
3638 at 2nd element to see where it should be inserted.
3640 for (i = part_left + 1; i <= part_right; ++i) {
3642 /* Scan (backwards - just in case 'i' is already in right place)
3643 through the elements already sorted to see if the ith element
3644 belongs ahead of one of them.
3646 for (j = i - 1; j >= part_left; --j) {
3647 if (qsort_cmp(i, j) >= 0) {
3648 /* i belongs right after j
3655 /* Looks like we really need to move some things
3659 for (k = i - 1; k >= j; --k)
3660 array[k + 1] = array[k];
3665 /* That partition is now sorted, grab the next one, or get out
3666 of the loop if there aren't any more.
3669 if (next_stack_entry == 0) {
3670 /* the stack is empty - we are done */
3674 part_left = partition_stack[next_stack_entry].left;
3675 part_right = partition_stack[next_stack_entry].right;
3676 #ifdef QSORT_ORDER_GUESS
3677 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3682 /* Believe it or not, the array is sorted at this point! */