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 = pregcomp(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 || !regexec_flags(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);
1391 sv_setiv(*svp, 0); /* make sure index SV is IV capable */
1394 cx->blk_loop.iterlval = newSVsv(sv);
1398 cx->blk_loop.iterary = curstack;
1399 AvFILLp(curstack) = SP - stack_base;
1400 cx->blk_loop.iterix = MARK - stack_base;
1409 register PERL_CONTEXT *cx;
1410 I32 gimme = GIMME_V;
1416 PUSHBLOCK(cx, CXt_LOOP, SP);
1417 PUSHLOOP(cx, 0, SP);
1425 register PERL_CONTEXT *cx;
1426 struct block_loop cxloop;
1434 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1437 if (gimme == G_VOID)
1439 else if (gimme == G_SCALAR) {
1441 *++newsp = sv_mortalcopy(*SP);
1443 *++newsp = &sv_undef;
1447 *++newsp = sv_mortalcopy(*++mark);
1448 TAINT_NOT; /* Each item is independent */
1454 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1455 curpm = newpm; /* ... and pop $1 et al */
1467 register PERL_CONTEXT *cx;
1468 struct block_sub cxsub;
1469 bool popsub2 = FALSE;
1475 if (curstackinfo->si_type == PERLSI_SORT) {
1476 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1477 if (cxstack_ix > sortcxix)
1479 AvARRAY(curstack)[1] = *SP;
1480 stack_sp = stack_base + 1;
1485 cxix = dopoptosub(cxstack_ix);
1487 DIE("Can't return outside a subroutine");
1488 if (cxix < cxstack_ix)
1492 switch (cx->cx_type) {
1494 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1499 if (optype == OP_REQUIRE &&
1500 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1502 /* Unassume the success we assumed earlier. */
1503 char *name = cx->blk_eval.old_name;
1504 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1505 DIE("%s did not return a true value", name);
1509 DIE("panic: return");
1513 if (gimme == G_SCALAR) {
1516 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1518 *++newsp = SvREFCNT_inc(*SP);
1523 *++newsp = sv_mortalcopy(*SP);
1526 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1528 *++newsp = sv_mortalcopy(*SP);
1530 *++newsp = &sv_undef;
1532 else if (gimme == G_ARRAY) {
1533 while (++MARK <= SP) {
1534 *++newsp = (popsub2 && SvTEMP(*MARK))
1535 ? *MARK : sv_mortalcopy(*MARK);
1536 TAINT_NOT; /* Each item is independent */
1541 /* Stack values are safe: */
1543 POPSUB2(); /* release CV and @_ ... */
1545 curpm = newpm; /* ... and pop $1 et al */
1548 return pop_return();
1555 register PERL_CONTEXT *cx;
1556 struct block_loop cxloop;
1557 struct block_sub cxsub;
1564 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1566 if (op->op_flags & OPf_SPECIAL) {
1567 cxix = dopoptoloop(cxstack_ix);
1569 DIE("Can't \"last\" outside a block");
1572 cxix = dopoptolabel(cPVOP->op_pv);
1574 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1576 if (cxix < cxstack_ix)
1580 switch (cx->cx_type) {
1582 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1584 nextop = cxloop.last_op->op_next;
1587 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1589 nextop = pop_return();
1593 nextop = pop_return();
1600 if (gimme == G_SCALAR) {
1602 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1603 ? *SP : sv_mortalcopy(*SP);
1605 *++newsp = &sv_undef;
1607 else if (gimme == G_ARRAY) {
1608 while (++MARK <= SP) {
1609 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1610 ? *MARK : sv_mortalcopy(*MARK);
1611 TAINT_NOT; /* Each item is independent */
1617 /* Stack values are safe: */
1620 POPLOOP2(); /* release loop vars ... */
1624 POPSUB2(); /* release CV and @_ ... */
1627 curpm = newpm; /* ... and pop $1 et al */
1636 register PERL_CONTEXT *cx;
1639 if (op->op_flags & OPf_SPECIAL) {
1640 cxix = dopoptoloop(cxstack_ix);
1642 DIE("Can't \"next\" outside a block");
1645 cxix = dopoptolabel(cPVOP->op_pv);
1647 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1649 if (cxix < cxstack_ix)
1653 oldsave = scopestack[scopestack_ix - 1];
1654 LEAVE_SCOPE(oldsave);
1655 return cx->blk_loop.next_op;
1661 register PERL_CONTEXT *cx;
1664 if (op->op_flags & OPf_SPECIAL) {
1665 cxix = dopoptoloop(cxstack_ix);
1667 DIE("Can't \"redo\" outside a block");
1670 cxix = dopoptolabel(cPVOP->op_pv);
1672 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1674 if (cxix < cxstack_ix)
1678 oldsave = scopestack[scopestack_ix - 1];
1679 LEAVE_SCOPE(oldsave);
1680 return cx->blk_loop.redo_op;
1684 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1688 static char too_deep[] = "Target of goto is too deeply nested";
1692 if (o->op_type == OP_LEAVE ||
1693 o->op_type == OP_SCOPE ||
1694 o->op_type == OP_LEAVELOOP ||
1695 o->op_type == OP_LEAVETRY)
1697 *ops++ = cUNOPo->op_first;
1702 if (o->op_flags & OPf_KIDS) {
1703 /* First try all the kids at this level, since that's likeliest. */
1704 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1705 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1706 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1709 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1710 if (kid == lastgotoprobe)
1712 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1714 (ops[-1]->op_type != OP_NEXTSTATE &&
1715 ops[-1]->op_type != OP_DBSTATE)))
1717 if (o = dofindlabel(kid, label, ops, oplimit))
1727 return pp_goto(ARGS);
1736 register PERL_CONTEXT *cx;
1737 #define GOTO_DEPTH 64
1738 OP *enterops[GOTO_DEPTH];
1740 int do_dump = (op->op_type == OP_DUMP);
1743 if (op->op_flags & OPf_STACKED) {
1746 /* This egregious kludge implements goto &subroutine */
1747 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1749 register PERL_CONTEXT *cx;
1750 CV* cv = (CV*)SvRV(sv);
1755 if (!CvROOT(cv) && !CvXSUB(cv)) {
1757 SV *tmpstr = sv_newmortal();
1758 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1759 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1761 DIE("Goto undefined subroutine");
1764 /* First do some returnish stuff. */
1765 cxix = dopoptosub(cxstack_ix);
1767 DIE("Can't goto subroutine outside a subroutine");
1768 if (cxix < cxstack_ix)
1771 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1772 DIE("Can't goto subroutine from an eval-string");
1774 if (cx->cx_type == CXt_SUB &&
1775 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1776 AV* av = cx->blk_sub.argarray;
1778 items = AvFILLp(av) + 1;
1780 EXTEND(stack_sp, items); /* @_ could have been extended. */
1781 Copy(AvARRAY(av), stack_sp, items, SV*);
1784 SvREFCNT_dec(GvAV(defgv));
1785 GvAV(defgv) = cx->blk_sub.savearray;
1786 #endif /* USE_THREADS */
1790 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1794 av = (AV*)curpad[0];
1798 items = AvFILLp(av) + 1;
1800 EXTEND(stack_sp, items); /* @_ could have been extended. */
1801 Copy(AvARRAY(av), stack_sp, items, SV*);
1804 if (cx->cx_type == CXt_SUB &&
1805 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1806 SvREFCNT_dec(cx->blk_sub.cv);
1807 oldsave = scopestack[scopestack_ix - 1];
1808 LEAVE_SCOPE(oldsave);
1810 /* Now do some callish stuff. */
1813 if (CvOLDSTYLE(cv)) {
1814 I32 (*fp3)_((int,int,int));
1819 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1820 items = (*fp3)(CvXSUBANY(cv).any_i32,
1821 mark - stack_base + 1,
1823 SP = stack_base + items;
1829 stack_sp--; /* There is no cv arg. */
1830 /* Push a mark for the start of arglist */
1832 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1833 /* Pop the current context like a decent sub should */
1834 POPBLOCK(cx, curpm);
1835 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
1838 return pop_return();
1841 AV* padlist = CvPADLIST(cv);
1842 SV** svp = AvARRAY(padlist);
1843 if (cx->cx_type == CXt_EVAL) {
1844 in_eval = cx->blk_eval.old_in_eval;
1845 eval_root = cx->blk_eval.old_eval_root;
1846 cx->cx_type = CXt_SUB;
1847 cx->blk_sub.hasargs = 0;
1849 cx->blk_sub.cv = cv;
1850 cx->blk_sub.olddepth = CvDEPTH(cv);
1852 if (CvDEPTH(cv) < 2)
1853 (void)SvREFCNT_inc(cv);
1854 else { /* save temporaries on recursion? */
1855 if (CvDEPTH(cv) == 100 && dowarn)
1856 sub_crush_depth(cv);
1857 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1858 AV *newpad = newAV();
1859 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1860 I32 ix = AvFILLp((AV*)svp[1]);
1861 svp = AvARRAY(svp[0]);
1862 for ( ;ix > 0; ix--) {
1863 if (svp[ix] != &sv_undef) {
1864 char *name = SvPVX(svp[ix]);
1865 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1868 /* outer lexical or anon code */
1869 av_store(newpad, ix,
1870 SvREFCNT_inc(oldpad[ix]) );
1872 else { /* our own lexical */
1874 av_store(newpad, ix, sv = (SV*)newAV());
1875 else if (*name == '%')
1876 av_store(newpad, ix, sv = (SV*)newHV());
1878 av_store(newpad, ix, sv = NEWSV(0,0));
1883 av_store(newpad, ix, sv = NEWSV(0,0));
1887 if (cx->blk_sub.hasargs) {
1890 av_store(newpad, 0, (SV*)av);
1891 AvFLAGS(av) = AVf_REIFY;
1893 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1894 AvFILLp(padlist) = CvDEPTH(cv);
1895 svp = AvARRAY(padlist);
1899 if (!cx->blk_sub.hasargs) {
1900 AV* av = (AV*)curpad[0];
1902 items = AvFILLp(av) + 1;
1904 /* Mark is at the end of the stack. */
1906 Copy(AvARRAY(av), SP + 1, items, SV*);
1911 #endif /* USE_THREADS */
1913 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1915 if (cx->blk_sub.hasargs)
1916 #endif /* USE_THREADS */
1918 AV* av = (AV*)curpad[0];
1922 cx->blk_sub.savearray = GvAV(defgv);
1923 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1924 #endif /* USE_THREADS */
1925 cx->blk_sub.argarray = av;
1928 if (items >= AvMAX(av) + 1) {
1930 if (AvARRAY(av) != ary) {
1931 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1932 SvPVX(av) = (char*)ary;
1934 if (items >= AvMAX(av) + 1) {
1935 AvMAX(av) = items - 1;
1936 Renew(ary,items+1,SV*);
1938 SvPVX(av) = (char*)ary;
1941 Copy(mark,AvARRAY(av),items,SV*);
1942 AvFILLp(av) = items - 1;
1950 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1952 * We do not care about using sv to call CV;
1953 * it's for informational purposes only.
1955 SV *sv = GvSV(DBsub);
1958 if (PERLDB_SUB_NN) {
1959 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1962 gv_efullname3(sv, CvGV(cv), Nullch);
1965 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1966 PUSHMARK( stack_sp );
1967 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1971 RETURNOP(CvSTART(cv));
1975 label = SvPV(sv,na);
1977 else if (op->op_flags & OPf_SPECIAL) {
1979 DIE("goto must have label");
1982 label = cPVOP->op_pv;
1984 if (label && *label) {
1991 for (ix = cxstack_ix; ix >= 0; ix--) {
1993 switch (cx->cx_type) {
1995 gotoprobe = eval_root; /* XXX not good for nested eval */
1998 gotoprobe = cx->blk_oldcop->op_sibling;
2004 gotoprobe = cx->blk_oldcop->op_sibling;
2006 gotoprobe = main_root;
2009 if (CvDEPTH(cx->blk_sub.cv)) {
2010 gotoprobe = CvROOT(cx->blk_sub.cv);
2015 DIE("Can't \"goto\" outside a block");
2019 gotoprobe = main_root;
2022 retop = dofindlabel(gotoprobe, label,
2023 enterops, enterops + GOTO_DEPTH);
2026 lastgotoprobe = gotoprobe;
2029 DIE("Can't find label %s", label);
2031 /* pop unwanted frames */
2033 if (ix < cxstack_ix) {
2040 oldsave = scopestack[scopestack_ix];
2041 LEAVE_SCOPE(oldsave);
2044 /* push wanted frames */
2046 if (*enterops && enterops[1]) {
2048 for (ix = 1; enterops[ix]; ix++) {
2050 /* Eventually we may want to stack the needed arguments
2051 * for each op. For now, we punt on the hard ones. */
2052 if (op->op_type == OP_ENTERITER)
2053 DIE("Can't \"goto\" into the middle of a foreach loop",
2055 (CALLOP->op_ppaddr)(ARGS);
2063 if (!retop) retop = main_start;
2070 restartop = 0; /* hmm, must be GNU unexec().. */
2074 if (top_env->je_prev) {
2092 if (anum == 1 && VMSISH_EXIT)
2105 double value = SvNVx(GvSV(cCOP->cop_gv));
2106 register I32 match = I_32(value);
2109 if (((double)match) > value)
2110 --match; /* was fractional--truncate other way */
2112 match -= cCOP->uop.scop.scop_offset;
2115 else if (match > cCOP->uop.scop.scop_max)
2116 match = cCOP->uop.scop.scop_max;
2117 op = cCOP->uop.scop.scop_next[match];
2127 op = op->op_next; /* can't assume anything */
2129 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2130 match -= cCOP->uop.scop.scop_offset;
2133 else if (match > cCOP->uop.scop.scop_max)
2134 match = cCOP->uop.scop.scop_max;
2135 op = cCOP->uop.scop.scop_next[match];
2144 save_lines(AV *array, SV *sv)
2146 register char *s = SvPVX(sv);
2147 register char *send = SvPVX(sv) + SvCUR(sv);
2149 register I32 line = 1;
2151 while (s && s < send) {
2152 SV *tmpstr = NEWSV(85,0);
2154 sv_upgrade(tmpstr, SVt_PVMG);
2155 t = strchr(s, '\n');
2161 sv_setpvn(tmpstr, s, t - s);
2162 av_store(array, line++, tmpstr);
2177 assert(CATCH_GET == TRUE);
2178 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2182 default: /* topmost level handles it */
2189 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2205 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2206 /* sv Text to convert to OP tree. */
2207 /* startop op_free() this to undo. */
2208 /* code Short string id of the caller. */
2210 dSP; /* Make POPBLOCK work. */
2213 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2217 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2223 /* switch to eval mode */
2225 SAVESPTR(compiling.cop_filegv);
2226 SAVEI16(compiling.cop_line);
2227 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2228 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2229 compiling.cop_line = 1;
2230 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2231 deleting the eval's FILEGV from the stash before gv_check() runs
2232 (i.e. before run-time proper). To work around the coredump that
2233 ensues, we always turn GvMULTI_on for any globals that were
2234 introduced within evals. See force_ident(). GSAR 96-10-12 */
2235 safestr = savepv(tmpbuf);
2236 SAVEDELETE(defstash, safestr, strlen(safestr));
2238 #ifdef OP_IN_REGISTER
2246 op->op_type = 0; /* Avoid uninit warning. */
2247 op->op_flags = 0; /* Avoid uninit warning. */
2248 PUSHBLOCK(cx, CXt_EVAL, SP);
2249 PUSHEVAL(cx, 0, compiling.cop_filegv);
2250 rop = doeval(G_SCALAR, startop);
2254 (*startop)->op_type = OP_NULL;
2255 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2257 *avp = (AV*)SvREFCNT_inc(comppad);
2259 #ifdef OP_IN_REGISTER
2265 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2267 doeval(int gimme, OP** startop)
2280 /* set up a scratch pad */
2285 SAVESPTR(comppad_name);
2286 SAVEI32(comppad_name_fill);
2287 SAVEI32(min_intro_pending);
2288 SAVEI32(max_intro_pending);
2291 for (i = cxstack_ix - 1; i >= 0; i--) {
2292 PERL_CONTEXT *cx = &cxstack[i];
2293 if (cx->cx_type == CXt_EVAL)
2295 else if (cx->cx_type == CXt_SUB) {
2296 caller = cx->blk_sub.cv;
2302 compcv = (CV*)NEWSV(1104,0);
2303 sv_upgrade((SV *)compcv, SVt_PVCV);
2304 CvUNIQUE_on(compcv);
2306 CvOWNER(compcv) = 0;
2307 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2308 MUTEX_INIT(CvMUTEXP(compcv));
2309 #endif /* USE_THREADS */
2312 av_push(comppad, Nullsv);
2313 curpad = AvARRAY(comppad);
2314 comppad_name = newAV();
2315 comppad_name_fill = 0;
2316 min_intro_pending = 0;
2319 av_store(comppad_name, 0, newSVpv("@_", 2));
2320 curpad[0] = (SV*)newAV();
2321 SvPADMY_on(curpad[0]); /* XXX Needed? */
2322 #endif /* USE_THREADS */
2324 comppadlist = newAV();
2325 AvREAL_off(comppadlist);
2326 av_store(comppadlist, 0, (SV*)comppad_name);
2327 av_store(comppadlist, 1, (SV*)comppad);
2328 CvPADLIST(compcv) = comppadlist;
2330 if (!saveop || saveop->op_type != OP_REQUIRE)
2331 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2335 /* make sure we compile in the right package */
2337 newstash = curcop->cop_stash;
2338 if (curstash != newstash) {
2340 curstash = newstash;
2344 SAVEFREESV(beginav);
2346 /* try to compile it */
2350 curcop = &compiling;
2351 curcop->cop_arybase = 0;
2353 rs = newSVpv("\n", 1);
2354 if (saveop && saveop->op_flags & OPf_SPECIAL)
2358 if (yyparse() || error_count || !eval_root) {
2362 I32 optype = 0; /* Might be reset by POPEVAL. */
2369 SP = stack_base + POPMARK; /* pop original mark */
2377 if (optype == OP_REQUIRE) {
2378 char* msg = SvPVx(ERRSV, na);
2379 DIE("%s", *msg ? msg : "Compilation failed in require");
2380 } else if (startop) {
2381 char* msg = SvPVx(ERRSV, na);
2385 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2388 rs = SvREFCNT_inc(nrs);
2390 MUTEX_LOCK(&eval_mutex);
2392 COND_SIGNAL(&eval_cond);
2393 MUTEX_UNLOCK(&eval_mutex);
2394 #endif /* USE_THREADS */
2398 rs = SvREFCNT_inc(nrs);
2399 compiling.cop_line = 0;
2401 *startop = eval_root;
2402 SvREFCNT_dec(CvOUTSIDE(compcv));
2403 CvOUTSIDE(compcv) = Nullcv;
2405 SAVEFREEOP(eval_root);
2407 scalarvoid(eval_root);
2408 else if (gimme & G_ARRAY)
2413 DEBUG_x(dump_eval());
2415 /* Register with debugger: */
2416 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2417 CV *cv = perl_get_cv("DB::postponed", FALSE);
2421 XPUSHs((SV*)compiling.cop_filegv);
2423 perl_call_sv((SV*)cv, G_DISCARD);
2427 /* compiled okay, so do it */
2429 CvDEPTH(compcv) = 1;
2430 SP = stack_base + POPMARK; /* pop original mark */
2431 op = saveop; /* The caller may need it. */
2433 MUTEX_LOCK(&eval_mutex);
2435 COND_SIGNAL(&eval_cond);
2436 MUTEX_UNLOCK(&eval_mutex);
2437 #endif /* USE_THREADS */
2439 RETURNOP(eval_start);
2445 register PERL_CONTEXT *cx;
2450 SV *namesv = Nullsv;
2452 I32 gimme = G_SCALAR;
2453 PerlIO *tryrsfp = 0;
2456 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2457 SET_NUMERIC_STANDARD();
2458 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2459 DIE("Perl %s required--this is only version %s, stopped",
2460 SvPV(sv,na),patchlevel);
2463 name = SvPV(sv, len);
2464 if (!(name && len > 0 && *name))
2465 DIE("Null filename used");
2466 TAINT_PROPER("require");
2467 if (op->op_type == OP_REQUIRE &&
2468 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2472 /* prepare to compile file */
2477 (name[1] == '.' && name[2] == '/')))
2479 || (name[0] && name[1] == ':')
2482 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2485 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2486 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2491 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2494 AV *ar = GvAVn(incgv);
2498 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2501 namesv = NEWSV(806, 0);
2502 for (i = 0; i <= AvFILL(ar); i++) {
2503 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2506 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2508 sv_setpv(namesv, unixdir);
2509 sv_catpv(namesv, unixname);
2511 sv_setpvf(namesv, "%s/%s", dir, name);
2513 tryname = SvPVX(namesv);
2514 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2516 if (tryname[0] == '.' && tryname[1] == '/')
2523 SAVESPTR(compiling.cop_filegv);
2524 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2525 SvREFCNT_dec(namesv);
2527 if (op->op_type == OP_REQUIRE) {
2528 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2529 SV *dirmsgsv = NEWSV(0, 0);
2530 AV *ar = GvAVn(incgv);
2532 if (instr(SvPVX(msg), ".h "))
2533 sv_catpv(msg, " (change .h to .ph maybe?)");
2534 if (instr(SvPVX(msg), ".ph "))
2535 sv_catpv(msg, " (did you run h2ph?)");
2536 sv_catpv(msg, " (@INC contains:");
2537 for (i = 0; i <= AvFILL(ar); i++) {
2538 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2539 sv_setpvf(dirmsgsv, " %s", dir);
2540 sv_catsv(msg, dirmsgsv);
2542 sv_catpvn(msg, ")", 1);
2543 SvREFCNT_dec(dirmsgsv);
2550 /* Assume success here to prevent recursive requirement. */
2551 (void)hv_store(GvHVn(incgv), name, strlen(name),
2552 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2556 lex_start(sv_2mortal(newSVpv("",0)));
2558 save_aptr(&rsfp_filters);
2559 rsfp_filters = NULL;
2563 name = savepv(name);
2568 /* switch to eval mode */
2570 push_return(op->op_next);
2571 PUSHBLOCK(cx, CXt_EVAL, SP);
2572 PUSHEVAL(cx, name, compiling.cop_filegv);
2574 compiling.cop_line = 0;
2578 MUTEX_LOCK(&eval_mutex);
2579 if (eval_owner && eval_owner != thr)
2581 COND_WAIT(&eval_cond, &eval_mutex);
2583 MUTEX_UNLOCK(&eval_mutex);
2584 #endif /* USE_THREADS */
2585 return DOCATCH(doeval(G_SCALAR, NULL));
2590 return pp_require(ARGS);
2596 register PERL_CONTEXT *cx;
2598 I32 gimme = GIMME_V, was = sub_generation;
2599 char tmpbuf[TYPE_DIGITS(long) + 12];
2604 if (!SvPV(sv,len) || !len)
2606 TAINT_PROPER("eval");
2612 /* switch to eval mode */
2614 SAVESPTR(compiling.cop_filegv);
2615 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2616 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2617 compiling.cop_line = 1;
2618 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2619 deleting the eval's FILEGV from the stash before gv_check() runs
2620 (i.e. before run-time proper). To work around the coredump that
2621 ensues, we always turn GvMULTI_on for any globals that were
2622 introduced within evals. See force_ident(). GSAR 96-10-12 */
2623 safestr = savepv(tmpbuf);
2624 SAVEDELETE(defstash, safestr, strlen(safestr));
2626 hints = op->op_targ;
2628 push_return(op->op_next);
2629 PUSHBLOCK(cx, CXt_EVAL, SP);
2630 PUSHEVAL(cx, 0, compiling.cop_filegv);
2632 /* prepare to compile string */
2634 if (PERLDB_LINE && curstash != debstash)
2635 save_lines(GvAV(compiling.cop_filegv), linestr);
2638 MUTEX_LOCK(&eval_mutex);
2639 if (eval_owner && eval_owner != thr)
2641 COND_WAIT(&eval_cond, &eval_mutex);
2643 MUTEX_UNLOCK(&eval_mutex);
2644 #endif /* USE_THREADS */
2645 ret = doeval(gimme, NULL);
2646 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2647 && ret != op->op_next) { /* Successive compilation. */
2648 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2650 return DOCATCH(ret);
2660 register PERL_CONTEXT *cx;
2662 U8 save_flags = op -> op_flags;
2667 retop = pop_return();
2670 if (gimme == G_VOID)
2672 else if (gimme == G_SCALAR) {
2675 if (SvFLAGS(TOPs) & SVs_TEMP)
2678 *MARK = sv_mortalcopy(TOPs);
2686 /* in case LEAVE wipes old return values */
2687 for (mark = newsp + 1; mark <= SP; mark++) {
2688 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2689 *mark = sv_mortalcopy(*mark);
2690 TAINT_NOT; /* Each item is independent */
2694 curpm = newpm; /* Don't pop $1 et al till now */
2697 * Closures mentioned at top level of eval cannot be referenced
2698 * again, and their presence indirectly causes a memory leak.
2699 * (Note that the fact that compcv and friends are still set here
2700 * is, AFAIK, an accident.) --Chip
2702 if (AvFILLp(comppad_name) >= 0) {
2703 SV **svp = AvARRAY(comppad_name);
2705 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2707 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2709 svp[ix] = &sv_undef;
2713 SvREFCNT_dec(CvOUTSIDE(sv));
2714 CvOUTSIDE(sv) = Nullcv;
2727 assert(CvDEPTH(compcv) == 1);
2729 CvDEPTH(compcv) = 0;
2732 if (optype == OP_REQUIRE &&
2733 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2735 /* Unassume the success we assumed earlier. */
2736 char *name = cx->blk_eval.old_name;
2737 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2738 retop = die("%s did not return a true value", name);
2739 /* die_where() did LEAVE, or we won't be here */
2743 if (!(save_flags & OPf_SPECIAL))
2753 register PERL_CONTEXT *cx;
2754 I32 gimme = GIMME_V;
2759 push_return(cLOGOP->op_other->op_next);
2760 PUSHBLOCK(cx, CXt_EVAL, SP);
2762 eval_root = op; /* Only needed so that goto works right. */
2767 return DOCATCH(op->op_next);
2777 register PERL_CONTEXT *cx;
2785 if (gimme == G_VOID)
2787 else if (gimme == G_SCALAR) {
2790 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2793 *MARK = sv_mortalcopy(TOPs);
2802 /* in case LEAVE wipes old return values */
2803 for (mark = newsp + 1; mark <= SP; mark++) {
2804 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2805 *mark = sv_mortalcopy(*mark);
2806 TAINT_NOT; /* Each item is independent */
2810 curpm = newpm; /* Don't pop $1 et al till now */
2821 register char *s = SvPV_force(sv, len);
2822 register char *send = s + len;
2823 register char *base;
2824 register I32 skipspaces = 0;
2827 bool postspace = FALSE;
2835 croak("Null picture in formline");
2837 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2842 *fpc++ = FF_LINEMARK;
2843 noblank = repeat = FALSE;
2861 case ' ': case '\t':
2872 *fpc++ = FF_LITERAL;
2880 *fpc++ = skipspaces;
2884 *fpc++ = FF_NEWLINE;
2888 arg = fpc - linepc + 1;
2895 *fpc++ = FF_LINEMARK;
2896 noblank = repeat = FALSE;
2905 ischop = s[-1] == '^';
2911 arg = (s - base) - 1;
2913 *fpc++ = FF_LITERAL;
2922 *fpc++ = FF_LINEGLOB;
2924 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2925 arg = ischop ? 512 : 0;
2935 arg |= 256 + (s - f);
2937 *fpc++ = s - base; /* fieldsize for FETCH */
2938 *fpc++ = FF_DECIMAL;
2943 bool ismore = FALSE;
2946 while (*++s == '>') ;
2947 prespace = FF_SPACE;
2949 else if (*s == '|') {
2950 while (*++s == '|') ;
2951 prespace = FF_HALFSPACE;
2956 while (*++s == '<') ;
2959 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2963 *fpc++ = s - base; /* fieldsize for FETCH */
2965 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2983 { /* need to jump to the next word */
2985 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2986 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2987 s = SvPVX(sv) + SvCUR(sv) + z;
2989 Copy(fops, s, arg, U16);
2991 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2996 * The rest of this file was derived from source code contributed
2999 * NOTE: this code was derived from Tom Horsley's qsort replacement
3000 * and should not be confused with the original code.
3003 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
3005 Permission granted to distribute under the same terms as perl which are
3008 This program is free software; you can redistribute it and/or modify
3009 it under the terms of either:
3011 a) the GNU General Public License as published by the Free
3012 Software Foundation; either version 1, or (at your option) any
3015 b) the "Artistic License" which comes with this Kit.
3017 Details on the perl license can be found in the perl source code which
3018 may be located via the www.perl.com web page.
3020 This is the most wonderfulest possible qsort I can come up with (and
3021 still be mostly portable) My (limited) tests indicate it consistently
3022 does about 20% fewer calls to compare than does the qsort in the Visual
3023 C++ library, other vendors may vary.
3025 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3026 others I invented myself (or more likely re-invented since they seemed
3027 pretty obvious once I watched the algorithm operate for a while).
3029 Most of this code was written while watching the Marlins sweep the Giants
3030 in the 1997 National League Playoffs - no Braves fans allowed to use this
3031 code (just kidding :-).
3033 I realize that if I wanted to be true to the perl tradition, the only
3034 comment in this file would be something like:
3036 ...they shuffled back towards the rear of the line. 'No, not at the
3037 rear!' the slave-driver shouted. 'Three files up. And stay there...
3039 However, I really needed to violate that tradition just so I could keep
3040 track of what happens myself, not to mention some poor fool trying to
3041 understand this years from now :-).
3044 /* ********************************************************** Configuration */
3046 #ifndef QSORT_ORDER_GUESS
3047 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3050 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3051 future processing - a good max upper bound is log base 2 of memory size
3052 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3053 safely be smaller than that since the program is taking up some space and
3054 most operating systems only let you grab some subset of contiguous
3055 memory (not to mention that you are normally sorting data larger than
3056 1 byte element size :-).
3058 #ifndef QSORT_MAX_STACK
3059 #define QSORT_MAX_STACK 32
3062 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3063 Anything bigger and we use qsort. If you make this too small, the qsort
3064 will probably break (or become less efficient), because it doesn't expect
3065 the middle element of a partition to be the same as the right or left -
3066 you have been warned).
3068 #ifndef QSORT_BREAK_EVEN
3069 #define QSORT_BREAK_EVEN 6
3072 /* ************************************************************* Data Types */
3074 /* hold left and right index values of a partition waiting to be sorted (the
3075 partition includes both left and right - right is NOT one past the end or
3076 anything like that).
3078 struct partition_stack_entry {
3081 #ifdef QSORT_ORDER_GUESS
3082 int qsort_break_even;
3086 /* ******************************************************* Shorthand Macros */
3088 /* Note that these macros will be used from inside the qsort function where
3089 we happen to know that the variable 'elt_size' contains the size of an
3090 array element and the variable 'temp' points to enough space to hold a
3091 temp element and the variable 'array' points to the array being sorted
3092 and 'compare' is the pointer to the compare routine.
3094 Also note that there are very many highly architecture specific ways
3095 these might be sped up, but this is simply the most generally portable
3096 code I could think of.
3099 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3102 #define qsort_cmp(elt1, elt2) \
3103 ((this->*compare)(array[elt1], array[elt2]))
3105 #define qsort_cmp(elt1, elt2) \
3106 ((*compare)(array[elt1], array[elt2]))
3109 #ifdef QSORT_ORDER_GUESS
3110 #define QSORT_NOTICE_SWAP swapped++;
3112 #define QSORT_NOTICE_SWAP
3115 /* swaps contents of array elements elt1, elt2.
3117 #define qsort_swap(elt1, elt2) \
3120 temp = array[elt1]; \
3121 array[elt1] = array[elt2]; \
3122 array[elt2] = temp; \
3125 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3126 elt3 and elt3 gets elt1.
3128 #define qsort_rotate(elt1, elt2, elt3) \
3131 temp = array[elt1]; \
3132 array[elt1] = array[elt2]; \
3133 array[elt2] = array[elt3]; \
3134 array[elt3] = temp; \
3137 /* ************************************************************ Debug stuff */
3144 return; /* good place to set a breakpoint */
3147 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3150 doqsort_all_asserts(
3154 int (*compare)(const void * elt1, const void * elt2),
3155 int pc_left, int pc_right, int u_left, int u_right)
3159 qsort_assert(pc_left <= pc_right);
3160 qsort_assert(u_right < pc_left);
3161 qsort_assert(pc_right < u_left);
3162 for (i = u_right + 1; i < pc_left; ++i) {
3163 qsort_assert(qsort_cmp(i, pc_left) < 0);
3165 for (i = pc_left; i < pc_right; ++i) {
3166 qsort_assert(qsort_cmp(i, pc_right) == 0);
3168 for (i = pc_right + 1; i < u_left; ++i) {
3169 qsort_assert(qsort_cmp(pc_right, i) < 0);
3173 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3174 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3175 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3179 #define qsort_assert(t) ((void)0)
3181 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3185 /* ****************************************************************** qsort */
3189 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3194 I32 (*compare)(SV *a, SV *b))
3199 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3200 int next_stack_entry = 0;
3204 #ifdef QSORT_ORDER_GUESS
3205 int qsort_break_even;
3209 /* Make sure we actually have work to do.
3211 if (num_elts <= 1) {
3215 /* Setup the initial partition definition and fall into the sorting loop
3218 part_right = (int)(num_elts - 1);
3219 #ifdef QSORT_ORDER_GUESS
3220 qsort_break_even = QSORT_BREAK_EVEN;
3222 #define qsort_break_even QSORT_BREAK_EVEN
3225 if ((part_right - part_left) >= qsort_break_even) {
3226 /* OK, this is gonna get hairy, so lets try to document all the
3227 concepts and abbreviations and variables and what they keep
3230 pc: pivot chunk - the set of array elements we accumulate in the
3231 middle of the partition, all equal in value to the original
3232 pivot element selected. The pc is defined by:
3234 pc_left - the leftmost array index of the pc
3235 pc_right - the rightmost array index of the pc
3237 we start with pc_left == pc_right and only one element
3238 in the pivot chunk (but it can grow during the scan).
3240 u: uncompared elements - the set of elements in the partition
3241 we have not yet compared to the pivot value. There are two
3242 uncompared sets during the scan - one to the left of the pc
3243 and one to the right.
3245 u_right - the rightmost index of the left side's uncompared set
3246 u_left - the leftmost index of the right side's uncompared set
3248 The leftmost index of the left sides's uncompared set
3249 doesn't need its own variable because it is always defined
3250 by the leftmost edge of the whole partition (part_left). The
3251 same goes for the rightmost edge of the right partition
3254 We know there are no uncompared elements on the left once we
3255 get u_right < part_left and no uncompared elements on the
3256 right once u_left > part_right. When both these conditions
3257 are met, we have completed the scan of the partition.
3259 Any elements which are between the pivot chunk and the
3260 uncompared elements should be less than the pivot value on
3261 the left side and greater than the pivot value on the right
3262 side (in fact, the goal of the whole algorithm is to arrange
3263 for that to be true and make the groups of less-than and
3264 greater-then elements into new partitions to sort again).
3266 As you marvel at the complexity of the code and wonder why it
3267 has to be so confusing. Consider some of the things this level
3268 of confusion brings:
3270 Once I do a compare, I squeeze every ounce of juice out of it. I
3271 never do compare calls I don't have to do, and I certainly never
3274 I also never swap any elements unless I can prove there is a
3275 good reason. Many sort algorithms will swap a known value with
3276 an uncompared value just to get things in the right place (or
3277 avoid complexity :-), but that uncompared value, once it gets
3278 compared, may then have to be swapped again. A lot of the
3279 complexity of this code is due to the fact that it never swaps
3280 anything except compared values, and it only swaps them when the
3281 compare shows they are out of position.
3283 int pc_left, pc_right;
3284 int u_right, u_left;
3288 pc_left = ((part_left + part_right) / 2);
3290 u_right = pc_left - 1;
3291 u_left = pc_right + 1;
3293 /* Qsort works best when the pivot value is also the median value
3294 in the partition (unfortunately you can't find the median value
3295 without first sorting :-), so to give the algorithm a helping
3296 hand, we pick 3 elements and sort them and use the median value
3297 of that tiny set as the pivot value.
3299 Some versions of qsort like to use the left middle and right as
3300 the 3 elements to sort so they can insure the ends of the
3301 partition will contain values which will stop the scan in the
3302 compare loop, but when you have to call an arbitrarily complex
3303 routine to do a compare, its really better to just keep track of
3304 array index values to know when you hit the edge of the
3305 partition and avoid the extra compare. An even better reason to
3306 avoid using a compare call is the fact that you can drop off the
3307 edge of the array if someone foolishly provides you with an
3308 unstable compare function that doesn't always provide consistent
3311 So, since it is simpler for us to compare the three adjacent
3312 elements in the middle of the partition, those are the ones we
3313 pick here (conveniently pointed at by u_right, pc_left, and
3314 u_left). The values of the left, center, and right elements
3315 are refered to as l c and r in the following comments.
3318 #ifdef QSORT_ORDER_GUESS
3321 s = qsort_cmp(u_right, pc_left);
3324 s = qsort_cmp(pc_left, u_left);
3325 /* if l < c, c < r - already in order - nothing to do */
3327 /* l < c, c == r - already in order, pc grows */
3329 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3331 /* l < c, c > r - need to know more */
3332 s = qsort_cmp(u_right, u_left);
3334 /* l < c, c > r, l < r - swap c & r to get ordered */
3335 qsort_swap(pc_left, u_left);
3336 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3337 } else if (s == 0) {
3338 /* l < c, c > r, l == r - swap c&r, grow pc */
3339 qsort_swap(pc_left, u_left);
3341 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3343 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3344 qsort_rotate(pc_left, u_right, u_left);
3345 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3348 } else if (s == 0) {
3350 s = qsort_cmp(pc_left, u_left);
3352 /* l == c, c < r - already in order, grow pc */
3354 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3355 } else if (s == 0) {
3356 /* l == c, c == r - already in order, grow pc both ways */
3359 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3361 /* l == c, c > r - swap l & r, grow pc */
3362 qsort_swap(u_right, u_left);
3364 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3368 s = qsort_cmp(pc_left, u_left);
3370 /* l > c, c < r - need to know more */
3371 s = qsort_cmp(u_right, u_left);
3373 /* l > c, c < r, l < r - swap l & c to get ordered */
3374 qsort_swap(u_right, pc_left);
3375 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3376 } else if (s == 0) {
3377 /* l > c, c < r, l == r - swap l & c, grow pc */
3378 qsort_swap(u_right, pc_left);
3380 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3382 /* l > c, c < r, l > r - rotate lcr into crl to order */
3383 qsort_rotate(u_right, pc_left, u_left);
3384 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3386 } else if (s == 0) {
3387 /* l > c, c == r - swap ends, grow pc */
3388 qsort_swap(u_right, u_left);
3390 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3392 /* l > c, c > r - swap ends to get in order */
3393 qsort_swap(u_right, u_left);
3394 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3397 /* We now know the 3 middle elements have been compared and
3398 arranged in the desired order, so we can shrink the uncompared
3403 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3405 /* The above massive nested if was the simple part :-). We now have
3406 the middle 3 elements ordered and we need to scan through the
3407 uncompared sets on either side, swapping elements that are on
3408 the wrong side or simply shuffling equal elements around to get
3409 all equal elements into the pivot chunk.
3413 int still_work_on_left;
3414 int still_work_on_right;
3416 /* Scan the uncompared values on the left. If I find a value
3417 equal to the pivot value, move it over so it is adjacent to
3418 the pivot chunk and expand the pivot chunk. If I find a value
3419 less than the pivot value, then just leave it - its already
3420 on the correct side of the partition. If I find a greater
3421 value, then stop the scan.
3423 while (still_work_on_left = (u_right >= part_left)) {
3424 s = qsort_cmp(u_right, pc_left);
3427 } else if (s == 0) {
3429 if (pc_left != u_right) {
3430 qsort_swap(u_right, pc_left);
3436 qsort_assert(u_right < pc_left);
3437 qsort_assert(pc_left <= pc_right);
3438 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3439 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3442 /* Do a mirror image scan of uncompared values on the right
3444 while (still_work_on_right = (u_left <= part_right)) {
3445 s = qsort_cmp(pc_right, u_left);
3448 } else if (s == 0) {
3450 if (pc_right != u_left) {
3451 qsort_swap(pc_right, u_left);
3457 qsort_assert(u_left > pc_right);
3458 qsort_assert(pc_left <= pc_right);
3459 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3460 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3463 if (still_work_on_left) {
3464 /* I know I have a value on the left side which needs to be
3465 on the right side, but I need to know more to decide
3466 exactly the best thing to do with it.
3468 if (still_work_on_right) {
3469 /* I know I have values on both side which are out of
3470 position. This is a big win because I kill two birds
3471 with one swap (so to speak). I can advance the
3472 uncompared pointers on both sides after swapping both
3473 of them into the right place.
3475 qsort_swap(u_right, u_left);
3478 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3480 /* I have an out of position value on the left, but the
3481 right is fully scanned, so I "slide" the pivot chunk
3482 and any less-than values left one to make room for the
3483 greater value over on the right. If the out of position
3484 value is immediately adjacent to the pivot chunk (there
3485 are no less-than values), I can do that with a swap,
3486 otherwise, I have to rotate one of the less than values
3487 into the former position of the out of position value
3488 and the right end of the pivot chunk into the left end
3492 if (pc_left == u_right) {
3493 qsort_swap(u_right, pc_right);
3494 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3496 qsort_rotate(u_right, pc_left, pc_right);
3497 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3502 } else if (still_work_on_right) {
3503 /* Mirror image of complex case above: I have an out of
3504 position value on the right, but the left is fully
3505 scanned, so I need to shuffle things around to make room
3506 for the right value on the left.
3509 if (pc_right == u_left) {
3510 qsort_swap(u_left, pc_left);
3511 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3513 qsort_rotate(pc_right, pc_left, u_left);
3514 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3519 /* No more scanning required on either side of partition,
3520 break out of loop and figure out next set of partitions
3526 /* The elements in the pivot chunk are now in the right place. They
3527 will never move or be compared again. All I have to do is decide
3528 what to do with the stuff to the left and right of the pivot
3531 Notes on the QSORT_ORDER_GUESS ifdef code:
3533 1. If I just built these partitions without swapping any (or
3534 very many) elements, there is a chance that the elements are
3535 already ordered properly (being properly ordered will
3536 certainly result in no swapping, but the converse can't be
3539 2. A (properly written) insertion sort will run faster on
3540 already ordered data than qsort will.
3542 3. Perhaps there is some way to make a good guess about
3543 switching to an insertion sort earlier than partition size 6
3544 (for instance - we could save the partition size on the stack
3545 and increase the size each time we find we didn't swap, thus
3546 switching to insertion sort earlier for partitions with a
3547 history of not swapping).
3549 4. Naturally, if I just switch right away, it will make
3550 artificial benchmarks with pure ascending (or descending)
3551 data look really good, but is that a good reason in general?
3555 #ifdef QSORT_ORDER_GUESS
3557 #if QSORT_ORDER_GUESS == 1
3558 qsort_break_even = (part_right - part_left) + 1;
3560 #if QSORT_ORDER_GUESS == 2
3561 qsort_break_even *= 2;
3563 #if QSORT_ORDER_GUESS == 3
3564 int prev_break = qsort_break_even;
3565 qsort_break_even *= qsort_break_even;
3566 if (qsort_break_even < prev_break) {
3567 qsort_break_even = (part_right - part_left) + 1;
3571 qsort_break_even = QSORT_BREAK_EVEN;
3575 if (part_left < pc_left) {
3576 /* There are elements on the left which need more processing.
3577 Check the right as well before deciding what to do.
3579 if (pc_right < part_right) {
3580 /* We have two partitions to be sorted. Stack the biggest one
3581 and process the smallest one on the next iteration. This
3582 minimizes the stack height by insuring that any additional
3583 stack entries must come from the smallest partition which
3584 (because it is smallest) will have the fewest
3585 opportunities to generate additional stack entries.
3587 if ((part_right - pc_right) > (pc_left - part_left)) {
3588 /* stack the right partition, process the left */
3589 partition_stack[next_stack_entry].left = pc_right + 1;
3590 partition_stack[next_stack_entry].right = part_right;
3591 #ifdef QSORT_ORDER_GUESS
3592 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3594 part_right = pc_left - 1;
3596 /* stack the left partition, process the right */
3597 partition_stack[next_stack_entry].left = part_left;
3598 partition_stack[next_stack_entry].right = pc_left - 1;
3599 #ifdef QSORT_ORDER_GUESS
3600 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3602 part_left = pc_right + 1;
3604 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3607 /* The elements on the left are the only remaining elements
3608 that need sorting, arrange for them to be processed as the
3611 part_right = pc_left - 1;
3613 } else if (pc_right < part_right) {
3614 /* There is only one chunk on the right to be sorted, make it
3615 the new partition and loop back around.
3617 part_left = pc_right + 1;
3619 /* This whole partition wound up in the pivot chunk, so
3620 we need to get a new partition off the stack.
3622 if (next_stack_entry == 0) {
3623 /* the stack is empty - we are done */
3627 part_left = partition_stack[next_stack_entry].left;
3628 part_right = partition_stack[next_stack_entry].right;
3629 #ifdef QSORT_ORDER_GUESS
3630 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3634 /* This partition is too small to fool with qsort complexity, just
3635 do an ordinary insertion sort to minimize overhead.
3638 /* Assume 1st element is in right place already, and start checking
3639 at 2nd element to see where it should be inserted.
3641 for (i = part_left + 1; i <= part_right; ++i) {
3643 /* Scan (backwards - just in case 'i' is already in right place)
3644 through the elements already sorted to see if the ith element
3645 belongs ahead of one of them.
3647 for (j = i - 1; j >= part_left; --j) {
3648 if (qsort_cmp(i, j) >= 0) {
3649 /* i belongs right after j
3656 /* Looks like we really need to move some things
3660 for (k = i - 1; k >= j; --k)
3661 array[k + 1] = array[k];
3666 /* That partition is now sorted, grab the next one, or get out
3667 of the loop if there aren't any more.
3670 if (next_stack_entry == 0) {
3671 /* the stack is empty - we are done */
3675 part_left = partition_stack[next_stack_entry].left;
3676 part_right = partition_stack[next_stack_entry].right;
3677 #ifdef QSORT_ORDER_GUESS
3678 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3683 /* Believe it or not, the array is sorted at this point! */