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) {
72 register PMOP *pm = (PMOP*)cLOGOP->op_other;
76 MAGIC *mg = Null(MAGIC*);
79 if(SvROK(tmpstr) || SvRMAGICAL(tmpstr)) {
80 SV *sv = SvROK(tmpstr) ? SvRV(tmpstr) : tmpstr;
82 mg = mg_find(sv, 'r');
85 regexp *re = (regexp *)mg->mg_obj;
86 ReREFCNT_dec(pm->op_pmregexp);
87 pm->op_pmregexp = ReREFCNT_inc(re);
90 t = SvPV(tmpstr, len);
92 /* Check against the last compiled regexp. */
93 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
94 pm->op_pmregexp->prelen != len ||
95 memNE(pm->op_pmregexp->precomp, t, len))
97 if (pm->op_pmregexp) {
98 ReREFCNT_dec(pm->op_pmregexp);
99 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
102 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
103 pm->op_pmregexp = pregcomp(t, t + len, pm);
104 sv_magic(tmpstr,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
108 if (!pm->op_pmregexp->prelen && curpm)
110 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
111 pm->op_pmflags |= PMf_WHITE;
113 if (pm->op_pmflags & PMf_KEEP) {
114 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
115 cLOGOP->op_first->op_next = op->op_next;
123 register PMOP *pm = (PMOP*) cLOGOP->op_other;
124 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
125 register SV *dstr = cx->sb_dstr;
126 register char *s = cx->sb_s;
127 register char *m = cx->sb_m;
128 char *orig = cx->sb_orig;
129 register REGEXP *rx = cx->sb_rx;
131 rxres_restore(&cx->sb_rxres, rx);
133 if (cx->sb_iters++) {
134 if (cx->sb_iters > cx->sb_maxiters)
135 DIE("Substitution loop");
137 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
138 cx->sb_rxtainted |= 2;
139 sv_catsv(dstr, POPs);
142 if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
143 s == m, Nullsv, NULL,
144 cx->sb_safebase ? 0 : REXEC_COPY_STR))
146 SV *targ = cx->sb_targ;
147 sv_catpvn(dstr, s, cx->sb_strend - s);
149 TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
150 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
152 (void)SvOOK_off(targ);
153 Safefree(SvPVX(targ));
154 SvPVX(targ) = SvPVX(dstr);
155 SvCUR_set(targ, SvCUR(dstr));
156 SvLEN_set(targ, SvLEN(dstr));
160 TAINT_IF(cx->sb_rxtainted & 1);
161 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
163 (void)SvPOK_only(targ);
164 TAINT_IF(cx->sb_rxtainted);
168 LEAVE_SCOPE(cx->sb_oldsave);
170 RETURNOP(pm->op_next);
173 if (rx->subbase && rx->subbase != orig) {
176 cx->sb_orig = orig = rx->subbase;
178 cx->sb_strend = s + (cx->sb_strend - m);
180 cx->sb_m = m = rx->startp[0];
181 sv_catpvn(dstr, s, m-s);
182 cx->sb_s = rx->endp[0];
183 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
184 rxres_save(&cx->sb_rxres, rx);
185 RETURNOP(pm->op_pmreplstart);
189 rxres_save(void **rsp, REGEXP *rx)
194 if (!p || p[1] < rx->nparens) {
195 i = 6 + rx->nparens * 2;
203 *p++ = (UV)rx->subbase;
204 rx->subbase = Nullch;
208 *p++ = (UV)rx->subbeg;
209 *p++ = (UV)rx->subend;
210 for (i = 0; i <= rx->nparens; ++i) {
211 *p++ = (UV)rx->startp[i];
212 *p++ = (UV)rx->endp[i];
217 rxres_restore(void **rsp, REGEXP *rx)
222 Safefree(rx->subbase);
223 rx->subbase = (char*)(*p);
228 rx->subbeg = (char*)(*p++);
229 rx->subend = (char*)(*p++);
230 for (i = 0; i <= rx->nparens; ++i) {
231 rx->startp[i] = (char*)(*p++);
232 rx->endp[i] = (char*)(*p++);
237 rxres_free(void **rsp)
242 Safefree((char*)(*p));
250 djSP; dMARK; dORIGMARK;
251 register SV *tmpForm = *++MARK;
263 bool chopspace = (strchr(chopset, ' ') != Nullch);
270 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
271 SvREADONLY_off(tmpForm);
272 doparseform(tmpForm);
275 SvPV_force(formtarget, len);
276 t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */
278 f = SvPV(tmpForm, len);
279 /* need to jump to the next word */
280 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
289 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
290 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
291 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
292 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
293 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
295 case FF_CHECKNL: name = "CHECKNL"; break;
296 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
297 case FF_SPACE: name = "SPACE"; break;
298 case FF_HALFSPACE: name = "HALFSPACE"; break;
299 case FF_ITEM: name = "ITEM"; break;
300 case FF_CHOP: name = "CHOP"; break;
301 case FF_LINEGLOB: name = "LINEGLOB"; break;
302 case FF_NEWLINE: name = "NEWLINE"; break;
303 case FF_MORE: name = "MORE"; break;
304 case FF_LINEMARK: name = "LINEMARK"; break;
305 case FF_END: name = "END"; break;
308 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
310 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
339 warn("Not enough format arguments");
344 item = s = SvPV(sv, len);
346 if (itemsize > fieldsize)
347 itemsize = fieldsize;
348 send = chophere = s + itemsize;
360 item = s = SvPV(sv, len);
362 if (itemsize <= fieldsize) {
363 send = chophere = s + itemsize;
374 itemsize = fieldsize;
375 send = chophere = s + itemsize;
376 while (s < send || (s == send && isSPACE(*s))) {
386 if (strchr(chopset, *s))
391 itemsize = chophere - item;
396 arg = fieldsize - itemsize;
405 arg = fieldsize - itemsize;
419 int ch = *t++ = *s++;
423 if ( !((*t++ = *s++) & ~31) )
433 while (*s && isSPACE(*s))
440 item = s = SvPV(sv, len);
453 SvCUR_set(formtarget, t - SvPVX(formtarget));
454 sv_catpvn(formtarget, item, itemsize);
455 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1);
456 t = SvPVX(formtarget) + SvCUR(formtarget);
461 /* If the field is marked with ^ and the value is undefined,
464 if ((arg & 512) && !SvOK(sv)) {
472 /* Formats aren't yet marked for locales, so assume "yes". */
475 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
477 sprintf(t, "%*.0f", (int) fieldsize, value);
484 while (t-- > linemark && *t == ' ') ;
492 if (arg) { /* repeat until fields exhausted? */
494 SvCUR_set(formtarget, t - SvPVX(formtarget));
495 lines += FmLINES(formtarget);
498 if (strnEQ(linemark, linemark - arg, arg))
499 DIE("Runaway format");
501 FmLINES(formtarget) = lines;
503 RETURNOP(cLISTOP->op_first);
514 arg = fieldsize - itemsize;
521 if (strnEQ(s," ",3)) {
522 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
533 SvCUR_set(formtarget, t - SvPVX(formtarget));
534 FmLINES(formtarget) += lines;
546 if (stack_base + *markstack_ptr == SP) {
548 if (GIMME_V == G_SCALAR)
550 RETURNOP(op->op_next->op_next);
552 stack_sp = stack_base + *markstack_ptr + 1;
553 pp_pushmark(ARGS); /* push dst */
554 pp_pushmark(ARGS); /* push src */
555 ENTER; /* enter outer scope */
559 /* SAVE_DEFSV does *not* suffice here */
560 save_sptr(&THREADSV(0));
562 SAVESPTR(GvSV(defgv));
563 #endif /* USE_THREADS */
564 ENTER; /* enter inner scope */
567 src = stack_base[*markstack_ptr];
572 if (op->op_type == OP_MAPSTART)
573 pp_pushmark(ARGS); /* push top */
574 return ((LOGOP*)op->op_next)->op_other;
579 DIE("panic: mapstart"); /* uses grepstart */
585 I32 diff = (SP - stack_base) - *markstack_ptr;
593 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
594 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
595 count = (SP - stack_base) - markstack_ptr[-1] + 2;
600 markstack_ptr[-1] += shift;
601 *markstack_ptr += shift;
605 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
608 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
610 LEAVE; /* exit inner scope */
613 if (markstack_ptr[-1] > *markstack_ptr) {
617 (void)POPMARK; /* pop top */
618 LEAVE; /* exit outer scope */
619 (void)POPMARK; /* pop src */
620 items = --*markstack_ptr - markstack_ptr[-1];
621 (void)POPMARK; /* pop dst */
622 SP = stack_base + POPMARK; /* pop original mark */
623 if (gimme == G_SCALAR) {
627 else if (gimme == G_ARRAY)
634 ENTER; /* enter inner scope */
637 src = stack_base[markstack_ptr[-1]];
641 RETURNOP(cLOGOP->op_other);
647 djSP; dMARK; dORIGMARK;
649 SV **myorigmark = ORIGMARK;
655 OP* nextop = op->op_next;
657 if (gimme != G_ARRAY) {
664 if (op->op_flags & OPf_STACKED) {
665 if (op->op_flags & OPf_SPECIAL) {
666 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
667 kid = kUNOP->op_first; /* pass rv2gv */
668 kid = kUNOP->op_first; /* pass leave */
669 sortcop = kid->op_next;
670 stash = curcop->cop_stash;
673 cv = sv_2cv(*++MARK, &stash, &gv, 0);
674 if (!(cv && CvROOT(cv))) {
676 SV *tmpstr = sv_newmortal();
677 gv_efullname3(tmpstr, gv, Nullch);
678 if (cv && CvXSUB(cv))
679 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
680 DIE("Undefined sort subroutine \"%s\" called",
685 DIE("Xsub called in sort");
686 DIE("Undefined subroutine in sort");
688 DIE("Not a CODE reference in sort");
690 sortcop = CvSTART(cv);
691 SAVESPTR(CvROOT(cv)->op_ppaddr);
692 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
695 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
700 stash = curcop->cop_stash;
704 while (MARK < SP) { /* This may or may not shift down one here. */
706 if (*up = *++MARK) { /* Weed out nulls. */
708 if (!sortcop && !SvPOK(*up))
709 (void)sv_2pv(*up, &na);
713 max = --up - myorigmark;
718 bool oldcatch = CATCH_GET;
725 if (sortstash != stash) {
726 firstgv = gv_fetchpv("a", TRUE, SVt_PV);
727 secondgv = gv_fetchpv("b", TRUE, SVt_PV);
731 SAVESPTR(GvSV(firstgv));
732 SAVESPTR(GvSV(secondgv));
734 PUSHBLOCK(cx, CXt_NULL, stack_base);
735 if (!(op->op_flags & OPf_SPECIAL)) {
736 bool hasargs = FALSE;
737 cx->cx_type = CXt_SUB;
738 cx->blk_gimme = G_SCALAR;
741 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
743 sortcxix = cxstack_ix;
744 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
753 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
754 qsortsv(ORIGMARK+1, max,
755 (op->op_private & OPpLOCALE)
756 ? FUNC_NAME_TO_PTR(sv_cmp_locale)
757 : FUNC_NAME_TO_PTR(sv_cmp));
761 stack_sp = ORIGMARK + max;
769 if (GIMME == G_ARRAY)
770 return cCONDOP->op_true;
771 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
778 if (GIMME == G_ARRAY) {
779 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
783 SV *targ = PAD_SV(op->op_targ);
785 if ((op->op_private & OPpFLIP_LINENUM)
786 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
788 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
789 if (op->op_flags & OPf_SPECIAL) {
797 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
810 if (GIMME == G_ARRAY) {
816 if (SvNIOKp(left) || !SvPOKp(left) ||
817 (looks_like_number(left) && *SvPVX(left) != '0') )
822 EXTEND_MORTAL(max - i + 1);
823 EXTEND(SP, max - i + 1);
826 sv = sv_2mortal(newSViv(i++));
831 SV *final = sv_mortalcopy(right);
833 char *tmps = SvPV(final, len);
835 sv = sv_mortalcopy(left);
836 while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
837 strNE(SvPVX(sv),tmps) ) {
839 sv = sv_2mortal(newSVsv(sv));
842 if (strEQ(SvPVX(sv),tmps))
848 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
850 if ((op->op_private & OPpFLIP_LINENUM)
851 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
853 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
854 sv_catpv(targ, "E0");
865 dopoptolabel(char *label)
869 register PERL_CONTEXT *cx;
871 for (i = cxstack_ix; i >= 0; i--) {
873 switch (cx->cx_type) {
876 warn("Exiting substitution via %s", op_name[op->op_type]);
880 warn("Exiting subroutine via %s", op_name[op->op_type]);
884 warn("Exiting eval via %s", op_name[op->op_type]);
888 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
891 if (!cx->blk_loop.label ||
892 strNE(label, cx->blk_loop.label) ) {
893 DEBUG_l(deb("(Skipping label #%ld %s)\n",
894 (long)i, cx->blk_loop.label));
897 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
907 I32 gimme = block_gimme();
908 return (gimme == G_VOID) ? G_SCALAR : gimme;
917 cxix = dopoptosub(cxstack_ix);
921 switch (cxstack[cxix].blk_gimme) {
929 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
936 dopoptosub(I32 startingblock)
940 register PERL_CONTEXT *cx;
941 for (i = startingblock; i >= 0; i--) {
943 switch (cx->cx_type) {
948 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
956 dopoptoeval(I32 startingblock)
960 register PERL_CONTEXT *cx;
961 for (i = startingblock; i >= 0; i--) {
963 switch (cx->cx_type) {
967 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
975 dopoptoloop(I32 startingblock)
979 register PERL_CONTEXT *cx;
980 for (i = startingblock; i >= 0; i--) {
982 switch (cx->cx_type) {
985 warn("Exiting substitution via %s", op_name[op->op_type]);
989 warn("Exiting subroutine via %s", op_name[op->op_type]);
993 warn("Exiting eval via %s", op_name[op->op_type]);
997 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
1000 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1011 register PERL_CONTEXT *cx;
1015 while (cxstack_ix > cxix) {
1016 cx = &cxstack[cxstack_ix];
1017 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1018 (long) cxstack_ix, block_type[cx->cx_type]));
1019 /* Note: we don't need to restore the base context info till the end. */
1020 switch (cx->cx_type) {
1023 continue; /* not break */
1041 die_where(char *message)
1046 register PERL_CONTEXT *cx;
1053 STRLEN klen = strlen(message);
1055 svp = hv_fetch(ERRHV, message, klen, TRUE);
1058 static char prefix[] = "\t(in cleanup) ";
1060 sv_upgrade(*svp, SVt_IV);
1061 (void)SvIOK_only(*svp);
1064 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1065 sv_catpvn(err, prefix, sizeof(prefix)-1);
1066 sv_catpvn(err, message, klen);
1072 sv_setpv(ERRSV, message);
1075 message = SvPVx(ERRSV, na);
1077 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
1085 if (cxix < cxstack_ix)
1089 if (cx->cx_type != CXt_EVAL) {
1090 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1095 if (gimme == G_SCALAR)
1096 *++newsp = &sv_undef;
1101 if (optype == OP_REQUIRE) {
1102 char* msg = SvPVx(ERRSV, na);
1103 DIE("%s", *msg ? msg : "Compilation failed in require");
1105 return pop_return();
1108 PerlIO_printf(PerlIO_stderr(), "%s",message);
1109 PerlIO_flush(PerlIO_stderr());
1118 if (SvTRUE(left) != SvTRUE(right))
1130 RETURNOP(cLOGOP->op_other);
1139 RETURNOP(cLOGOP->op_other);
1145 register I32 cxix = dopoptosub(cxstack_ix);
1146 register PERL_CONTEXT *cx;
1158 if (GIMME != G_ARRAY)
1162 if (DBsub && cxix >= 0 &&
1163 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1167 cxix = dopoptosub(cxix - 1);
1169 cx = &cxstack[cxix];
1170 if (cxstack[cxix].cx_type == CXt_SUB) {
1171 dbcxix = dopoptosub(cxix - 1);
1172 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1173 field below is defined for any cx. */
1174 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1175 cx = &cxstack[dbcxix];
1178 if (GIMME != G_ARRAY) {
1179 hv = cx->blk_oldcop->cop_stash;
1184 sv_setpv(TARG, HvNAME(hv));
1190 hv = cx->blk_oldcop->cop_stash;
1194 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1195 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1196 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1199 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1201 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1202 PUSHs(sv_2mortal(sv));
1203 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1206 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1207 PUSHs(sv_2mortal(newSViv(0)));
1209 gimme = (I32)cx->blk_gimme;
1210 if (gimme == G_VOID)
1213 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1214 if (cx->cx_type == CXt_EVAL) {
1215 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1216 PUSHs(cx->blk_eval.cur_text);
1219 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1220 /* Require, put the name. */
1221 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1225 else if (cx->cx_type == CXt_SUB &&
1226 cx->blk_sub.hasargs &&
1227 curcop->cop_stash == debstash)
1229 AV *ary = cx->blk_sub.argarray;
1230 int off = AvARRAY(ary) - AvALLOC(ary);
1234 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1237 AvREAL_off(dbargs); /* XXX Should be REIFY */
1240 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1241 av_extend(dbargs, AvFILLp(ary) + off);
1242 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1243 AvFILLp(dbargs) = AvFILLp(ary) + off;
1249 sortcv(SV *a, SV *b)
1252 I32 oldsaveix = savestack_ix;
1253 I32 oldscopeix = scopestack_ix;
1257 stack_sp = stack_base;
1260 if (stack_sp != stack_base + 1)
1261 croak("Sort subroutine didn't return single value");
1262 if (!SvNIOKp(*stack_sp))
1263 croak("Sort subroutine didn't return a numeric value");
1264 result = SvIV(*stack_sp);
1265 while (scopestack_ix > oldscopeix) {
1268 leave_scope(oldsaveix);
1281 sv_reset(tmps, curcop->cop_stash);
1294 TAINT_NOT; /* Each statement is presumed innocent */
1295 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1298 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1302 register PERL_CONTEXT *cx;
1303 I32 gimme = G_ARRAY;
1310 DIE("No DB::DB routine defined");
1312 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1324 push_return(op->op_next);
1325 PUSHBLOCK(cx, CXt_SUB, SP);
1328 (void)SvREFCNT_inc(cv);
1330 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1331 RETURNOP(CvSTART(cv));
1345 register PERL_CONTEXT *cx;
1346 I32 gimme = GIMME_V;
1353 if (op->op_flags & OPf_SPECIAL)
1354 svp = save_threadsv(op->op_targ); /* per-thread variable */
1356 #endif /* USE_THREADS */
1358 svp = &curpad[op->op_targ]; /* "my" variable */
1363 (void)save_scalar(gv);
1364 svp = &GvSV(gv); /* symbol table variable */
1369 PUSHBLOCK(cx, CXt_LOOP, SP);
1370 PUSHLOOP(cx, svp, MARK);
1371 if (op->op_flags & OPf_STACKED)
1372 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1374 cx->blk_loop.iterary = curstack;
1375 AvFILLp(curstack) = SP - stack_base;
1376 cx->blk_loop.iterix = MARK - stack_base;
1385 register PERL_CONTEXT *cx;
1386 I32 gimme = GIMME_V;
1392 PUSHBLOCK(cx, CXt_LOOP, SP);
1393 PUSHLOOP(cx, 0, SP);
1401 register PERL_CONTEXT *cx;
1402 struct block_loop cxloop;
1410 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1413 if (gimme == G_VOID)
1415 else if (gimme == G_SCALAR) {
1417 *++newsp = sv_mortalcopy(*SP);
1419 *++newsp = &sv_undef;
1423 *++newsp = sv_mortalcopy(*++mark);
1424 TAINT_NOT; /* Each item is independent */
1430 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1431 curpm = newpm; /* ... and pop $1 et al */
1443 register PERL_CONTEXT *cx;
1444 struct block_sub cxsub;
1445 bool popsub2 = FALSE;
1451 if (curstackinfo->si_type == SI_SORT) {
1452 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1453 if (cxstack_ix > sortcxix)
1455 AvARRAY(curstack)[1] = *SP;
1456 stack_sp = stack_base + 1;
1461 cxix = dopoptosub(cxstack_ix);
1463 DIE("Can't return outside a subroutine");
1464 if (cxix < cxstack_ix)
1468 switch (cx->cx_type) {
1470 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1475 if (optype == OP_REQUIRE &&
1476 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1478 /* Unassume the success we assumed earlier. */
1479 char *name = cx->blk_eval.old_name;
1480 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1481 DIE("%s did not return a true value", name);
1485 DIE("panic: return");
1489 if (gimme == G_SCALAR) {
1491 *++newsp = (popsub2 && SvTEMP(*SP))
1492 ? *SP : sv_mortalcopy(*SP);
1494 *++newsp = &sv_undef;
1496 else if (gimme == G_ARRAY) {
1497 while (++MARK <= SP) {
1498 *++newsp = (popsub2 && SvTEMP(*MARK))
1499 ? *MARK : sv_mortalcopy(*MARK);
1500 TAINT_NOT; /* Each item is independent */
1505 /* Stack values are safe: */
1507 POPSUB2(); /* release CV and @_ ... */
1509 curpm = newpm; /* ... and pop $1 et al */
1512 return pop_return();
1519 register PERL_CONTEXT *cx;
1520 struct block_loop cxloop;
1521 struct block_sub cxsub;
1528 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1530 if (op->op_flags & OPf_SPECIAL) {
1531 cxix = dopoptoloop(cxstack_ix);
1533 DIE("Can't \"last\" outside a block");
1536 cxix = dopoptolabel(cPVOP->op_pv);
1538 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1540 if (cxix < cxstack_ix)
1544 switch (cx->cx_type) {
1546 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1548 nextop = cxloop.last_op->op_next;
1551 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1553 nextop = pop_return();
1557 nextop = pop_return();
1564 if (gimme == G_SCALAR) {
1566 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1567 ? *SP : sv_mortalcopy(*SP);
1569 *++newsp = &sv_undef;
1571 else if (gimme == G_ARRAY) {
1572 while (++MARK <= SP) {
1573 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1574 ? *MARK : sv_mortalcopy(*MARK);
1575 TAINT_NOT; /* Each item is independent */
1581 /* Stack values are safe: */
1584 POPLOOP2(); /* release loop vars ... */
1588 POPSUB2(); /* release CV and @_ ... */
1591 curpm = newpm; /* ... and pop $1 et al */
1600 register PERL_CONTEXT *cx;
1603 if (op->op_flags & OPf_SPECIAL) {
1604 cxix = dopoptoloop(cxstack_ix);
1606 DIE("Can't \"next\" outside a block");
1609 cxix = dopoptolabel(cPVOP->op_pv);
1611 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1613 if (cxix < cxstack_ix)
1617 oldsave = scopestack[scopestack_ix - 1];
1618 LEAVE_SCOPE(oldsave);
1619 return cx->blk_loop.next_op;
1625 register PERL_CONTEXT *cx;
1628 if (op->op_flags & OPf_SPECIAL) {
1629 cxix = dopoptoloop(cxstack_ix);
1631 DIE("Can't \"redo\" outside a block");
1634 cxix = dopoptolabel(cPVOP->op_pv);
1636 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1638 if (cxix < cxstack_ix)
1642 oldsave = scopestack[scopestack_ix - 1];
1643 LEAVE_SCOPE(oldsave);
1644 return cx->blk_loop.redo_op;
1648 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1652 static char too_deep[] = "Target of goto is too deeply nested";
1656 if (o->op_type == OP_LEAVE ||
1657 o->op_type == OP_SCOPE ||
1658 o->op_type == OP_LEAVELOOP ||
1659 o->op_type == OP_LEAVETRY)
1661 *ops++ = cUNOPo->op_first;
1666 if (o->op_flags & OPf_KIDS) {
1667 /* First try all the kids at this level, since that's likeliest. */
1668 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1669 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1670 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1673 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1674 if (kid == lastgotoprobe)
1676 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1678 (ops[-1]->op_type != OP_NEXTSTATE &&
1679 ops[-1]->op_type != OP_DBSTATE)))
1681 if (o = dofindlabel(kid, label, ops, oplimit))
1691 return pp_goto(ARGS);
1700 register PERL_CONTEXT *cx;
1701 #define GOTO_DEPTH 64
1702 OP *enterops[GOTO_DEPTH];
1704 int do_dump = (op->op_type == OP_DUMP);
1707 if (op->op_flags & OPf_STACKED) {
1710 /* This egregious kludge implements goto &subroutine */
1711 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1713 register PERL_CONTEXT *cx;
1714 CV* cv = (CV*)SvRV(sv);
1719 if (!CvROOT(cv) && !CvXSUB(cv)) {
1721 SV *tmpstr = sv_newmortal();
1722 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1723 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1725 DIE("Goto undefined subroutine");
1728 /* First do some returnish stuff. */
1729 cxix = dopoptosub(cxstack_ix);
1731 DIE("Can't goto subroutine outside a subroutine");
1732 if (cxix < cxstack_ix)
1735 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1736 DIE("Can't goto subroutine from an eval-string");
1738 if (cx->cx_type == CXt_SUB &&
1739 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1740 AV* av = cx->blk_sub.argarray;
1742 items = AvFILLp(av) + 1;
1744 EXTEND(stack_sp, items); /* @_ could have been extended. */
1745 Copy(AvARRAY(av), stack_sp, items, SV*);
1748 SvREFCNT_dec(GvAV(defgv));
1749 GvAV(defgv) = cx->blk_sub.savearray;
1750 #endif /* USE_THREADS */
1754 if (cx->cx_type == CXt_SUB &&
1755 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1756 SvREFCNT_dec(cx->blk_sub.cv);
1757 oldsave = scopestack[scopestack_ix - 1];
1758 LEAVE_SCOPE(oldsave);
1760 /* Now do some callish stuff. */
1763 if (CvOLDSTYLE(cv)) {
1764 I32 (*fp3)_((int,int,int));
1769 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1770 items = (*fp3)(CvXSUBANY(cv).any_i32,
1771 mark - stack_base + 1,
1773 SP = stack_base + items;
1776 stack_sp--; /* There is no cv arg. */
1777 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1780 return pop_return();
1783 AV* padlist = CvPADLIST(cv);
1784 SV** svp = AvARRAY(padlist);
1785 if (cx->cx_type == CXt_EVAL) {
1786 in_eval = cx->blk_eval.old_in_eval;
1787 eval_root = cx->blk_eval.old_eval_root;
1788 cx->cx_type = CXt_SUB;
1789 cx->blk_sub.hasargs = 0;
1791 cx->blk_sub.cv = cv;
1792 cx->blk_sub.olddepth = CvDEPTH(cv);
1794 if (CvDEPTH(cv) < 2)
1795 (void)SvREFCNT_inc(cv);
1796 else { /* save temporaries on recursion? */
1797 if (CvDEPTH(cv) == 100 && dowarn)
1798 sub_crush_depth(cv);
1799 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1800 AV *newpad = newAV();
1801 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1802 I32 ix = AvFILLp((AV*)svp[1]);
1803 svp = AvARRAY(svp[0]);
1804 for ( ;ix > 0; ix--) {
1805 if (svp[ix] != &sv_undef) {
1806 char *name = SvPVX(svp[ix]);
1807 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1810 /* outer lexical or anon code */
1811 av_store(newpad, ix,
1812 SvREFCNT_inc(oldpad[ix]) );
1814 else { /* our own lexical */
1816 av_store(newpad, ix, sv = (SV*)newAV());
1817 else if (*name == '%')
1818 av_store(newpad, ix, sv = (SV*)newHV());
1820 av_store(newpad, ix, sv = NEWSV(0,0));
1825 av_store(newpad, ix, sv = NEWSV(0,0));
1829 if (cx->blk_sub.hasargs) {
1832 av_store(newpad, 0, (SV*)av);
1833 AvFLAGS(av) = AVf_REIFY;
1835 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1836 AvFILLp(padlist) = CvDEPTH(cv);
1837 svp = AvARRAY(padlist);
1841 if (!cx->blk_sub.hasargs) {
1842 AV* av = (AV*)curpad[0];
1844 items = AvFILLp(av) + 1;
1846 /* Mark is at the end of the stack. */
1848 Copy(AvARRAY(av), SP + 1, items, SV*);
1853 #endif /* USE_THREADS */
1855 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1857 if (cx->blk_sub.hasargs)
1858 #endif /* USE_THREADS */
1860 AV* av = (AV*)curpad[0];
1864 cx->blk_sub.savearray = GvAV(defgv);
1865 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1866 #endif /* USE_THREADS */
1867 cx->blk_sub.argarray = av;
1870 if (items >= AvMAX(av) + 1) {
1872 if (AvARRAY(av) != ary) {
1873 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1874 SvPVX(av) = (char*)ary;
1876 if (items >= AvMAX(av) + 1) {
1877 AvMAX(av) = items - 1;
1878 Renew(ary,items+1,SV*);
1880 SvPVX(av) = (char*)ary;
1883 Copy(mark,AvARRAY(av),items,SV*);
1884 AvFILLp(av) = items - 1;
1892 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1894 * We do not care about using sv to call CV;
1895 * it's for informational purposes only.
1897 SV *sv = GvSV(DBsub);
1900 if (PERLDB_SUB_NN) {
1901 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1904 gv_efullname3(sv, CvGV(cv), Nullch);
1907 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1908 PUSHMARK( stack_sp );
1909 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1913 RETURNOP(CvSTART(cv));
1917 label = SvPV(sv,na);
1919 else if (op->op_flags & OPf_SPECIAL) {
1921 DIE("goto must have label");
1924 label = cPVOP->op_pv;
1926 if (label && *label) {
1933 for (ix = cxstack_ix; ix >= 0; ix--) {
1935 switch (cx->cx_type) {
1937 gotoprobe = eval_root; /* XXX not good for nested eval */
1940 gotoprobe = cx->blk_oldcop->op_sibling;
1946 gotoprobe = cx->blk_oldcop->op_sibling;
1948 gotoprobe = main_root;
1951 if (CvDEPTH(cx->blk_sub.cv)) {
1952 gotoprobe = CvROOT(cx->blk_sub.cv);
1957 DIE("Can't \"goto\" outside a block");
1961 gotoprobe = main_root;
1964 retop = dofindlabel(gotoprobe, label,
1965 enterops, enterops + GOTO_DEPTH);
1968 lastgotoprobe = gotoprobe;
1971 DIE("Can't find label %s", label);
1973 /* pop unwanted frames */
1975 if (ix < cxstack_ix) {
1982 oldsave = scopestack[scopestack_ix];
1983 LEAVE_SCOPE(oldsave);
1986 /* push wanted frames */
1988 if (*enterops && enterops[1]) {
1990 for (ix = 1; enterops[ix]; ix++) {
1992 /* Eventually we may want to stack the needed arguments
1993 * for each op. For now, we punt on the hard ones. */
1994 if (op->op_type == OP_ENTERITER)
1995 DIE("Can't \"goto\" into the middle of a foreach loop",
1997 (CALLOP->op_ppaddr)(ARGS);
2005 if (!retop) retop = main_start;
2012 restartop = 0; /* hmm, must be GNU unexec().. */
2016 if (top_env->je_prev) {
2034 if (anum == 1 && VMSISH_EXIT)
2047 double value = SvNVx(GvSV(cCOP->cop_gv));
2048 register I32 match = I_32(value);
2051 if (((double)match) > value)
2052 --match; /* was fractional--truncate other way */
2054 match -= cCOP->uop.scop.scop_offset;
2057 else if (match > cCOP->uop.scop.scop_max)
2058 match = cCOP->uop.scop.scop_max;
2059 op = cCOP->uop.scop.scop_next[match];
2069 op = op->op_next; /* can't assume anything */
2071 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2072 match -= cCOP->uop.scop.scop_offset;
2075 else if (match > cCOP->uop.scop.scop_max)
2076 match = cCOP->uop.scop.scop_max;
2077 op = cCOP->uop.scop.scop_next[match];
2086 save_lines(AV *array, SV *sv)
2088 register char *s = SvPVX(sv);
2089 register char *send = SvPVX(sv) + SvCUR(sv);
2091 register I32 line = 1;
2093 while (s && s < send) {
2094 SV *tmpstr = NEWSV(85,0);
2096 sv_upgrade(tmpstr, SVt_PVMG);
2097 t = strchr(s, '\n');
2103 sv_setpvn(tmpstr, s, t - s);
2104 av_store(array, line++, tmpstr);
2119 assert(CATCH_GET == TRUE);
2120 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2124 default: /* topmost level handles it */
2131 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2147 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2148 /* sv Text to convert to OP tree. */
2149 /* startop op_free() this to undo. */
2150 /* code Short string id of the caller. */
2152 dSP; /* Make POPBLOCK work. */
2155 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2159 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2165 /* switch to eval mode */
2167 SAVESPTR(compiling.cop_filegv);
2168 SAVEI16(compiling.cop_line);
2169 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2170 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2171 compiling.cop_line = 1;
2172 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2173 deleting the eval's FILEGV from the stash before gv_check() runs
2174 (i.e. before run-time proper). To work around the coredump that
2175 ensues, we always turn GvMULTI_on for any globals that were
2176 introduced within evals. See force_ident(). GSAR 96-10-12 */
2177 safestr = savepv(tmpbuf);
2178 SAVEDELETE(defstash, safestr, strlen(safestr));
2180 #ifdef OP_IN_REGISTER
2188 op->op_type = 0; /* Avoid uninit warning. */
2189 op->op_flags = 0; /* Avoid uninit warning. */
2190 PUSHBLOCK(cx, CXt_EVAL, SP);
2191 PUSHEVAL(cx, 0, compiling.cop_filegv);
2192 rop = doeval(G_SCALAR, startop);
2196 (*startop)->op_type = OP_NULL;
2197 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2199 *avp = (AV*)SvREFCNT_inc(comppad);
2201 #ifdef OP_IN_REGISTER
2207 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2209 doeval(int gimme, OP** startop)
2222 /* set up a scratch pad */
2227 SAVESPTR(comppad_name);
2228 SAVEI32(comppad_name_fill);
2229 SAVEI32(min_intro_pending);
2230 SAVEI32(max_intro_pending);
2233 for (i = cxstack_ix - 1; i >= 0; i--) {
2234 PERL_CONTEXT *cx = &cxstack[i];
2235 if (cx->cx_type == CXt_EVAL)
2237 else if (cx->cx_type == CXt_SUB) {
2238 caller = cx->blk_sub.cv;
2244 compcv = (CV*)NEWSV(1104,0);
2245 sv_upgrade((SV *)compcv, SVt_PVCV);
2246 CvUNIQUE_on(compcv);
2248 CvOWNER(compcv) = 0;
2249 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2250 MUTEX_INIT(CvMUTEXP(compcv));
2251 #endif /* USE_THREADS */
2254 av_push(comppad, Nullsv);
2255 curpad = AvARRAY(comppad);
2256 comppad_name = newAV();
2257 comppad_name_fill = 0;
2258 min_intro_pending = 0;
2261 av_store(comppad_name, 0, newSVpv("@_", 2));
2262 curpad[0] = (SV*)newAV();
2263 SvPADMY_on(curpad[0]); /* XXX Needed? */
2264 #endif /* USE_THREADS */
2266 comppadlist = newAV();
2267 AvREAL_off(comppadlist);
2268 av_store(comppadlist, 0, (SV*)comppad_name);
2269 av_store(comppadlist, 1, (SV*)comppad);
2270 CvPADLIST(compcv) = comppadlist;
2272 if (!saveop || saveop->op_type != OP_REQUIRE)
2273 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2277 /* make sure we compile in the right package */
2279 newstash = curcop->cop_stash;
2280 if (curstash != newstash) {
2282 curstash = newstash;
2286 SAVEFREESV(beginav);
2288 /* try to compile it */
2292 curcop = &compiling;
2293 curcop->cop_arybase = 0;
2295 rs = newSVpv("\n", 1);
2296 if (saveop && saveop->op_flags & OPf_SPECIAL)
2300 if (yyparse() || error_count || !eval_root) {
2304 I32 optype = 0; /* Might be reset by POPEVAL. */
2311 SP = stack_base + POPMARK; /* pop original mark */
2319 if (optype == OP_REQUIRE) {
2320 char* msg = SvPVx(ERRSV, na);
2321 DIE("%s", *msg ? msg : "Compilation failed in require");
2322 } else if (startop) {
2323 char* msg = SvPVx(ERRSV, na);
2327 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2330 rs = SvREFCNT_inc(nrs);
2332 MUTEX_LOCK(&eval_mutex);
2334 COND_SIGNAL(&eval_cond);
2335 MUTEX_UNLOCK(&eval_mutex);
2336 #endif /* USE_THREADS */
2340 rs = SvREFCNT_inc(nrs);
2341 compiling.cop_line = 0;
2343 *startop = eval_root;
2344 SvREFCNT_dec(CvOUTSIDE(compcv));
2345 CvOUTSIDE(compcv) = Nullcv;
2347 SAVEFREEOP(eval_root);
2349 scalarvoid(eval_root);
2350 else if (gimme & G_ARRAY)
2355 DEBUG_x(dump_eval());
2357 /* Register with debugger: */
2358 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2359 CV *cv = perl_get_cv("DB::postponed", FALSE);
2363 XPUSHs((SV*)compiling.cop_filegv);
2365 perl_call_sv((SV*)cv, G_DISCARD);
2369 /* compiled okay, so do it */
2371 CvDEPTH(compcv) = 1;
2372 SP = stack_base + POPMARK; /* pop original mark */
2373 op = saveop; /* The caller may need it. */
2375 MUTEX_LOCK(&eval_mutex);
2377 COND_SIGNAL(&eval_cond);
2378 MUTEX_UNLOCK(&eval_mutex);
2379 #endif /* USE_THREADS */
2381 RETURNOP(eval_start);
2387 register PERL_CONTEXT *cx;
2392 SV *namesv = Nullsv;
2394 I32 gimme = G_SCALAR;
2395 PerlIO *tryrsfp = 0;
2398 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2399 SET_NUMERIC_STANDARD();
2400 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2401 DIE("Perl %s required--this is only version %s, stopped",
2402 SvPV(sv,na),patchlevel);
2405 name = SvPV(sv, len);
2406 if (!(name && len > 0 && *name))
2407 DIE("Null filename used");
2408 TAINT_PROPER("require");
2409 if (op->op_type == OP_REQUIRE &&
2410 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2414 /* prepare to compile file */
2419 (name[1] == '.' && name[2] == '/')))
2421 || (name[0] && name[1] == ':')
2424 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2427 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2428 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2433 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2436 AV *ar = GvAVn(incgv);
2440 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2443 namesv = NEWSV(806, 0);
2444 for (i = 0; i <= AvFILL(ar); i++) {
2445 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2448 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2450 sv_setpv(namesv, unixdir);
2451 sv_catpv(namesv, unixname);
2453 sv_setpvf(namesv, "%s/%s", dir, name);
2455 tryname = SvPVX(namesv);
2456 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2458 if (tryname[0] == '.' && tryname[1] == '/')
2465 SAVESPTR(compiling.cop_filegv);
2466 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2467 SvREFCNT_dec(namesv);
2469 if (op->op_type == OP_REQUIRE) {
2470 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2471 SV *dirmsgsv = NEWSV(0, 0);
2472 AV *ar = GvAVn(incgv);
2474 if (instr(SvPVX(msg), ".h "))
2475 sv_catpv(msg, " (change .h to .ph maybe?)");
2476 if (instr(SvPVX(msg), ".ph "))
2477 sv_catpv(msg, " (did you run h2ph?)");
2478 sv_catpv(msg, " (@INC contains:");
2479 for (i = 0; i <= AvFILL(ar); i++) {
2480 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2481 sv_setpvf(dirmsgsv, " %s", dir);
2482 sv_catsv(msg, dirmsgsv);
2484 sv_catpvn(msg, ")", 1);
2485 SvREFCNT_dec(dirmsgsv);
2492 /* Assume success here to prevent recursive requirement. */
2493 (void)hv_store(GvHVn(incgv), name, strlen(name),
2494 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2498 lex_start(sv_2mortal(newSVpv("",0)));
2500 save_aptr(&rsfp_filters);
2501 rsfp_filters = NULL;
2505 name = savepv(name);
2510 /* switch to eval mode */
2512 push_return(op->op_next);
2513 PUSHBLOCK(cx, CXt_EVAL, SP);
2514 PUSHEVAL(cx, name, compiling.cop_filegv);
2516 compiling.cop_line = 0;
2520 MUTEX_LOCK(&eval_mutex);
2521 if (eval_owner && eval_owner != thr)
2523 COND_WAIT(&eval_cond, &eval_mutex);
2525 MUTEX_UNLOCK(&eval_mutex);
2526 #endif /* USE_THREADS */
2527 return DOCATCH(doeval(G_SCALAR, NULL));
2532 return pp_require(ARGS);
2538 register PERL_CONTEXT *cx;
2540 I32 gimme = GIMME_V, was = sub_generation;
2541 char tmpbuf[TYPE_DIGITS(long) + 12];
2546 if (!SvPV(sv,len) || !len)
2548 TAINT_PROPER("eval");
2554 /* switch to eval mode */
2556 SAVESPTR(compiling.cop_filegv);
2557 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2558 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2559 compiling.cop_line = 1;
2560 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2561 deleting the eval's FILEGV from the stash before gv_check() runs
2562 (i.e. before run-time proper). To work around the coredump that
2563 ensues, we always turn GvMULTI_on for any globals that were
2564 introduced within evals. See force_ident(). GSAR 96-10-12 */
2565 safestr = savepv(tmpbuf);
2566 SAVEDELETE(defstash, safestr, strlen(safestr));
2568 hints = op->op_targ;
2570 push_return(op->op_next);
2571 PUSHBLOCK(cx, CXt_EVAL, SP);
2572 PUSHEVAL(cx, 0, compiling.cop_filegv);
2574 /* prepare to compile string */
2576 if (PERLDB_LINE && curstash != debstash)
2577 save_lines(GvAV(compiling.cop_filegv), linestr);
2580 MUTEX_LOCK(&eval_mutex);
2581 if (eval_owner && eval_owner != thr)
2583 COND_WAIT(&eval_cond, &eval_mutex);
2585 MUTEX_UNLOCK(&eval_mutex);
2586 #endif /* USE_THREADS */
2587 ret = doeval(gimme, NULL);
2588 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2589 && ret != op->op_next) { /* Successive compilation. */
2590 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2592 return DOCATCH(ret);
2602 register PERL_CONTEXT *cx;
2604 U8 save_flags = op -> op_flags;
2609 retop = pop_return();
2612 if (gimme == G_VOID)
2614 else if (gimme == G_SCALAR) {
2617 if (SvFLAGS(TOPs) & SVs_TEMP)
2620 *MARK = sv_mortalcopy(TOPs);
2628 /* in case LEAVE wipes old return values */
2629 for (mark = newsp + 1; mark <= SP; mark++) {
2630 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2631 *mark = sv_mortalcopy(*mark);
2632 TAINT_NOT; /* Each item is independent */
2636 curpm = newpm; /* Don't pop $1 et al till now */
2639 * Closures mentioned at top level of eval cannot be referenced
2640 * again, and their presence indirectly causes a memory leak.
2641 * (Note that the fact that compcv and friends are still set here
2642 * is, AFAIK, an accident.) --Chip
2644 if (AvFILLp(comppad_name) >= 0) {
2645 SV **svp = AvARRAY(comppad_name);
2647 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2649 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2651 svp[ix] = &sv_undef;
2655 SvREFCNT_dec(CvOUTSIDE(sv));
2656 CvOUTSIDE(sv) = Nullcv;
2669 assert(CvDEPTH(compcv) == 1);
2671 CvDEPTH(compcv) = 0;
2674 if (optype == OP_REQUIRE &&
2675 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2677 /* Unassume the success we assumed earlier. */
2678 char *name = cx->blk_eval.old_name;
2679 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2680 retop = die("%s did not return a true value", name);
2681 /* die_where() did LEAVE, or we won't be here */
2685 if (!(save_flags & OPf_SPECIAL))
2695 register PERL_CONTEXT *cx;
2696 I32 gimme = GIMME_V;
2701 push_return(cLOGOP->op_other->op_next);
2702 PUSHBLOCK(cx, CXt_EVAL, SP);
2704 eval_root = op; /* Only needed so that goto works right. */
2709 return DOCATCH(op->op_next);
2719 register PERL_CONTEXT *cx;
2727 if (gimme == G_VOID)
2729 else if (gimme == G_SCALAR) {
2732 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2735 *MARK = sv_mortalcopy(TOPs);
2744 /* in case LEAVE wipes old return values */
2745 for (mark = newsp + 1; mark <= SP; mark++) {
2746 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2747 *mark = sv_mortalcopy(*mark);
2748 TAINT_NOT; /* Each item is independent */
2752 curpm = newpm; /* Don't pop $1 et al till now */
2763 register char *s = SvPV_force(sv, len);
2764 register char *send = s + len;
2765 register char *base;
2766 register I32 skipspaces = 0;
2769 bool postspace = FALSE;
2777 croak("Null picture in formline");
2779 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2784 *fpc++ = FF_LINEMARK;
2785 noblank = repeat = FALSE;
2803 case ' ': case '\t':
2814 *fpc++ = FF_LITERAL;
2822 *fpc++ = skipspaces;
2826 *fpc++ = FF_NEWLINE;
2830 arg = fpc - linepc + 1;
2837 *fpc++ = FF_LINEMARK;
2838 noblank = repeat = FALSE;
2847 ischop = s[-1] == '^';
2853 arg = (s - base) - 1;
2855 *fpc++ = FF_LITERAL;
2864 *fpc++ = FF_LINEGLOB;
2866 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2867 arg = ischop ? 512 : 0;
2877 arg |= 256 + (s - f);
2879 *fpc++ = s - base; /* fieldsize for FETCH */
2880 *fpc++ = FF_DECIMAL;
2885 bool ismore = FALSE;
2888 while (*++s == '>') ;
2889 prespace = FF_SPACE;
2891 else if (*s == '|') {
2892 while (*++s == '|') ;
2893 prespace = FF_HALFSPACE;
2898 while (*++s == '<') ;
2901 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2905 *fpc++ = s - base; /* fieldsize for FETCH */
2907 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2925 { /* need to jump to the next word */
2927 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2928 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2929 s = SvPVX(sv) + SvCUR(sv) + z;
2931 Copy(fops, s, arg, U16);
2933 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2938 * The rest of this file was derived from source code contributed
2941 * NOTE: this code was derived from Tom Horsley's qsort replacement
2942 * and should not be confused with the original code.
2945 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2947 Permission granted to distribute under the same terms as perl which are
2950 This program is free software; you can redistribute it and/or modify
2951 it under the terms of either:
2953 a) the GNU General Public License as published by the Free
2954 Software Foundation; either version 1, or (at your option) any
2957 b) the "Artistic License" which comes with this Kit.
2959 Details on the perl license can be found in the perl source code which
2960 may be located via the www.perl.com web page.
2962 This is the most wonderfulest possible qsort I can come up with (and
2963 still be mostly portable) My (limited) tests indicate it consistently
2964 does about 20% fewer calls to compare than does the qsort in the Visual
2965 C++ library, other vendors may vary.
2967 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2968 others I invented myself (or more likely re-invented since they seemed
2969 pretty obvious once I watched the algorithm operate for a while).
2971 Most of this code was written while watching the Marlins sweep the Giants
2972 in the 1997 National League Playoffs - no Braves fans allowed to use this
2973 code (just kidding :-).
2975 I realize that if I wanted to be true to the perl tradition, the only
2976 comment in this file would be something like:
2978 ...they shuffled back towards the rear of the line. 'No, not at the
2979 rear!' the slave-driver shouted. 'Three files up. And stay there...
2981 However, I really needed to violate that tradition just so I could keep
2982 track of what happens myself, not to mention some poor fool trying to
2983 understand this years from now :-).
2986 /* ********************************************************** Configuration */
2988 #ifndef QSORT_ORDER_GUESS
2989 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
2992 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
2993 future processing - a good max upper bound is log base 2 of memory size
2994 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
2995 safely be smaller than that since the program is taking up some space and
2996 most operating systems only let you grab some subset of contiguous
2997 memory (not to mention that you are normally sorting data larger than
2998 1 byte element size :-).
3000 #ifndef QSORT_MAX_STACK
3001 #define QSORT_MAX_STACK 32
3004 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3005 Anything bigger and we use qsort. If you make this too small, the qsort
3006 will probably break (or become less efficient), because it doesn't expect
3007 the middle element of a partition to be the same as the right or left -
3008 you have been warned).
3010 #ifndef QSORT_BREAK_EVEN
3011 #define QSORT_BREAK_EVEN 6
3014 /* ************************************************************* Data Types */
3016 /* hold left and right index values of a partition waiting to be sorted (the
3017 partition includes both left and right - right is NOT one past the end or
3018 anything like that).
3020 struct partition_stack_entry {
3023 #ifdef QSORT_ORDER_GUESS
3024 int qsort_break_even;
3028 /* ******************************************************* Shorthand Macros */
3030 /* Note that these macros will be used from inside the qsort function where
3031 we happen to know that the variable 'elt_size' contains the size of an
3032 array element and the variable 'temp' points to enough space to hold a
3033 temp element and the variable 'array' points to the array being sorted
3034 and 'compare' is the pointer to the compare routine.
3036 Also note that there are very many highly architecture specific ways
3037 these might be sped up, but this is simply the most generally portable
3038 code I could think of.
3041 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3044 #define qsort_cmp(elt1, elt2) \
3045 ((this->*compare)(array[elt1], array[elt2]))
3047 #define qsort_cmp(elt1, elt2) \
3048 ((*compare)(array[elt1], array[elt2]))
3051 #ifdef QSORT_ORDER_GUESS
3052 #define QSORT_NOTICE_SWAP swapped++;
3054 #define QSORT_NOTICE_SWAP
3057 /* swaps contents of array elements elt1, elt2.
3059 #define qsort_swap(elt1, elt2) \
3062 temp = array[elt1]; \
3063 array[elt1] = array[elt2]; \
3064 array[elt2] = temp; \
3067 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3068 elt3 and elt3 gets elt1.
3070 #define qsort_rotate(elt1, elt2, elt3) \
3073 temp = array[elt1]; \
3074 array[elt1] = array[elt2]; \
3075 array[elt2] = array[elt3]; \
3076 array[elt3] = temp; \
3079 /* ************************************************************ Debug stuff */
3086 return; /* good place to set a breakpoint */
3089 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3092 doqsort_all_asserts(
3096 int (*compare)(const void * elt1, const void * elt2),
3097 int pc_left, int pc_right, int u_left, int u_right)
3101 qsort_assert(pc_left <= pc_right);
3102 qsort_assert(u_right < pc_left);
3103 qsort_assert(pc_right < u_left);
3104 for (i = u_right + 1; i < pc_left; ++i) {
3105 qsort_assert(qsort_cmp(i, pc_left) < 0);
3107 for (i = pc_left; i < pc_right; ++i) {
3108 qsort_assert(qsort_cmp(i, pc_right) == 0);
3110 for (i = pc_right + 1; i < u_left; ++i) {
3111 qsort_assert(qsort_cmp(pc_right, i) < 0);
3115 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3116 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3117 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3121 #define qsort_assert(t) ((void)0)
3123 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3127 /* ****************************************************************** qsort */
3131 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3136 I32 (*compare)(SV *a, SV *b))
3141 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3142 int next_stack_entry = 0;
3146 #ifdef QSORT_ORDER_GUESS
3147 int qsort_break_even;
3151 /* Make sure we actually have work to do.
3153 if (num_elts <= 1) {
3157 /* Setup the initial partition definition and fall into the sorting loop
3160 part_right = (int)(num_elts - 1);
3161 #ifdef QSORT_ORDER_GUESS
3162 qsort_break_even = QSORT_BREAK_EVEN;
3164 #define qsort_break_even QSORT_BREAK_EVEN
3167 if ((part_right - part_left) >= qsort_break_even) {
3168 /* OK, this is gonna get hairy, so lets try to document all the
3169 concepts and abbreviations and variables and what they keep
3172 pc: pivot chunk - the set of array elements we accumulate in the
3173 middle of the partition, all equal in value to the original
3174 pivot element selected. The pc is defined by:
3176 pc_left - the leftmost array index of the pc
3177 pc_right - the rightmost array index of the pc
3179 we start with pc_left == pc_right and only one element
3180 in the pivot chunk (but it can grow during the scan).
3182 u: uncompared elements - the set of elements in the partition
3183 we have not yet compared to the pivot value. There are two
3184 uncompared sets during the scan - one to the left of the pc
3185 and one to the right.
3187 u_right - the rightmost index of the left side's uncompared set
3188 u_left - the leftmost index of the right side's uncompared set
3190 The leftmost index of the left sides's uncompared set
3191 doesn't need its own variable because it is always defined
3192 by the leftmost edge of the whole partition (part_left). The
3193 same goes for the rightmost edge of the right partition
3196 We know there are no uncompared elements on the left once we
3197 get u_right < part_left and no uncompared elements on the
3198 right once u_left > part_right. When both these conditions
3199 are met, we have completed the scan of the partition.
3201 Any elements which are between the pivot chunk and the
3202 uncompared elements should be less than the pivot value on
3203 the left side and greater than the pivot value on the right
3204 side (in fact, the goal of the whole algorithm is to arrange
3205 for that to be true and make the groups of less-than and
3206 greater-then elements into new partitions to sort again).
3208 As you marvel at the complexity of the code and wonder why it
3209 has to be so confusing. Consider some of the things this level
3210 of confusion brings:
3212 Once I do a compare, I squeeze every ounce of juice out of it. I
3213 never do compare calls I don't have to do, and I certainly never
3216 I also never swap any elements unless I can prove there is a
3217 good reason. Many sort algorithms will swap a known value with
3218 an uncompared value just to get things in the right place (or
3219 avoid complexity :-), but that uncompared value, once it gets
3220 compared, may then have to be swapped again. A lot of the
3221 complexity of this code is due to the fact that it never swaps
3222 anything except compared values, and it only swaps them when the
3223 compare shows they are out of position.
3225 int pc_left, pc_right;
3226 int u_right, u_left;
3230 pc_left = ((part_left + part_right) / 2);
3232 u_right = pc_left - 1;
3233 u_left = pc_right + 1;
3235 /* Qsort works best when the pivot value is also the median value
3236 in the partition (unfortunately you can't find the median value
3237 without first sorting :-), so to give the algorithm a helping
3238 hand, we pick 3 elements and sort them and use the median value
3239 of that tiny set as the pivot value.
3241 Some versions of qsort like to use the left middle and right as
3242 the 3 elements to sort so they can insure the ends of the
3243 partition will contain values which will stop the scan in the
3244 compare loop, but when you have to call an arbitrarily complex
3245 routine to do a compare, its really better to just keep track of
3246 array index values to know when you hit the edge of the
3247 partition and avoid the extra compare. An even better reason to
3248 avoid using a compare call is the fact that you can drop off the
3249 edge of the array if someone foolishly provides you with an
3250 unstable compare function that doesn't always provide consistent
3253 So, since it is simpler for us to compare the three adjacent
3254 elements in the middle of the partition, those are the ones we
3255 pick here (conveniently pointed at by u_right, pc_left, and
3256 u_left). The values of the left, center, and right elements
3257 are refered to as l c and r in the following comments.
3260 #ifdef QSORT_ORDER_GUESS
3263 s = qsort_cmp(u_right, pc_left);
3266 s = qsort_cmp(pc_left, u_left);
3267 /* if l < c, c < r - already in order - nothing to do */
3269 /* l < c, c == r - already in order, pc grows */
3271 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3273 /* l < c, c > r - need to know more */
3274 s = qsort_cmp(u_right, u_left);
3276 /* l < c, c > r, l < r - swap c & r to get ordered */
3277 qsort_swap(pc_left, u_left);
3278 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3279 } else if (s == 0) {
3280 /* l < c, c > r, l == r - swap c&r, grow pc */
3281 qsort_swap(pc_left, u_left);
3283 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3285 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3286 qsort_rotate(pc_left, u_right, u_left);
3287 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3290 } else if (s == 0) {
3292 s = qsort_cmp(pc_left, u_left);
3294 /* l == c, c < r - already in order, grow pc */
3296 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3297 } else if (s == 0) {
3298 /* l == c, c == r - already in order, grow pc both ways */
3301 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3303 /* l == c, c > r - swap l & r, grow pc */
3304 qsort_swap(u_right, u_left);
3306 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3310 s = qsort_cmp(pc_left, u_left);
3312 /* l > c, c < r - need to know more */
3313 s = qsort_cmp(u_right, u_left);
3315 /* l > c, c < r, l < r - swap l & c to get ordered */
3316 qsort_swap(u_right, pc_left);
3317 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3318 } else if (s == 0) {
3319 /* l > c, c < r, l == r - swap l & c, grow pc */
3320 qsort_swap(u_right, pc_left);
3322 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3324 /* l > c, c < r, l > r - rotate lcr into crl to order */
3325 qsort_rotate(u_right, pc_left, u_left);
3326 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3328 } else if (s == 0) {
3329 /* l > c, c == r - swap ends, grow pc */
3330 qsort_swap(u_right, u_left);
3332 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3334 /* l > c, c > r - swap ends to get in order */
3335 qsort_swap(u_right, u_left);
3336 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3339 /* We now know the 3 middle elements have been compared and
3340 arranged in the desired order, so we can shrink the uncompared
3345 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3347 /* The above massive nested if was the simple part :-). We now have
3348 the middle 3 elements ordered and we need to scan through the
3349 uncompared sets on either side, swapping elements that are on
3350 the wrong side or simply shuffling equal elements around to get
3351 all equal elements into the pivot chunk.
3355 int still_work_on_left;
3356 int still_work_on_right;
3358 /* Scan the uncompared values on the left. If I find a value
3359 equal to the pivot value, move it over so it is adjacent to
3360 the pivot chunk and expand the pivot chunk. If I find a value
3361 less than the pivot value, then just leave it - its already
3362 on the correct side of the partition. If I find a greater
3363 value, then stop the scan.
3365 while (still_work_on_left = (u_right >= part_left)) {
3366 s = qsort_cmp(u_right, pc_left);
3369 } else if (s == 0) {
3371 if (pc_left != u_right) {
3372 qsort_swap(u_right, pc_left);
3378 qsort_assert(u_right < pc_left);
3379 qsort_assert(pc_left <= pc_right);
3380 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3381 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3384 /* Do a mirror image scan of uncompared values on the right
3386 while (still_work_on_right = (u_left <= part_right)) {
3387 s = qsort_cmp(pc_right, u_left);
3390 } else if (s == 0) {
3392 if (pc_right != u_left) {
3393 qsort_swap(pc_right, u_left);
3399 qsort_assert(u_left > pc_right);
3400 qsort_assert(pc_left <= pc_right);
3401 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3402 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3405 if (still_work_on_left) {
3406 /* I know I have a value on the left side which needs to be
3407 on the right side, but I need to know more to decide
3408 exactly the best thing to do with it.
3410 if (still_work_on_right) {
3411 /* I know I have values on both side which are out of
3412 position. This is a big win because I kill two birds
3413 with one swap (so to speak). I can advance the
3414 uncompared pointers on both sides after swapping both
3415 of them into the right place.
3417 qsort_swap(u_right, u_left);
3420 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3422 /* I have an out of position value on the left, but the
3423 right is fully scanned, so I "slide" the pivot chunk
3424 and any less-than values left one to make room for the
3425 greater value over on the right. If the out of position
3426 value is immediately adjacent to the pivot chunk (there
3427 are no less-than values), I can do that with a swap,
3428 otherwise, I have to rotate one of the less than values
3429 into the former position of the out of position value
3430 and the right end of the pivot chunk into the left end
3434 if (pc_left == u_right) {
3435 qsort_swap(u_right, pc_right);
3436 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3438 qsort_rotate(u_right, pc_left, pc_right);
3439 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3444 } else if (still_work_on_right) {
3445 /* Mirror image of complex case above: I have an out of
3446 position value on the right, but the left is fully
3447 scanned, so I need to shuffle things around to make room
3448 for the right value on the left.
3451 if (pc_right == u_left) {
3452 qsort_swap(u_left, pc_left);
3453 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3455 qsort_rotate(pc_right, pc_left, u_left);
3456 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3461 /* No more scanning required on either side of partition,
3462 break out of loop and figure out next set of partitions
3468 /* The elements in the pivot chunk are now in the right place. They
3469 will never move or be compared again. All I have to do is decide
3470 what to do with the stuff to the left and right of the pivot
3473 Notes on the QSORT_ORDER_GUESS ifdef code:
3475 1. If I just built these partitions without swapping any (or
3476 very many) elements, there is a chance that the elements are
3477 already ordered properly (being properly ordered will
3478 certainly result in no swapping, but the converse can't be
3481 2. A (properly written) insertion sort will run faster on
3482 already ordered data than qsort will.
3484 3. Perhaps there is some way to make a good guess about
3485 switching to an insertion sort earlier than partition size 6
3486 (for instance - we could save the partition size on the stack
3487 and increase the size each time we find we didn't swap, thus
3488 switching to insertion sort earlier for partitions with a
3489 history of not swapping).
3491 4. Naturally, if I just switch right away, it will make
3492 artificial benchmarks with pure ascending (or descending)
3493 data look really good, but is that a good reason in general?
3497 #ifdef QSORT_ORDER_GUESS
3499 #if QSORT_ORDER_GUESS == 1
3500 qsort_break_even = (part_right - part_left) + 1;
3502 #if QSORT_ORDER_GUESS == 2
3503 qsort_break_even *= 2;
3505 #if QSORT_ORDER_GUESS == 3
3506 int prev_break = qsort_break_even;
3507 qsort_break_even *= qsort_break_even;
3508 if (qsort_break_even < prev_break) {
3509 qsort_break_even = (part_right - part_left) + 1;
3513 qsort_break_even = QSORT_BREAK_EVEN;
3517 if (part_left < pc_left) {
3518 /* There are elements on the left which need more processing.
3519 Check the right as well before deciding what to do.
3521 if (pc_right < part_right) {
3522 /* We have two partitions to be sorted. Stack the biggest one
3523 and process the smallest one on the next iteration. This
3524 minimizes the stack height by insuring that any additional
3525 stack entries must come from the smallest partition which
3526 (because it is smallest) will have the fewest
3527 opportunities to generate additional stack entries.
3529 if ((part_right - pc_right) > (pc_left - part_left)) {
3530 /* stack the right partition, process the left */
3531 partition_stack[next_stack_entry].left = pc_right + 1;
3532 partition_stack[next_stack_entry].right = part_right;
3533 #ifdef QSORT_ORDER_GUESS
3534 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3536 part_right = pc_left - 1;
3538 /* stack the left partition, process the right */
3539 partition_stack[next_stack_entry].left = part_left;
3540 partition_stack[next_stack_entry].right = pc_left - 1;
3541 #ifdef QSORT_ORDER_GUESS
3542 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3544 part_left = pc_right + 1;
3546 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3549 /* The elements on the left are the only remaining elements
3550 that need sorting, arrange for them to be processed as the
3553 part_right = pc_left - 1;
3555 } else if (pc_right < part_right) {
3556 /* There is only one chunk on the right to be sorted, make it
3557 the new partition and loop back around.
3559 part_left = pc_right + 1;
3561 /* This whole partition wound up in the pivot chunk, so
3562 we need to get a new partition off the stack.
3564 if (next_stack_entry == 0) {
3565 /* the stack is empty - we are done */
3569 part_left = partition_stack[next_stack_entry].left;
3570 part_right = partition_stack[next_stack_entry].right;
3571 #ifdef QSORT_ORDER_GUESS
3572 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3576 /* This partition is too small to fool with qsort complexity, just
3577 do an ordinary insertion sort to minimize overhead.
3580 /* Assume 1st element is in right place already, and start checking
3581 at 2nd element to see where it should be inserted.
3583 for (i = part_left + 1; i <= part_right; ++i) {
3585 /* Scan (backwards - just in case 'i' is already in right place)
3586 through the elements already sorted to see if the ith element
3587 belongs ahead of one of them.
3589 for (j = i - 1; j >= part_left; --j) {
3590 if (qsort_cmp(i, j) >= 0) {
3591 /* i belongs right after j
3598 /* Looks like we really need to move some things
3602 for (k = i - 1; k >= j; --k)
3603 array[k + 1] = array[k];
3608 /* That partition is now sorted, grab the next one, or get out
3609 of the loop if there aren't any more.
3612 if (next_stack_entry == 0) {
3613 /* the stack is empty - we are done */
3617 part_left = partition_stack[next_stack_entry].left;
3618 part_right = partition_stack[next_stack_entry].right;
3619 #ifdef QSORT_ORDER_GUESS
3620 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3625 /* Believe it or not, the array is sorted at this point! */