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*);
80 SV *sv = SvRV(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);
107 if (!pm->op_pmregexp->prelen && curpm)
109 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
110 pm->op_pmflags |= PMf_WHITE;
112 if (pm->op_pmflags & PMf_KEEP) {
113 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
114 cLOGOP->op_first->op_next = op->op_next;
122 register PMOP *pm = (PMOP*) cLOGOP->op_other;
123 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
124 register SV *dstr = cx->sb_dstr;
125 register char *s = cx->sb_s;
126 register char *m = cx->sb_m;
127 char *orig = cx->sb_orig;
128 register REGEXP *rx = cx->sb_rx;
130 rxres_restore(&cx->sb_rxres, rx);
132 if (cx->sb_iters++) {
133 if (cx->sb_iters > cx->sb_maxiters)
134 DIE("Substitution loop");
136 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
137 cx->sb_rxtainted |= 2;
138 sv_catsv(dstr, POPs);
141 if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
142 s == m, Nullsv, NULL,
143 cx->sb_safebase ? 0 : REXEC_COPY_STR))
145 SV *targ = cx->sb_targ;
146 sv_catpvn(dstr, s, cx->sb_strend - s);
148 TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
149 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
151 (void)SvOOK_off(targ);
152 Safefree(SvPVX(targ));
153 SvPVX(targ) = SvPVX(dstr);
154 SvCUR_set(targ, SvCUR(dstr));
155 SvLEN_set(targ, SvLEN(dstr));
159 TAINT_IF(cx->sb_rxtainted & 1);
160 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
162 (void)SvPOK_only(targ);
163 TAINT_IF(cx->sb_rxtainted);
167 LEAVE_SCOPE(cx->sb_oldsave);
169 RETURNOP(pm->op_next);
172 if (rx->subbase && rx->subbase != orig) {
175 cx->sb_orig = orig = rx->subbase;
177 cx->sb_strend = s + (cx->sb_strend - m);
179 cx->sb_m = m = rx->startp[0];
180 sv_catpvn(dstr, s, m-s);
181 cx->sb_s = rx->endp[0];
182 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
183 rxres_save(&cx->sb_rxres, rx);
184 RETURNOP(pm->op_pmreplstart);
188 rxres_save(void **rsp, REGEXP *rx)
193 if (!p || p[1] < rx->nparens) {
194 i = 6 + rx->nparens * 2;
202 *p++ = (UV)rx->subbase;
203 rx->subbase = Nullch;
207 *p++ = (UV)rx->subbeg;
208 *p++ = (UV)rx->subend;
209 for (i = 0; i <= rx->nparens; ++i) {
210 *p++ = (UV)rx->startp[i];
211 *p++ = (UV)rx->endp[i];
216 rxres_restore(void **rsp, REGEXP *rx)
221 Safefree(rx->subbase);
222 rx->subbase = (char*)(*p);
227 rx->subbeg = (char*)(*p++);
228 rx->subend = (char*)(*p++);
229 for (i = 0; i <= rx->nparens; ++i) {
230 rx->startp[i] = (char*)(*p++);
231 rx->endp[i] = (char*)(*p++);
236 rxres_free(void **rsp)
241 Safefree((char*)(*p));
249 djSP; dMARK; dORIGMARK;
250 register SV *tmpForm = *++MARK;
262 bool chopspace = (strchr(chopset, ' ') != Nullch);
269 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
270 SvREADONLY_off(tmpForm);
271 doparseform(tmpForm);
274 SvPV_force(formtarget, len);
275 t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */
277 f = SvPV(tmpForm, len);
278 /* need to jump to the next word */
279 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
288 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
289 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
290 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
291 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
292 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
294 case FF_CHECKNL: name = "CHECKNL"; break;
295 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
296 case FF_SPACE: name = "SPACE"; break;
297 case FF_HALFSPACE: name = "HALFSPACE"; break;
298 case FF_ITEM: name = "ITEM"; break;
299 case FF_CHOP: name = "CHOP"; break;
300 case FF_LINEGLOB: name = "LINEGLOB"; break;
301 case FF_NEWLINE: name = "NEWLINE"; break;
302 case FF_MORE: name = "MORE"; break;
303 case FF_LINEMARK: name = "LINEMARK"; break;
304 case FF_END: name = "END"; break;
307 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
309 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
338 warn("Not enough format arguments");
343 item = s = SvPV(sv, len);
345 if (itemsize > fieldsize)
346 itemsize = fieldsize;
347 send = chophere = s + itemsize;
359 item = s = SvPV(sv, len);
361 if (itemsize <= fieldsize) {
362 send = chophere = s + itemsize;
373 itemsize = fieldsize;
374 send = chophere = s + itemsize;
375 while (s < send || (s == send && isSPACE(*s))) {
385 if (strchr(chopset, *s))
390 itemsize = chophere - item;
395 arg = fieldsize - itemsize;
404 arg = fieldsize - itemsize;
418 int ch = *t++ = *s++;
422 if ( !((*t++ = *s++) & ~31) )
432 while (*s && isSPACE(*s))
439 item = s = SvPV(sv, len);
452 SvCUR_set(formtarget, t - SvPVX(formtarget));
453 sv_catpvn(formtarget, item, itemsize);
454 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1);
455 t = SvPVX(formtarget) + SvCUR(formtarget);
460 /* If the field is marked with ^ and the value is undefined,
463 if ((arg & 512) && !SvOK(sv)) {
471 /* Formats aren't yet marked for locales, so assume "yes". */
474 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
476 sprintf(t, "%*.0f", (int) fieldsize, value);
483 while (t-- > linemark && *t == ' ') ;
491 if (arg) { /* repeat until fields exhausted? */
493 SvCUR_set(formtarget, t - SvPVX(formtarget));
494 lines += FmLINES(formtarget);
497 if (strnEQ(linemark, linemark - arg, arg))
498 DIE("Runaway format");
500 FmLINES(formtarget) = lines;
502 RETURNOP(cLISTOP->op_first);
513 arg = fieldsize - itemsize;
520 if (strnEQ(s," ",3)) {
521 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
532 SvCUR_set(formtarget, t - SvPVX(formtarget));
533 FmLINES(formtarget) += lines;
545 if (stack_base + *markstack_ptr == SP) {
547 if (GIMME_V == G_SCALAR)
549 RETURNOP(op->op_next->op_next);
551 stack_sp = stack_base + *markstack_ptr + 1;
552 pp_pushmark(ARGS); /* push dst */
553 pp_pushmark(ARGS); /* push src */
554 ENTER; /* enter outer scope */
558 /* SAVE_DEFSV does *not* suffice here */
559 save_sptr(&THREADSV(0));
561 SAVESPTR(GvSV(defgv));
562 #endif /* USE_THREADS */
563 ENTER; /* enter inner scope */
566 src = stack_base[*markstack_ptr];
571 if (op->op_type == OP_MAPSTART)
572 pp_pushmark(ARGS); /* push top */
573 return ((LOGOP*)op->op_next)->op_other;
578 DIE("panic: mapstart"); /* uses grepstart */
584 I32 diff = (SP - stack_base) - *markstack_ptr;
592 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
593 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
594 count = (SP - stack_base) - markstack_ptr[-1] + 2;
599 markstack_ptr[-1] += shift;
600 *markstack_ptr += shift;
604 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
607 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
609 LEAVE; /* exit inner scope */
612 if (markstack_ptr[-1] > *markstack_ptr) {
616 (void)POPMARK; /* pop top */
617 LEAVE; /* exit outer scope */
618 (void)POPMARK; /* pop src */
619 items = --*markstack_ptr - markstack_ptr[-1];
620 (void)POPMARK; /* pop dst */
621 SP = stack_base + POPMARK; /* pop original mark */
622 if (gimme == G_SCALAR) {
626 else if (gimme == G_ARRAY)
633 ENTER; /* enter inner scope */
636 src = stack_base[markstack_ptr[-1]];
640 RETURNOP(cLOGOP->op_other);
646 djSP; dMARK; dORIGMARK;
648 SV **myorigmark = ORIGMARK;
654 OP* nextop = op->op_next;
656 if (gimme != G_ARRAY) {
663 if (op->op_flags & OPf_STACKED) {
664 if (op->op_flags & OPf_SPECIAL) {
665 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
666 kid = kUNOP->op_first; /* pass rv2gv */
667 kid = kUNOP->op_first; /* pass leave */
668 sortcop = kid->op_next;
669 stash = curcop->cop_stash;
672 cv = sv_2cv(*++MARK, &stash, &gv, 0);
673 if (!(cv && CvROOT(cv))) {
675 SV *tmpstr = sv_newmortal();
676 gv_efullname3(tmpstr, gv, Nullch);
677 if (cv && CvXSUB(cv))
678 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
679 DIE("Undefined sort subroutine \"%s\" called",
684 DIE("Xsub called in sort");
685 DIE("Undefined subroutine in sort");
687 DIE("Not a CODE reference in sort");
689 sortcop = CvSTART(cv);
690 SAVESPTR(CvROOT(cv)->op_ppaddr);
691 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
694 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
699 stash = curcop->cop_stash;
703 while (MARK < SP) { /* This may or may not shift down one here. */
705 if (*up = *++MARK) { /* Weed out nulls. */
707 if (!sortcop && !SvPOK(*up))
708 (void)sv_2pv(*up, &na);
712 max = --up - myorigmark;
717 bool oldcatch = CATCH_GET;
724 if (sortstash != stash) {
725 firstgv = gv_fetchpv("a", TRUE, SVt_PV);
726 secondgv = gv_fetchpv("b", TRUE, SVt_PV);
730 SAVESPTR(GvSV(firstgv));
731 SAVESPTR(GvSV(secondgv));
733 PUSHBLOCK(cx, CXt_NULL, stack_base);
734 if (!(op->op_flags & OPf_SPECIAL)) {
735 bool hasargs = FALSE;
736 cx->cx_type = CXt_SUB;
737 cx->blk_gimme = G_SCALAR;
740 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
742 sortcxix = cxstack_ix;
743 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
752 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
753 qsortsv(ORIGMARK+1, max,
754 (op->op_private & OPpLOCALE)
755 ? FUNC_NAME_TO_PTR(sv_cmp_locale)
756 : FUNC_NAME_TO_PTR(sv_cmp));
760 stack_sp = ORIGMARK + max;
768 if (GIMME == G_ARRAY)
769 return cCONDOP->op_true;
770 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
777 if (GIMME == G_ARRAY) {
778 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
782 SV *targ = PAD_SV(op->op_targ);
784 if ((op->op_private & OPpFLIP_LINENUM)
785 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
787 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
788 if (op->op_flags & OPf_SPECIAL) {
796 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
809 if (GIMME == G_ARRAY) {
815 if (SvNIOKp(left) || !SvPOKp(left) ||
816 (looks_like_number(left) && *SvPVX(left) != '0') )
821 EXTEND_MORTAL(max - i + 1);
822 EXTEND(SP, max - i + 1);
825 sv = sv_2mortal(newSViv(i++));
830 SV *final = sv_mortalcopy(right);
832 char *tmps = SvPV(final, len);
834 sv = sv_mortalcopy(left);
835 while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
836 strNE(SvPVX(sv),tmps) ) {
838 sv = sv_2mortal(newSVsv(sv));
841 if (strEQ(SvPVX(sv),tmps))
847 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
849 if ((op->op_private & OPpFLIP_LINENUM)
850 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
852 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
853 sv_catpv(targ, "E0");
864 dopoptolabel(char *label)
868 register PERL_CONTEXT *cx;
870 for (i = cxstack_ix; i >= 0; i--) {
872 switch (cx->cx_type) {
875 warn("Exiting substitution via %s", op_name[op->op_type]);
879 warn("Exiting subroutine via %s", op_name[op->op_type]);
883 warn("Exiting eval via %s", op_name[op->op_type]);
887 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
890 if (!cx->blk_loop.label ||
891 strNE(label, cx->blk_loop.label) ) {
892 DEBUG_l(deb("(Skipping label #%ld %s)\n",
893 (long)i, cx->blk_loop.label));
896 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
906 I32 gimme = block_gimme();
907 return (gimme == G_VOID) ? G_SCALAR : gimme;
916 cxix = dopoptosub(cxstack_ix);
920 switch (cxstack[cxix].blk_gimme) {
928 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
935 dopoptosub(I32 startingblock)
939 register PERL_CONTEXT *cx;
940 for (i = startingblock; i >= 0; i--) {
942 switch (cx->cx_type) {
947 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
955 dopoptoeval(I32 startingblock)
959 register PERL_CONTEXT *cx;
960 for (i = startingblock; i >= 0; i--) {
962 switch (cx->cx_type) {
966 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
974 dopoptoloop(I32 startingblock)
978 register PERL_CONTEXT *cx;
979 for (i = startingblock; i >= 0; i--) {
981 switch (cx->cx_type) {
984 warn("Exiting substitution via %s", op_name[op->op_type]);
988 warn("Exiting subroutine via %s", op_name[op->op_type]);
992 warn("Exiting eval via %s", op_name[op->op_type]);
996 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
999 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1010 register PERL_CONTEXT *cx;
1014 while (cxstack_ix > cxix) {
1015 cx = &cxstack[cxstack_ix];
1016 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1017 (long) cxstack_ix, block_type[cx->cx_type]));
1018 /* Note: we don't need to restore the base context info till the end. */
1019 switch (cx->cx_type) {
1022 continue; /* not break */
1040 die_where(char *message)
1045 register PERL_CONTEXT *cx;
1052 STRLEN klen = strlen(message);
1054 svp = hv_fetch(ERRHV, message, klen, TRUE);
1057 static char prefix[] = "\t(in cleanup) ";
1059 sv_upgrade(*svp, SVt_IV);
1060 (void)SvIOK_only(*svp);
1063 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1064 sv_catpvn(err, prefix, sizeof(prefix)-1);
1065 sv_catpvn(err, message, klen);
1071 sv_setpv(ERRSV, message);
1074 message = SvPVx(ERRSV, na);
1076 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
1084 if (cxix < cxstack_ix)
1088 if (cx->cx_type != CXt_EVAL) {
1089 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1094 if (gimme == G_SCALAR)
1095 *++newsp = &sv_undef;
1100 if (optype == OP_REQUIRE) {
1101 char* msg = SvPVx(ERRSV, na);
1102 DIE("%s", *msg ? msg : "Compilation failed in require");
1104 return pop_return();
1107 PerlIO_printf(PerlIO_stderr(), "%s",message);
1108 PerlIO_flush(PerlIO_stderr());
1117 if (SvTRUE(left) != SvTRUE(right))
1129 RETURNOP(cLOGOP->op_other);
1138 RETURNOP(cLOGOP->op_other);
1144 register I32 cxix = dopoptosub(cxstack_ix);
1145 register PERL_CONTEXT *cx;
1157 if (GIMME != G_ARRAY)
1161 if (DBsub && cxix >= 0 &&
1162 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1166 cxix = dopoptosub(cxix - 1);
1168 cx = &cxstack[cxix];
1169 if (cxstack[cxix].cx_type == CXt_SUB) {
1170 dbcxix = dopoptosub(cxix - 1);
1171 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1172 field below is defined for any cx. */
1173 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1174 cx = &cxstack[dbcxix];
1177 if (GIMME != G_ARRAY) {
1178 hv = cx->blk_oldcop->cop_stash;
1183 sv_setpv(TARG, HvNAME(hv));
1189 hv = cx->blk_oldcop->cop_stash;
1193 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1194 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1195 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1198 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1200 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1201 PUSHs(sv_2mortal(sv));
1202 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1205 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1206 PUSHs(sv_2mortal(newSViv(0)));
1208 gimme = (I32)cx->blk_gimme;
1209 if (gimme == G_VOID)
1212 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1213 if (cx->cx_type == CXt_EVAL) {
1214 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1215 PUSHs(cx->blk_eval.cur_text);
1218 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1219 /* Require, put the name. */
1220 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1224 else if (cx->cx_type == CXt_SUB &&
1225 cx->blk_sub.hasargs &&
1226 curcop->cop_stash == debstash)
1228 AV *ary = cx->blk_sub.argarray;
1229 int off = AvARRAY(ary) - AvALLOC(ary);
1233 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1236 AvREAL_off(dbargs); /* XXX Should be REIFY */
1239 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1240 av_extend(dbargs, AvFILLp(ary) + off);
1241 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1242 AvFILLp(dbargs) = AvFILLp(ary) + off;
1248 sortcv(SV *a, SV *b)
1251 I32 oldsaveix = savestack_ix;
1252 I32 oldscopeix = scopestack_ix;
1256 stack_sp = stack_base;
1259 if (stack_sp != stack_base + 1)
1260 croak("Sort subroutine didn't return single value");
1261 if (!SvNIOKp(*stack_sp))
1262 croak("Sort subroutine didn't return a numeric value");
1263 result = SvIV(*stack_sp);
1264 while (scopestack_ix > oldscopeix) {
1267 leave_scope(oldsaveix);
1280 sv_reset(tmps, curcop->cop_stash);
1293 TAINT_NOT; /* Each statement is presumed innocent */
1294 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1297 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1301 register PERL_CONTEXT *cx;
1302 I32 gimme = G_ARRAY;
1309 DIE("No DB::DB routine defined");
1311 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1323 push_return(op->op_next);
1324 PUSHBLOCK(cx, CXt_SUB, SP);
1327 (void)SvREFCNT_inc(cv);
1329 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1330 RETURNOP(CvSTART(cv));
1344 register PERL_CONTEXT *cx;
1345 I32 gimme = GIMME_V;
1352 if (op->op_flags & OPf_SPECIAL)
1353 svp = save_threadsv(op->op_targ); /* per-thread variable */
1355 #endif /* USE_THREADS */
1357 svp = &curpad[op->op_targ]; /* "my" variable */
1362 (void)save_scalar(gv);
1363 svp = &GvSV(gv); /* symbol table variable */
1368 PUSHBLOCK(cx, CXt_LOOP, SP);
1369 PUSHLOOP(cx, svp, MARK);
1370 if (op->op_flags & OPf_STACKED)
1371 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1373 cx->blk_loop.iterary = curstack;
1374 AvFILLp(curstack) = SP - stack_base;
1375 cx->blk_loop.iterix = MARK - stack_base;
1384 register PERL_CONTEXT *cx;
1385 I32 gimme = GIMME_V;
1391 PUSHBLOCK(cx, CXt_LOOP, SP);
1392 PUSHLOOP(cx, 0, SP);
1400 register PERL_CONTEXT *cx;
1401 struct block_loop cxloop;
1409 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1412 if (gimme == G_VOID)
1414 else if (gimme == G_SCALAR) {
1416 *++newsp = sv_mortalcopy(*SP);
1418 *++newsp = &sv_undef;
1422 *++newsp = sv_mortalcopy(*++mark);
1423 TAINT_NOT; /* Each item is independent */
1429 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1430 curpm = newpm; /* ... and pop $1 et al */
1442 register PERL_CONTEXT *cx;
1443 struct block_sub cxsub;
1444 bool popsub2 = FALSE;
1450 if (curstackinfo->si_type == SI_SORT) {
1451 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1452 if (cxstack_ix > sortcxix)
1454 AvARRAY(curstack)[1] = *SP;
1455 stack_sp = stack_base + 1;
1460 cxix = dopoptosub(cxstack_ix);
1462 DIE("Can't return outside a subroutine");
1463 if (cxix < cxstack_ix)
1467 switch (cx->cx_type) {
1469 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1474 if (optype == OP_REQUIRE &&
1475 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1477 /* Unassume the success we assumed earlier. */
1478 char *name = cx->blk_eval.old_name;
1479 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1480 DIE("%s did not return a true value", name);
1484 DIE("panic: return");
1488 if (gimme == G_SCALAR) {
1491 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1493 *++newsp = SvREFCNT_inc(*SP);
1498 *++newsp = sv_mortalcopy(*SP);
1501 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1503 *++newsp = sv_mortalcopy(*SP);
1505 *++newsp = &sv_undef;
1507 else if (gimme == G_ARRAY) {
1508 while (++MARK <= SP) {
1509 *++newsp = (popsub2 && SvTEMP(*MARK))
1510 ? *MARK : sv_mortalcopy(*MARK);
1511 TAINT_NOT; /* Each item is independent */
1516 /* Stack values are safe: */
1518 POPSUB2(); /* release CV and @_ ... */
1520 curpm = newpm; /* ... and pop $1 et al */
1523 return pop_return();
1530 register PERL_CONTEXT *cx;
1531 struct block_loop cxloop;
1532 struct block_sub cxsub;
1539 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1541 if (op->op_flags & OPf_SPECIAL) {
1542 cxix = dopoptoloop(cxstack_ix);
1544 DIE("Can't \"last\" outside a block");
1547 cxix = dopoptolabel(cPVOP->op_pv);
1549 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1551 if (cxix < cxstack_ix)
1555 switch (cx->cx_type) {
1557 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1559 nextop = cxloop.last_op->op_next;
1562 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1564 nextop = pop_return();
1568 nextop = pop_return();
1575 if (gimme == G_SCALAR) {
1577 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1578 ? *SP : sv_mortalcopy(*SP);
1580 *++newsp = &sv_undef;
1582 else if (gimme == G_ARRAY) {
1583 while (++MARK <= SP) {
1584 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1585 ? *MARK : sv_mortalcopy(*MARK);
1586 TAINT_NOT; /* Each item is independent */
1592 /* Stack values are safe: */
1595 POPLOOP2(); /* release loop vars ... */
1599 POPSUB2(); /* release CV and @_ ... */
1602 curpm = newpm; /* ... and pop $1 et al */
1611 register PERL_CONTEXT *cx;
1614 if (op->op_flags & OPf_SPECIAL) {
1615 cxix = dopoptoloop(cxstack_ix);
1617 DIE("Can't \"next\" outside a block");
1620 cxix = dopoptolabel(cPVOP->op_pv);
1622 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1624 if (cxix < cxstack_ix)
1628 oldsave = scopestack[scopestack_ix - 1];
1629 LEAVE_SCOPE(oldsave);
1630 return cx->blk_loop.next_op;
1636 register PERL_CONTEXT *cx;
1639 if (op->op_flags & OPf_SPECIAL) {
1640 cxix = dopoptoloop(cxstack_ix);
1642 DIE("Can't \"redo\" outside a block");
1645 cxix = dopoptolabel(cPVOP->op_pv);
1647 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1649 if (cxix < cxstack_ix)
1653 oldsave = scopestack[scopestack_ix - 1];
1654 LEAVE_SCOPE(oldsave);
1655 return cx->blk_loop.redo_op;
1659 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1663 static char too_deep[] = "Target of goto is too deeply nested";
1667 if (o->op_type == OP_LEAVE ||
1668 o->op_type == OP_SCOPE ||
1669 o->op_type == OP_LEAVELOOP ||
1670 o->op_type == OP_LEAVETRY)
1672 *ops++ = cUNOPo->op_first;
1677 if (o->op_flags & OPf_KIDS) {
1678 /* First try all the kids at this level, since that's likeliest. */
1679 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1680 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1681 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1684 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1685 if (kid == lastgotoprobe)
1687 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1689 (ops[-1]->op_type != OP_NEXTSTATE &&
1690 ops[-1]->op_type != OP_DBSTATE)))
1692 if (o = dofindlabel(kid, label, ops, oplimit))
1702 return pp_goto(ARGS);
1711 register PERL_CONTEXT *cx;
1712 #define GOTO_DEPTH 64
1713 OP *enterops[GOTO_DEPTH];
1715 int do_dump = (op->op_type == OP_DUMP);
1718 if (op->op_flags & OPf_STACKED) {
1721 /* This egregious kludge implements goto &subroutine */
1722 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1724 register PERL_CONTEXT *cx;
1725 CV* cv = (CV*)SvRV(sv);
1730 if (!CvROOT(cv) && !CvXSUB(cv)) {
1732 SV *tmpstr = sv_newmortal();
1733 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1734 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1736 DIE("Goto undefined subroutine");
1739 /* First do some returnish stuff. */
1740 cxix = dopoptosub(cxstack_ix);
1742 DIE("Can't goto subroutine outside a subroutine");
1743 if (cxix < cxstack_ix)
1746 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1747 DIE("Can't goto subroutine from an eval-string");
1749 if (cx->cx_type == CXt_SUB &&
1750 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1751 AV* av = cx->blk_sub.argarray;
1753 items = AvFILLp(av) + 1;
1755 EXTEND(stack_sp, items); /* @_ could have been extended. */
1756 Copy(AvARRAY(av), stack_sp, items, SV*);
1759 SvREFCNT_dec(GvAV(defgv));
1760 GvAV(defgv) = cx->blk_sub.savearray;
1761 #endif /* USE_THREADS */
1765 if (cx->cx_type == CXt_SUB &&
1766 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1767 SvREFCNT_dec(cx->blk_sub.cv);
1768 oldsave = scopestack[scopestack_ix - 1];
1769 LEAVE_SCOPE(oldsave);
1771 /* Now do some callish stuff. */
1774 if (CvOLDSTYLE(cv)) {
1775 I32 (*fp3)_((int,int,int));
1780 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1781 items = (*fp3)(CvXSUBANY(cv).any_i32,
1782 mark - stack_base + 1,
1784 SP = stack_base + items;
1787 stack_sp--; /* There is no cv arg. */
1788 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1791 return pop_return();
1794 AV* padlist = CvPADLIST(cv);
1795 SV** svp = AvARRAY(padlist);
1796 if (cx->cx_type == CXt_EVAL) {
1797 in_eval = cx->blk_eval.old_in_eval;
1798 eval_root = cx->blk_eval.old_eval_root;
1799 cx->cx_type = CXt_SUB;
1800 cx->blk_sub.hasargs = 0;
1802 cx->blk_sub.cv = cv;
1803 cx->blk_sub.olddepth = CvDEPTH(cv);
1805 if (CvDEPTH(cv) < 2)
1806 (void)SvREFCNT_inc(cv);
1807 else { /* save temporaries on recursion? */
1808 if (CvDEPTH(cv) == 100 && dowarn)
1809 sub_crush_depth(cv);
1810 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1811 AV *newpad = newAV();
1812 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1813 I32 ix = AvFILLp((AV*)svp[1]);
1814 svp = AvARRAY(svp[0]);
1815 for ( ;ix > 0; ix--) {
1816 if (svp[ix] != &sv_undef) {
1817 char *name = SvPVX(svp[ix]);
1818 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1821 /* outer lexical or anon code */
1822 av_store(newpad, ix,
1823 SvREFCNT_inc(oldpad[ix]) );
1825 else { /* our own lexical */
1827 av_store(newpad, ix, sv = (SV*)newAV());
1828 else if (*name == '%')
1829 av_store(newpad, ix, sv = (SV*)newHV());
1831 av_store(newpad, ix, sv = NEWSV(0,0));
1836 av_store(newpad, ix, sv = NEWSV(0,0));
1840 if (cx->blk_sub.hasargs) {
1843 av_store(newpad, 0, (SV*)av);
1844 AvFLAGS(av) = AVf_REIFY;
1846 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1847 AvFILLp(padlist) = CvDEPTH(cv);
1848 svp = AvARRAY(padlist);
1852 if (!cx->blk_sub.hasargs) {
1853 AV* av = (AV*)curpad[0];
1855 items = AvFILLp(av) + 1;
1857 /* Mark is at the end of the stack. */
1859 Copy(AvARRAY(av), SP + 1, items, SV*);
1864 #endif /* USE_THREADS */
1866 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1868 if (cx->blk_sub.hasargs)
1869 #endif /* USE_THREADS */
1871 AV* av = (AV*)curpad[0];
1875 cx->blk_sub.savearray = GvAV(defgv);
1876 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1877 #endif /* USE_THREADS */
1878 cx->blk_sub.argarray = av;
1881 if (items >= AvMAX(av) + 1) {
1883 if (AvARRAY(av) != ary) {
1884 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1885 SvPVX(av) = (char*)ary;
1887 if (items >= AvMAX(av) + 1) {
1888 AvMAX(av) = items - 1;
1889 Renew(ary,items+1,SV*);
1891 SvPVX(av) = (char*)ary;
1894 Copy(mark,AvARRAY(av),items,SV*);
1895 AvFILLp(av) = items - 1;
1903 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1905 * We do not care about using sv to call CV;
1906 * it's for informational purposes only.
1908 SV *sv = GvSV(DBsub);
1911 if (PERLDB_SUB_NN) {
1912 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1915 gv_efullname3(sv, CvGV(cv), Nullch);
1918 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1919 PUSHMARK( stack_sp );
1920 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1924 RETURNOP(CvSTART(cv));
1928 label = SvPV(sv,na);
1930 else if (op->op_flags & OPf_SPECIAL) {
1932 DIE("goto must have label");
1935 label = cPVOP->op_pv;
1937 if (label && *label) {
1944 for (ix = cxstack_ix; ix >= 0; ix--) {
1946 switch (cx->cx_type) {
1948 gotoprobe = eval_root; /* XXX not good for nested eval */
1951 gotoprobe = cx->blk_oldcop->op_sibling;
1957 gotoprobe = cx->blk_oldcop->op_sibling;
1959 gotoprobe = main_root;
1962 if (CvDEPTH(cx->blk_sub.cv)) {
1963 gotoprobe = CvROOT(cx->blk_sub.cv);
1968 DIE("Can't \"goto\" outside a block");
1972 gotoprobe = main_root;
1975 retop = dofindlabel(gotoprobe, label,
1976 enterops, enterops + GOTO_DEPTH);
1979 lastgotoprobe = gotoprobe;
1982 DIE("Can't find label %s", label);
1984 /* pop unwanted frames */
1986 if (ix < cxstack_ix) {
1993 oldsave = scopestack[scopestack_ix];
1994 LEAVE_SCOPE(oldsave);
1997 /* push wanted frames */
1999 if (*enterops && enterops[1]) {
2001 for (ix = 1; enterops[ix]; ix++) {
2003 /* Eventually we may want to stack the needed arguments
2004 * for each op. For now, we punt on the hard ones. */
2005 if (op->op_type == OP_ENTERITER)
2006 DIE("Can't \"goto\" into the middle of a foreach loop",
2008 (CALLOP->op_ppaddr)(ARGS);
2016 if (!retop) retop = main_start;
2023 restartop = 0; /* hmm, must be GNU unexec().. */
2027 if (top_env->je_prev) {
2045 if (anum == 1 && VMSISH_EXIT)
2058 double value = SvNVx(GvSV(cCOP->cop_gv));
2059 register I32 match = I_32(value);
2062 if (((double)match) > value)
2063 --match; /* was fractional--truncate other way */
2065 match -= cCOP->uop.scop.scop_offset;
2068 else if (match > cCOP->uop.scop.scop_max)
2069 match = cCOP->uop.scop.scop_max;
2070 op = cCOP->uop.scop.scop_next[match];
2080 op = op->op_next; /* can't assume anything */
2082 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2083 match -= cCOP->uop.scop.scop_offset;
2086 else if (match > cCOP->uop.scop.scop_max)
2087 match = cCOP->uop.scop.scop_max;
2088 op = cCOP->uop.scop.scop_next[match];
2097 save_lines(AV *array, SV *sv)
2099 register char *s = SvPVX(sv);
2100 register char *send = SvPVX(sv) + SvCUR(sv);
2102 register I32 line = 1;
2104 while (s && s < send) {
2105 SV *tmpstr = NEWSV(85,0);
2107 sv_upgrade(tmpstr, SVt_PVMG);
2108 t = strchr(s, '\n');
2114 sv_setpvn(tmpstr, s, t - s);
2115 av_store(array, line++, tmpstr);
2130 assert(CATCH_GET == TRUE);
2131 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2135 default: /* topmost level handles it */
2142 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2158 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2159 /* sv Text to convert to OP tree. */
2160 /* startop op_free() this to undo. */
2161 /* code Short string id of the caller. */
2163 dSP; /* Make POPBLOCK work. */
2166 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2170 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2176 /* switch to eval mode */
2178 SAVESPTR(compiling.cop_filegv);
2179 SAVEI16(compiling.cop_line);
2180 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2181 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2182 compiling.cop_line = 1;
2183 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2184 deleting the eval's FILEGV from the stash before gv_check() runs
2185 (i.e. before run-time proper). To work around the coredump that
2186 ensues, we always turn GvMULTI_on for any globals that were
2187 introduced within evals. See force_ident(). GSAR 96-10-12 */
2188 safestr = savepv(tmpbuf);
2189 SAVEDELETE(defstash, safestr, strlen(safestr));
2191 #ifdef OP_IN_REGISTER
2199 op->op_type = 0; /* Avoid uninit warning. */
2200 op->op_flags = 0; /* Avoid uninit warning. */
2201 PUSHBLOCK(cx, CXt_EVAL, SP);
2202 PUSHEVAL(cx, 0, compiling.cop_filegv);
2203 rop = doeval(G_SCALAR, startop);
2207 (*startop)->op_type = OP_NULL;
2208 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2210 *avp = (AV*)SvREFCNT_inc(comppad);
2212 #ifdef OP_IN_REGISTER
2218 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2220 doeval(int gimme, OP** startop)
2233 /* set up a scratch pad */
2238 SAVESPTR(comppad_name);
2239 SAVEI32(comppad_name_fill);
2240 SAVEI32(min_intro_pending);
2241 SAVEI32(max_intro_pending);
2244 for (i = cxstack_ix - 1; i >= 0; i--) {
2245 PERL_CONTEXT *cx = &cxstack[i];
2246 if (cx->cx_type == CXt_EVAL)
2248 else if (cx->cx_type == CXt_SUB) {
2249 caller = cx->blk_sub.cv;
2255 compcv = (CV*)NEWSV(1104,0);
2256 sv_upgrade((SV *)compcv, SVt_PVCV);
2257 CvUNIQUE_on(compcv);
2259 CvOWNER(compcv) = 0;
2260 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2261 MUTEX_INIT(CvMUTEXP(compcv));
2262 #endif /* USE_THREADS */
2265 av_push(comppad, Nullsv);
2266 curpad = AvARRAY(comppad);
2267 comppad_name = newAV();
2268 comppad_name_fill = 0;
2269 min_intro_pending = 0;
2272 av_store(comppad_name, 0, newSVpv("@_", 2));
2273 curpad[0] = (SV*)newAV();
2274 SvPADMY_on(curpad[0]); /* XXX Needed? */
2275 #endif /* USE_THREADS */
2277 comppadlist = newAV();
2278 AvREAL_off(comppadlist);
2279 av_store(comppadlist, 0, (SV*)comppad_name);
2280 av_store(comppadlist, 1, (SV*)comppad);
2281 CvPADLIST(compcv) = comppadlist;
2283 if (!saveop || saveop->op_type != OP_REQUIRE)
2284 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2288 /* make sure we compile in the right package */
2290 newstash = curcop->cop_stash;
2291 if (curstash != newstash) {
2293 curstash = newstash;
2297 SAVEFREESV(beginav);
2299 /* try to compile it */
2303 curcop = &compiling;
2304 curcop->cop_arybase = 0;
2306 rs = newSVpv("\n", 1);
2307 if (saveop && saveop->op_flags & OPf_SPECIAL)
2311 if (yyparse() || error_count || !eval_root) {
2315 I32 optype = 0; /* Might be reset by POPEVAL. */
2322 SP = stack_base + POPMARK; /* pop original mark */
2330 if (optype == OP_REQUIRE) {
2331 char* msg = SvPVx(ERRSV, na);
2332 DIE("%s", *msg ? msg : "Compilation failed in require");
2333 } else if (startop) {
2334 char* msg = SvPVx(ERRSV, na);
2338 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2341 rs = SvREFCNT_inc(nrs);
2343 MUTEX_LOCK(&eval_mutex);
2345 COND_SIGNAL(&eval_cond);
2346 MUTEX_UNLOCK(&eval_mutex);
2347 #endif /* USE_THREADS */
2351 rs = SvREFCNT_inc(nrs);
2352 compiling.cop_line = 0;
2354 *startop = eval_root;
2355 SvREFCNT_dec(CvOUTSIDE(compcv));
2356 CvOUTSIDE(compcv) = Nullcv;
2358 SAVEFREEOP(eval_root);
2360 scalarvoid(eval_root);
2361 else if (gimme & G_ARRAY)
2366 DEBUG_x(dump_eval());
2368 /* Register with debugger: */
2369 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2370 CV *cv = perl_get_cv("DB::postponed", FALSE);
2374 XPUSHs((SV*)compiling.cop_filegv);
2376 perl_call_sv((SV*)cv, G_DISCARD);
2380 /* compiled okay, so do it */
2382 CvDEPTH(compcv) = 1;
2383 SP = stack_base + POPMARK; /* pop original mark */
2384 op = saveop; /* The caller may need it. */
2386 MUTEX_LOCK(&eval_mutex);
2388 COND_SIGNAL(&eval_cond);
2389 MUTEX_UNLOCK(&eval_mutex);
2390 #endif /* USE_THREADS */
2392 RETURNOP(eval_start);
2398 register PERL_CONTEXT *cx;
2403 SV *namesv = Nullsv;
2405 I32 gimme = G_SCALAR;
2406 PerlIO *tryrsfp = 0;
2409 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2410 SET_NUMERIC_STANDARD();
2411 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2412 DIE("Perl %s required--this is only version %s, stopped",
2413 SvPV(sv,na),patchlevel);
2416 name = SvPV(sv, len);
2417 if (!(name && len > 0 && *name))
2418 DIE("Null filename used");
2419 TAINT_PROPER("require");
2420 if (op->op_type == OP_REQUIRE &&
2421 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2425 /* prepare to compile file */
2430 (name[1] == '.' && name[2] == '/')))
2432 || (name[0] && name[1] == ':')
2435 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2438 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2439 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2444 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2447 AV *ar = GvAVn(incgv);
2451 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2454 namesv = NEWSV(806, 0);
2455 for (i = 0; i <= AvFILL(ar); i++) {
2456 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2459 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2461 sv_setpv(namesv, unixdir);
2462 sv_catpv(namesv, unixname);
2464 sv_setpvf(namesv, "%s/%s", dir, name);
2466 tryname = SvPVX(namesv);
2467 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2469 if (tryname[0] == '.' && tryname[1] == '/')
2476 SAVESPTR(compiling.cop_filegv);
2477 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2478 SvREFCNT_dec(namesv);
2480 if (op->op_type == OP_REQUIRE) {
2481 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2482 SV *dirmsgsv = NEWSV(0, 0);
2483 AV *ar = GvAVn(incgv);
2485 if (instr(SvPVX(msg), ".h "))
2486 sv_catpv(msg, " (change .h to .ph maybe?)");
2487 if (instr(SvPVX(msg), ".ph "))
2488 sv_catpv(msg, " (did you run h2ph?)");
2489 sv_catpv(msg, " (@INC contains:");
2490 for (i = 0; i <= AvFILL(ar); i++) {
2491 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2492 sv_setpvf(dirmsgsv, " %s", dir);
2493 sv_catsv(msg, dirmsgsv);
2495 sv_catpvn(msg, ")", 1);
2496 SvREFCNT_dec(dirmsgsv);
2503 /* Assume success here to prevent recursive requirement. */
2504 (void)hv_store(GvHVn(incgv), name, strlen(name),
2505 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2509 lex_start(sv_2mortal(newSVpv("",0)));
2511 save_aptr(&rsfp_filters);
2512 rsfp_filters = NULL;
2516 name = savepv(name);
2521 /* switch to eval mode */
2523 push_return(op->op_next);
2524 PUSHBLOCK(cx, CXt_EVAL, SP);
2525 PUSHEVAL(cx, name, compiling.cop_filegv);
2527 compiling.cop_line = 0;
2531 MUTEX_LOCK(&eval_mutex);
2532 if (eval_owner && eval_owner != thr)
2534 COND_WAIT(&eval_cond, &eval_mutex);
2536 MUTEX_UNLOCK(&eval_mutex);
2537 #endif /* USE_THREADS */
2538 return DOCATCH(doeval(G_SCALAR, NULL));
2543 return pp_require(ARGS);
2549 register PERL_CONTEXT *cx;
2551 I32 gimme = GIMME_V, was = sub_generation;
2552 char tmpbuf[TYPE_DIGITS(long) + 12];
2557 if (!SvPV(sv,len) || !len)
2559 TAINT_PROPER("eval");
2565 /* switch to eval mode */
2567 SAVESPTR(compiling.cop_filegv);
2568 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2569 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2570 compiling.cop_line = 1;
2571 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2572 deleting the eval's FILEGV from the stash before gv_check() runs
2573 (i.e. before run-time proper). To work around the coredump that
2574 ensues, we always turn GvMULTI_on for any globals that were
2575 introduced within evals. See force_ident(). GSAR 96-10-12 */
2576 safestr = savepv(tmpbuf);
2577 SAVEDELETE(defstash, safestr, strlen(safestr));
2579 hints = op->op_targ;
2581 push_return(op->op_next);
2582 PUSHBLOCK(cx, CXt_EVAL, SP);
2583 PUSHEVAL(cx, 0, compiling.cop_filegv);
2585 /* prepare to compile string */
2587 if (PERLDB_LINE && curstash != debstash)
2588 save_lines(GvAV(compiling.cop_filegv), linestr);
2591 MUTEX_LOCK(&eval_mutex);
2592 if (eval_owner && eval_owner != thr)
2594 COND_WAIT(&eval_cond, &eval_mutex);
2596 MUTEX_UNLOCK(&eval_mutex);
2597 #endif /* USE_THREADS */
2598 ret = doeval(gimme, NULL);
2599 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2600 && ret != op->op_next) { /* Successive compilation. */
2601 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2603 return DOCATCH(ret);
2613 register PERL_CONTEXT *cx;
2615 U8 save_flags = op -> op_flags;
2620 retop = pop_return();
2623 if (gimme == G_VOID)
2625 else if (gimme == G_SCALAR) {
2628 if (SvFLAGS(TOPs) & SVs_TEMP)
2631 *MARK = sv_mortalcopy(TOPs);
2639 /* in case LEAVE wipes old return values */
2640 for (mark = newsp + 1; mark <= SP; mark++) {
2641 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2642 *mark = sv_mortalcopy(*mark);
2643 TAINT_NOT; /* Each item is independent */
2647 curpm = newpm; /* Don't pop $1 et al till now */
2650 * Closures mentioned at top level of eval cannot be referenced
2651 * again, and their presence indirectly causes a memory leak.
2652 * (Note that the fact that compcv and friends are still set here
2653 * is, AFAIK, an accident.) --Chip
2655 if (AvFILLp(comppad_name) >= 0) {
2656 SV **svp = AvARRAY(comppad_name);
2658 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2660 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2662 svp[ix] = &sv_undef;
2666 SvREFCNT_dec(CvOUTSIDE(sv));
2667 CvOUTSIDE(sv) = Nullcv;
2680 assert(CvDEPTH(compcv) == 1);
2682 CvDEPTH(compcv) = 0;
2685 if (optype == OP_REQUIRE &&
2686 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2688 /* Unassume the success we assumed earlier. */
2689 char *name = cx->blk_eval.old_name;
2690 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2691 retop = die("%s did not return a true value", name);
2692 /* die_where() did LEAVE, or we won't be here */
2696 if (!(save_flags & OPf_SPECIAL))
2706 register PERL_CONTEXT *cx;
2707 I32 gimme = GIMME_V;
2712 push_return(cLOGOP->op_other->op_next);
2713 PUSHBLOCK(cx, CXt_EVAL, SP);
2715 eval_root = op; /* Only needed so that goto works right. */
2720 return DOCATCH(op->op_next);
2730 register PERL_CONTEXT *cx;
2738 if (gimme == G_VOID)
2740 else if (gimme == G_SCALAR) {
2743 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2746 *MARK = sv_mortalcopy(TOPs);
2755 /* in case LEAVE wipes old return values */
2756 for (mark = newsp + 1; mark <= SP; mark++) {
2757 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2758 *mark = sv_mortalcopy(*mark);
2759 TAINT_NOT; /* Each item is independent */
2763 curpm = newpm; /* Don't pop $1 et al till now */
2774 register char *s = SvPV_force(sv, len);
2775 register char *send = s + len;
2776 register char *base;
2777 register I32 skipspaces = 0;
2780 bool postspace = FALSE;
2788 croak("Null picture in formline");
2790 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2795 *fpc++ = FF_LINEMARK;
2796 noblank = repeat = FALSE;
2814 case ' ': case '\t':
2825 *fpc++ = FF_LITERAL;
2833 *fpc++ = skipspaces;
2837 *fpc++ = FF_NEWLINE;
2841 arg = fpc - linepc + 1;
2848 *fpc++ = FF_LINEMARK;
2849 noblank = repeat = FALSE;
2858 ischop = s[-1] == '^';
2864 arg = (s - base) - 1;
2866 *fpc++ = FF_LITERAL;
2875 *fpc++ = FF_LINEGLOB;
2877 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2878 arg = ischop ? 512 : 0;
2888 arg |= 256 + (s - f);
2890 *fpc++ = s - base; /* fieldsize for FETCH */
2891 *fpc++ = FF_DECIMAL;
2896 bool ismore = FALSE;
2899 while (*++s == '>') ;
2900 prespace = FF_SPACE;
2902 else if (*s == '|') {
2903 while (*++s == '|') ;
2904 prespace = FF_HALFSPACE;
2909 while (*++s == '<') ;
2912 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2916 *fpc++ = s - base; /* fieldsize for FETCH */
2918 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2936 { /* need to jump to the next word */
2938 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2939 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2940 s = SvPVX(sv) + SvCUR(sv) + z;
2942 Copy(fops, s, arg, U16);
2944 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2949 * The rest of this file was derived from source code contributed
2952 * NOTE: this code was derived from Tom Horsley's qsort replacement
2953 * and should not be confused with the original code.
2956 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2958 Permission granted to distribute under the same terms as perl which are
2961 This program is free software; you can redistribute it and/or modify
2962 it under the terms of either:
2964 a) the GNU General Public License as published by the Free
2965 Software Foundation; either version 1, or (at your option) any
2968 b) the "Artistic License" which comes with this Kit.
2970 Details on the perl license can be found in the perl source code which
2971 may be located via the www.perl.com web page.
2973 This is the most wonderfulest possible qsort I can come up with (and
2974 still be mostly portable) My (limited) tests indicate it consistently
2975 does about 20% fewer calls to compare than does the qsort in the Visual
2976 C++ library, other vendors may vary.
2978 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2979 others I invented myself (or more likely re-invented since they seemed
2980 pretty obvious once I watched the algorithm operate for a while).
2982 Most of this code was written while watching the Marlins sweep the Giants
2983 in the 1997 National League Playoffs - no Braves fans allowed to use this
2984 code (just kidding :-).
2986 I realize that if I wanted to be true to the perl tradition, the only
2987 comment in this file would be something like:
2989 ...they shuffled back towards the rear of the line. 'No, not at the
2990 rear!' the slave-driver shouted. 'Three files up. And stay there...
2992 However, I really needed to violate that tradition just so I could keep
2993 track of what happens myself, not to mention some poor fool trying to
2994 understand this years from now :-).
2997 /* ********************************************************** Configuration */
2999 #ifndef QSORT_ORDER_GUESS
3000 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3003 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3004 future processing - a good max upper bound is log base 2 of memory size
3005 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3006 safely be smaller than that since the program is taking up some space and
3007 most operating systems only let you grab some subset of contiguous
3008 memory (not to mention that you are normally sorting data larger than
3009 1 byte element size :-).
3011 #ifndef QSORT_MAX_STACK
3012 #define QSORT_MAX_STACK 32
3015 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3016 Anything bigger and we use qsort. If you make this too small, the qsort
3017 will probably break (or become less efficient), because it doesn't expect
3018 the middle element of a partition to be the same as the right or left -
3019 you have been warned).
3021 #ifndef QSORT_BREAK_EVEN
3022 #define QSORT_BREAK_EVEN 6
3025 /* ************************************************************* Data Types */
3027 /* hold left and right index values of a partition waiting to be sorted (the
3028 partition includes both left and right - right is NOT one past the end or
3029 anything like that).
3031 struct partition_stack_entry {
3034 #ifdef QSORT_ORDER_GUESS
3035 int qsort_break_even;
3039 /* ******************************************************* Shorthand Macros */
3041 /* Note that these macros will be used from inside the qsort function where
3042 we happen to know that the variable 'elt_size' contains the size of an
3043 array element and the variable 'temp' points to enough space to hold a
3044 temp element and the variable 'array' points to the array being sorted
3045 and 'compare' is the pointer to the compare routine.
3047 Also note that there are very many highly architecture specific ways
3048 these might be sped up, but this is simply the most generally portable
3049 code I could think of.
3052 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3055 #define qsort_cmp(elt1, elt2) \
3056 ((this->*compare)(array[elt1], array[elt2]))
3058 #define qsort_cmp(elt1, elt2) \
3059 ((*compare)(array[elt1], array[elt2]))
3062 #ifdef QSORT_ORDER_GUESS
3063 #define QSORT_NOTICE_SWAP swapped++;
3065 #define QSORT_NOTICE_SWAP
3068 /* swaps contents of array elements elt1, elt2.
3070 #define qsort_swap(elt1, elt2) \
3073 temp = array[elt1]; \
3074 array[elt1] = array[elt2]; \
3075 array[elt2] = temp; \
3078 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3079 elt3 and elt3 gets elt1.
3081 #define qsort_rotate(elt1, elt2, elt3) \
3084 temp = array[elt1]; \
3085 array[elt1] = array[elt2]; \
3086 array[elt2] = array[elt3]; \
3087 array[elt3] = temp; \
3090 /* ************************************************************ Debug stuff */
3097 return; /* good place to set a breakpoint */
3100 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3103 doqsort_all_asserts(
3107 int (*compare)(const void * elt1, const void * elt2),
3108 int pc_left, int pc_right, int u_left, int u_right)
3112 qsort_assert(pc_left <= pc_right);
3113 qsort_assert(u_right < pc_left);
3114 qsort_assert(pc_right < u_left);
3115 for (i = u_right + 1; i < pc_left; ++i) {
3116 qsort_assert(qsort_cmp(i, pc_left) < 0);
3118 for (i = pc_left; i < pc_right; ++i) {
3119 qsort_assert(qsort_cmp(i, pc_right) == 0);
3121 for (i = pc_right + 1; i < u_left; ++i) {
3122 qsort_assert(qsort_cmp(pc_right, i) < 0);
3126 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3127 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3128 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3132 #define qsort_assert(t) ((void)0)
3134 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3138 /* ****************************************************************** qsort */
3142 qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3147 I32 (*compare)(SV *a, SV *b))
3152 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3153 int next_stack_entry = 0;
3157 #ifdef QSORT_ORDER_GUESS
3158 int qsort_break_even;
3162 /* Make sure we actually have work to do.
3164 if (num_elts <= 1) {
3168 /* Setup the initial partition definition and fall into the sorting loop
3171 part_right = (int)(num_elts - 1);
3172 #ifdef QSORT_ORDER_GUESS
3173 qsort_break_even = QSORT_BREAK_EVEN;
3175 #define qsort_break_even QSORT_BREAK_EVEN
3178 if ((part_right - part_left) >= qsort_break_even) {
3179 /* OK, this is gonna get hairy, so lets try to document all the
3180 concepts and abbreviations and variables and what they keep
3183 pc: pivot chunk - the set of array elements we accumulate in the
3184 middle of the partition, all equal in value to the original
3185 pivot element selected. The pc is defined by:
3187 pc_left - the leftmost array index of the pc
3188 pc_right - the rightmost array index of the pc
3190 we start with pc_left == pc_right and only one element
3191 in the pivot chunk (but it can grow during the scan).
3193 u: uncompared elements - the set of elements in the partition
3194 we have not yet compared to the pivot value. There are two
3195 uncompared sets during the scan - one to the left of the pc
3196 and one to the right.
3198 u_right - the rightmost index of the left side's uncompared set
3199 u_left - the leftmost index of the right side's uncompared set
3201 The leftmost index of the left sides's uncompared set
3202 doesn't need its own variable because it is always defined
3203 by the leftmost edge of the whole partition (part_left). The
3204 same goes for the rightmost edge of the right partition
3207 We know there are no uncompared elements on the left once we
3208 get u_right < part_left and no uncompared elements on the
3209 right once u_left > part_right. When both these conditions
3210 are met, we have completed the scan of the partition.
3212 Any elements which are between the pivot chunk and the
3213 uncompared elements should be less than the pivot value on
3214 the left side and greater than the pivot value on the right
3215 side (in fact, the goal of the whole algorithm is to arrange
3216 for that to be true and make the groups of less-than and
3217 greater-then elements into new partitions to sort again).
3219 As you marvel at the complexity of the code and wonder why it
3220 has to be so confusing. Consider some of the things this level
3221 of confusion brings:
3223 Once I do a compare, I squeeze every ounce of juice out of it. I
3224 never do compare calls I don't have to do, and I certainly never
3227 I also never swap any elements unless I can prove there is a
3228 good reason. Many sort algorithms will swap a known value with
3229 an uncompared value just to get things in the right place (or
3230 avoid complexity :-), but that uncompared value, once it gets
3231 compared, may then have to be swapped again. A lot of the
3232 complexity of this code is due to the fact that it never swaps
3233 anything except compared values, and it only swaps them when the
3234 compare shows they are out of position.
3236 int pc_left, pc_right;
3237 int u_right, u_left;
3241 pc_left = ((part_left + part_right) / 2);
3243 u_right = pc_left - 1;
3244 u_left = pc_right + 1;
3246 /* Qsort works best when the pivot value is also the median value
3247 in the partition (unfortunately you can't find the median value
3248 without first sorting :-), so to give the algorithm a helping
3249 hand, we pick 3 elements and sort them and use the median value
3250 of that tiny set as the pivot value.
3252 Some versions of qsort like to use the left middle and right as
3253 the 3 elements to sort so they can insure the ends of the
3254 partition will contain values which will stop the scan in the
3255 compare loop, but when you have to call an arbitrarily complex
3256 routine to do a compare, its really better to just keep track of
3257 array index values to know when you hit the edge of the
3258 partition and avoid the extra compare. An even better reason to
3259 avoid using a compare call is the fact that you can drop off the
3260 edge of the array if someone foolishly provides you with an
3261 unstable compare function that doesn't always provide consistent
3264 So, since it is simpler for us to compare the three adjacent
3265 elements in the middle of the partition, those are the ones we
3266 pick here (conveniently pointed at by u_right, pc_left, and
3267 u_left). The values of the left, center, and right elements
3268 are refered to as l c and r in the following comments.
3271 #ifdef QSORT_ORDER_GUESS
3274 s = qsort_cmp(u_right, pc_left);
3277 s = qsort_cmp(pc_left, u_left);
3278 /* if l < c, c < r - already in order - nothing to do */
3280 /* l < c, c == r - already in order, pc grows */
3282 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3284 /* l < c, c > r - need to know more */
3285 s = qsort_cmp(u_right, u_left);
3287 /* l < c, c > r, l < r - swap c & r to get ordered */
3288 qsort_swap(pc_left, u_left);
3289 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3290 } else if (s == 0) {
3291 /* l < c, c > r, l == r - swap c&r, grow pc */
3292 qsort_swap(pc_left, u_left);
3294 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3296 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3297 qsort_rotate(pc_left, u_right, u_left);
3298 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3301 } else if (s == 0) {
3303 s = qsort_cmp(pc_left, u_left);
3305 /* l == c, c < r - already in order, grow pc */
3307 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3308 } else if (s == 0) {
3309 /* l == c, c == r - already in order, grow pc both ways */
3312 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3314 /* l == c, c > r - swap l & r, grow pc */
3315 qsort_swap(u_right, u_left);
3317 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3321 s = qsort_cmp(pc_left, u_left);
3323 /* l > c, c < r - need to know more */
3324 s = qsort_cmp(u_right, u_left);
3326 /* l > c, c < r, l < r - swap l & c to get ordered */
3327 qsort_swap(u_right, pc_left);
3328 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3329 } else if (s == 0) {
3330 /* l > c, c < r, l == r - swap l & c, grow pc */
3331 qsort_swap(u_right, pc_left);
3333 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3335 /* l > c, c < r, l > r - rotate lcr into crl to order */
3336 qsort_rotate(u_right, pc_left, u_left);
3337 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3339 } else if (s == 0) {
3340 /* l > c, c == r - swap ends, grow pc */
3341 qsort_swap(u_right, u_left);
3343 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3345 /* l > c, c > r - swap ends to get in order */
3346 qsort_swap(u_right, u_left);
3347 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3350 /* We now know the 3 middle elements have been compared and
3351 arranged in the desired order, so we can shrink the uncompared
3356 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3358 /* The above massive nested if was the simple part :-). We now have
3359 the middle 3 elements ordered and we need to scan through the
3360 uncompared sets on either side, swapping elements that are on
3361 the wrong side or simply shuffling equal elements around to get
3362 all equal elements into the pivot chunk.
3366 int still_work_on_left;
3367 int still_work_on_right;
3369 /* Scan the uncompared values on the left. If I find a value
3370 equal to the pivot value, move it over so it is adjacent to
3371 the pivot chunk and expand the pivot chunk. If I find a value
3372 less than the pivot value, then just leave it - its already
3373 on the correct side of the partition. If I find a greater
3374 value, then stop the scan.
3376 while (still_work_on_left = (u_right >= part_left)) {
3377 s = qsort_cmp(u_right, pc_left);
3380 } else if (s == 0) {
3382 if (pc_left != u_right) {
3383 qsort_swap(u_right, pc_left);
3389 qsort_assert(u_right < pc_left);
3390 qsort_assert(pc_left <= pc_right);
3391 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3392 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3395 /* Do a mirror image scan of uncompared values on the right
3397 while (still_work_on_right = (u_left <= part_right)) {
3398 s = qsort_cmp(pc_right, u_left);
3401 } else if (s == 0) {
3403 if (pc_right != u_left) {
3404 qsort_swap(pc_right, u_left);
3410 qsort_assert(u_left > pc_right);
3411 qsort_assert(pc_left <= pc_right);
3412 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3413 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3416 if (still_work_on_left) {
3417 /* I know I have a value on the left side which needs to be
3418 on the right side, but I need to know more to decide
3419 exactly the best thing to do with it.
3421 if (still_work_on_right) {
3422 /* I know I have values on both side which are out of
3423 position. This is a big win because I kill two birds
3424 with one swap (so to speak). I can advance the
3425 uncompared pointers on both sides after swapping both
3426 of them into the right place.
3428 qsort_swap(u_right, u_left);
3431 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3433 /* I have an out of position value on the left, but the
3434 right is fully scanned, so I "slide" the pivot chunk
3435 and any less-than values left one to make room for the
3436 greater value over on the right. If the out of position
3437 value is immediately adjacent to the pivot chunk (there
3438 are no less-than values), I can do that with a swap,
3439 otherwise, I have to rotate one of the less than values
3440 into the former position of the out of position value
3441 and the right end of the pivot chunk into the left end
3445 if (pc_left == u_right) {
3446 qsort_swap(u_right, pc_right);
3447 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3449 qsort_rotate(u_right, pc_left, pc_right);
3450 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3455 } else if (still_work_on_right) {
3456 /* Mirror image of complex case above: I have an out of
3457 position value on the right, but the left is fully
3458 scanned, so I need to shuffle things around to make room
3459 for the right value on the left.
3462 if (pc_right == u_left) {
3463 qsort_swap(u_left, pc_left);
3464 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3466 qsort_rotate(pc_right, pc_left, u_left);
3467 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3472 /* No more scanning required on either side of partition,
3473 break out of loop and figure out next set of partitions
3479 /* The elements in the pivot chunk are now in the right place. They
3480 will never move or be compared again. All I have to do is decide
3481 what to do with the stuff to the left and right of the pivot
3484 Notes on the QSORT_ORDER_GUESS ifdef code:
3486 1. If I just built these partitions without swapping any (or
3487 very many) elements, there is a chance that the elements are
3488 already ordered properly (being properly ordered will
3489 certainly result in no swapping, but the converse can't be
3492 2. A (properly written) insertion sort will run faster on
3493 already ordered data than qsort will.
3495 3. Perhaps there is some way to make a good guess about
3496 switching to an insertion sort earlier than partition size 6
3497 (for instance - we could save the partition size on the stack
3498 and increase the size each time we find we didn't swap, thus
3499 switching to insertion sort earlier for partitions with a
3500 history of not swapping).
3502 4. Naturally, if I just switch right away, it will make
3503 artificial benchmarks with pure ascending (or descending)
3504 data look really good, but is that a good reason in general?
3508 #ifdef QSORT_ORDER_GUESS
3510 #if QSORT_ORDER_GUESS == 1
3511 qsort_break_even = (part_right - part_left) + 1;
3513 #if QSORT_ORDER_GUESS == 2
3514 qsort_break_even *= 2;
3516 #if QSORT_ORDER_GUESS == 3
3517 int prev_break = qsort_break_even;
3518 qsort_break_even *= qsort_break_even;
3519 if (qsort_break_even < prev_break) {
3520 qsort_break_even = (part_right - part_left) + 1;
3524 qsort_break_even = QSORT_BREAK_EVEN;
3528 if (part_left < pc_left) {
3529 /* There are elements on the left which need more processing.
3530 Check the right as well before deciding what to do.
3532 if (pc_right < part_right) {
3533 /* We have two partitions to be sorted. Stack the biggest one
3534 and process the smallest one on the next iteration. This
3535 minimizes the stack height by insuring that any additional
3536 stack entries must come from the smallest partition which
3537 (because it is smallest) will have the fewest
3538 opportunities to generate additional stack entries.
3540 if ((part_right - pc_right) > (pc_left - part_left)) {
3541 /* stack the right partition, process the left */
3542 partition_stack[next_stack_entry].left = pc_right + 1;
3543 partition_stack[next_stack_entry].right = part_right;
3544 #ifdef QSORT_ORDER_GUESS
3545 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3547 part_right = pc_left - 1;
3549 /* stack the left partition, process the right */
3550 partition_stack[next_stack_entry].left = part_left;
3551 partition_stack[next_stack_entry].right = pc_left - 1;
3552 #ifdef QSORT_ORDER_GUESS
3553 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3555 part_left = pc_right + 1;
3557 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3560 /* The elements on the left are the only remaining elements
3561 that need sorting, arrange for them to be processed as the
3564 part_right = pc_left - 1;
3566 } else if (pc_right < part_right) {
3567 /* There is only one chunk on the right to be sorted, make it
3568 the new partition and loop back around.
3570 part_left = pc_right + 1;
3572 /* This whole partition wound up in the pivot chunk, so
3573 we need to get a new partition off the stack.
3575 if (next_stack_entry == 0) {
3576 /* the stack is empty - we are done */
3580 part_left = partition_stack[next_stack_entry].left;
3581 part_right = partition_stack[next_stack_entry].right;
3582 #ifdef QSORT_ORDER_GUESS
3583 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3587 /* This partition is too small to fool with qsort complexity, just
3588 do an ordinary insertion sort to minimize overhead.
3591 /* Assume 1st element is in right place already, and start checking
3592 at 2nd element to see where it should be inserted.
3594 for (i = part_left + 1; i <= part_right; ++i) {
3596 /* Scan (backwards - just in case 'i' is already in right place)
3597 through the elements already sorted to see if the ith element
3598 belongs ahead of one of them.
3600 for (j = i - 1; j >= part_left; --j) {
3601 if (qsort_cmp(i, j) >= 0) {
3602 /* i belongs right after j
3609 /* Looks like we really need to move some things
3613 for (k = i - 1; k >= j; --k)
3614 array[k + 1] = array[k];
3619 /* That partition is now sorted, grab the next one, or get out
3620 of the loop if there aren't any more.
3623 if (next_stack_entry == 0) {
3624 /* the stack is empty - we are done */
3628 part_left = partition_stack[next_stack_entry].left;
3629 part_right = partition_stack[next_stack_entry].right;
3630 #ifdef QSORT_ORDER_GUESS
3631 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3636 /* Believe it or not, the array is sorted at this point! */