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))
28 static OP *docatch _((OP *o));
29 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
30 static void doparseform _((SV *sv));
31 static I32 dopoptoeval _((I32 startingblock));
32 static I32 dopoptolabel _((char *label));
33 static I32 dopoptoloop _((I32 startingblock));
34 static I32 dopoptosub _((I32 startingblock));
35 static void save_lines _((AV *array, SV *sv));
36 static I32 sortcv _((SV *a, SV *b));
37 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
38 static OP *doeval _((int gimme, OP** startop));
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
69 register PMOP *pm = (PMOP*)cLOGOP->op_other;
73 MAGIC *mg = Null(MAGIC*);
77 SV *sv = SvRV(tmpstr);
79 mg = mg_find(sv, 'r');
82 regexp *re = (regexp *)mg->mg_obj;
83 ReREFCNT_dec(pm->op_pmregexp);
84 pm->op_pmregexp = ReREFCNT_inc(re);
87 t = SvPV(tmpstr, len);
89 /* Check against the last compiled regexp. */
90 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
91 pm->op_pmregexp->prelen != len ||
92 memNE(pm->op_pmregexp->precomp, t, len))
94 if (pm->op_pmregexp) {
95 ReREFCNT_dec(pm->op_pmregexp);
96 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
99 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
100 pm->op_pmregexp = pregcomp(t, t + len, pm);
104 if (!pm->op_pmregexp->prelen && curpm)
106 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
107 pm->op_pmflags |= PMf_WHITE;
109 if (pm->op_pmflags & PMf_KEEP) {
110 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
111 cLOGOP->op_first->op_next = op->op_next;
119 register PMOP *pm = (PMOP*) cLOGOP->op_other;
120 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
121 register SV *dstr = cx->sb_dstr;
122 register char *s = cx->sb_s;
123 register char *m = cx->sb_m;
124 char *orig = cx->sb_orig;
125 register REGEXP *rx = cx->sb_rx;
127 rxres_restore(&cx->sb_rxres, rx);
129 if (cx->sb_iters++) {
130 if (cx->sb_iters > cx->sb_maxiters)
131 DIE("Substitution loop");
133 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
134 cx->sb_rxtainted |= 2;
135 sv_catsv(dstr, POPs);
138 if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
139 s == m, Nullsv, NULL,
140 cx->sb_safebase ? 0 : REXEC_COPY_STR))
142 SV *targ = cx->sb_targ;
143 sv_catpvn(dstr, s, cx->sb_strend - s);
145 TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
146 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
148 (void)SvOOK_off(targ);
149 Safefree(SvPVX(targ));
150 SvPVX(targ) = SvPVX(dstr);
151 SvCUR_set(targ, SvCUR(dstr));
152 SvLEN_set(targ, SvLEN(dstr));
156 TAINT_IF(cx->sb_rxtainted & 1);
157 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
159 (void)SvPOK_only(targ);
160 TAINT_IF(cx->sb_rxtainted);
164 LEAVE_SCOPE(cx->sb_oldsave);
166 RETURNOP(pm->op_next);
169 if (rx->subbase && rx->subbase != orig) {
172 cx->sb_orig = orig = rx->subbase;
174 cx->sb_strend = s + (cx->sb_strend - m);
176 cx->sb_m = m = rx->startp[0];
177 sv_catpvn(dstr, s, m-s);
178 cx->sb_s = rx->endp[0];
179 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
180 rxres_save(&cx->sb_rxres, rx);
181 RETURNOP(pm->op_pmreplstart);
185 rxres_save(void **rsp, REGEXP *rx)
190 if (!p || p[1] < rx->nparens) {
191 i = 6 + rx->nparens * 2;
199 *p++ = (UV)rx->subbase;
200 rx->subbase = Nullch;
204 *p++ = (UV)rx->subbeg;
205 *p++ = (UV)rx->subend;
206 for (i = 0; i <= rx->nparens; ++i) {
207 *p++ = (UV)rx->startp[i];
208 *p++ = (UV)rx->endp[i];
213 rxres_restore(void **rsp, REGEXP *rx)
218 Safefree(rx->subbase);
219 rx->subbase = (char*)(*p);
224 rx->subbeg = (char*)(*p++);
225 rx->subend = (char*)(*p++);
226 for (i = 0; i <= rx->nparens; ++i) {
227 rx->startp[i] = (char*)(*p++);
228 rx->endp[i] = (char*)(*p++);
233 rxres_free(void **rsp)
238 Safefree((char*)(*p));
246 djSP; dMARK; dORIGMARK;
247 register SV *form = *++MARK;
259 bool chopspace = (strchr(chopset, ' ') != Nullch);
266 if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
267 SvREADONLY_off(form);
271 SvPV_force(formtarget, len);
272 t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */
275 /* need to jump to the next word */
276 s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN;
285 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
286 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
287 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
288 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
289 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
291 case FF_CHECKNL: name = "CHECKNL"; break;
292 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
293 case FF_SPACE: name = "SPACE"; break;
294 case FF_HALFSPACE: name = "HALFSPACE"; break;
295 case FF_ITEM: name = "ITEM"; break;
296 case FF_CHOP: name = "CHOP"; break;
297 case FF_LINEGLOB: name = "LINEGLOB"; break;
298 case FF_NEWLINE: name = "NEWLINE"; break;
299 case FF_MORE: name = "MORE"; break;
300 case FF_LINEMARK: name = "LINEMARK"; break;
301 case FF_END: name = "END"; break;
304 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
306 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
335 warn("Not enough format arguments");
340 item = s = SvPV(sv, len);
342 if (itemsize > fieldsize)
343 itemsize = fieldsize;
344 send = chophere = s + itemsize;
356 item = s = SvPV(sv, len);
358 if (itemsize <= fieldsize) {
359 send = chophere = s + itemsize;
370 itemsize = fieldsize;
371 send = chophere = s + itemsize;
372 while (s < send || (s == send && isSPACE(*s))) {
382 if (strchr(chopset, *s))
387 itemsize = chophere - item;
392 arg = fieldsize - itemsize;
401 arg = fieldsize - itemsize;
415 int ch = *t++ = *s++;
419 if ( !((*t++ = *s++) & ~31) )
429 while (*s && isSPACE(*s))
436 item = s = SvPV(sv, len);
449 SvCUR_set(formtarget, t - SvPVX(formtarget));
450 sv_catpvn(formtarget, item, itemsize);
451 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
452 t = SvPVX(formtarget) + SvCUR(formtarget);
457 /* If the field is marked with ^ and the value is undefined,
460 if ((arg & 512) && !SvOK(sv)) {
468 /* Formats aren't yet marked for locales, so assume "yes". */
471 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
473 sprintf(t, "%*.0f", (int) fieldsize, value);
480 while (t-- > linemark && *t == ' ') ;
488 if (arg) { /* repeat until fields exhausted? */
490 SvCUR_set(formtarget, t - SvPVX(formtarget));
491 lines += FmLINES(formtarget);
494 if (strnEQ(linemark, linemark - arg, arg))
495 DIE("Runaway format");
497 FmLINES(formtarget) = lines;
499 RETURNOP(cLISTOP->op_first);
510 arg = fieldsize - itemsize;
517 if (strnEQ(s," ",3)) {
518 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
529 SvCUR_set(formtarget, t - SvPVX(formtarget));
530 FmLINES(formtarget) += lines;
542 if (stack_base + *markstack_ptr == SP) {
544 if (GIMME_V == G_SCALAR)
546 RETURNOP(op->op_next->op_next);
548 stack_sp = stack_base + *markstack_ptr + 1;
549 pp_pushmark(ARGS); /* push dst */
550 pp_pushmark(ARGS); /* push src */
551 ENTER; /* enter outer scope */
555 /* SAVE_DEFSV does *not* suffice here */
556 save_sptr(&THREADSV(0));
558 SAVESPTR(GvSV(defgv));
559 #endif /* USE_THREADS */
560 ENTER; /* enter inner scope */
563 src = stack_base[*markstack_ptr];
568 if (op->op_type == OP_MAPSTART)
569 pp_pushmark(ARGS); /* push top */
570 return ((LOGOP*)op->op_next)->op_other;
575 DIE("panic: mapstart"); /* uses grepstart */
581 I32 diff = (SP - stack_base) - *markstack_ptr;
589 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
590 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
591 count = (SP - stack_base) - markstack_ptr[-1] + 2;
596 markstack_ptr[-1] += shift;
597 *markstack_ptr += shift;
601 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
604 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
606 LEAVE; /* exit inner scope */
609 if (markstack_ptr[-1] > *markstack_ptr) {
613 (void)POPMARK; /* pop top */
614 LEAVE; /* exit outer scope */
615 (void)POPMARK; /* pop src */
616 items = --*markstack_ptr - markstack_ptr[-1];
617 (void)POPMARK; /* pop dst */
618 SP = stack_base + POPMARK; /* pop original mark */
619 if (gimme == G_SCALAR) {
623 else if (gimme == G_ARRAY)
630 ENTER; /* enter inner scope */
633 src = stack_base[markstack_ptr[-1]];
637 RETURNOP(cLOGOP->op_other);
644 djSP; dMARK; dORIGMARK;
646 SV **myorigmark = ORIGMARK;
652 OP* nextop = op->op_next;
654 if (gimme != G_ARRAY) {
661 if (op->op_flags & OPf_STACKED) {
662 if (op->op_flags & OPf_SPECIAL) {
663 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
664 kid = kUNOP->op_first; /* pass rv2gv */
665 kid = kUNOP->op_first; /* pass leave */
666 sortcop = kid->op_next;
667 stash = curcop->cop_stash;
670 cv = sv_2cv(*++MARK, &stash, &gv, 0);
671 if (!(cv && CvROOT(cv))) {
673 SV *tmpstr = sv_newmortal();
674 gv_efullname3(tmpstr, gv, Nullch);
675 if (cv && CvXSUB(cv))
676 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
677 DIE("Undefined sort subroutine \"%s\" called",
682 DIE("Xsub called in sort");
683 DIE("Undefined subroutine in sort");
685 DIE("Not a CODE reference in sort");
687 sortcop = CvSTART(cv);
688 SAVESPTR(CvROOT(cv)->op_ppaddr);
689 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
692 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
697 stash = curcop->cop_stash;
701 while (MARK < SP) { /* This may or may not shift down one here. */
703 if (*up = *++MARK) { /* Weed out nulls. */
705 if (!sortcop && !SvPOK(*up))
706 (void)sv_2pv(*up, &na);
710 max = --up - myorigmark;
715 bool oldcatch = CATCH_GET;
722 if (sortstash != stash) {
723 firstgv = gv_fetchpv("a", TRUE, SVt_PV);
724 secondgv = gv_fetchpv("b", TRUE, SVt_PV);
728 SAVESPTR(GvSV(firstgv));
729 SAVESPTR(GvSV(secondgv));
731 PUSHBLOCK(cx, CXt_NULL, stack_base);
732 if (!(op->op_flags & OPf_SPECIAL)) {
733 bool hasargs = FALSE;
734 cx->cx_type = CXt_SUB;
735 cx->blk_gimme = G_SCALAR;
738 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
740 sortcxix = cxstack_ix;
742 qsortsv(myorigmark+1, max, sortcv);
751 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
752 qsortsv(ORIGMARK+1, max,
753 (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
757 stack_sp = ORIGMARK + max;
765 if (GIMME == G_ARRAY)
766 return cCONDOP->op_true;
767 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
774 if (GIMME == G_ARRAY) {
775 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
779 SV *targ = PAD_SV(op->op_targ);
781 if ((op->op_private & OPpFLIP_LINENUM)
782 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
784 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
785 if (op->op_flags & OPf_SPECIAL) {
793 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
806 if (GIMME == G_ARRAY) {
812 if (SvNIOKp(left) || !SvPOKp(left) ||
813 (looks_like_number(left) && *SvPVX(left) != '0') )
818 EXTEND_MORTAL(max - i + 1);
819 EXTEND(SP, max - i + 1);
822 sv = sv_2mortal(newSViv(i++));
827 SV *final = sv_mortalcopy(right);
829 char *tmps = SvPV(final, len);
831 sv = sv_mortalcopy(left);
832 while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
833 strNE(SvPVX(sv),tmps) ) {
835 sv = sv_2mortal(newSVsv(sv));
838 if (strEQ(SvPVX(sv),tmps))
844 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
846 if ((op->op_private & OPpFLIP_LINENUM)
847 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
849 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
850 sv_catpv(targ, "E0");
861 dopoptolabel(char *label)
865 register PERL_CONTEXT *cx;
867 for (i = cxstack_ix; i >= 0; i--) {
869 switch (cx->cx_type) {
872 warn("Exiting substitution via %s", op_name[op->op_type]);
876 warn("Exiting subroutine via %s", op_name[op->op_type]);
880 warn("Exiting eval via %s", op_name[op->op_type]);
884 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
887 if (!cx->blk_loop.label ||
888 strNE(label, cx->blk_loop.label) ) {
889 DEBUG_l(deb("(Skipping label #%ld %s)\n",
890 (long)i, cx->blk_loop.label));
893 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
903 I32 gimme = block_gimme();
904 return (gimme == G_VOID) ? G_SCALAR : gimme;
913 cxix = dopoptosub(cxstack_ix);
917 switch (cxstack[cxix].blk_gimme) {
923 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
930 dopoptosub(I32 startingblock)
934 register PERL_CONTEXT *cx;
935 for (i = startingblock; i >= 0; i--) {
937 switch (cx->cx_type) {
942 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
950 dopoptoeval(I32 startingblock)
954 register PERL_CONTEXT *cx;
955 for (i = startingblock; i >= 0; i--) {
957 switch (cx->cx_type) {
961 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
969 dopoptoloop(I32 startingblock)
973 register PERL_CONTEXT *cx;
974 for (i = startingblock; i >= 0; i--) {
976 switch (cx->cx_type) {
979 warn("Exiting substitution via %s", op_name[op->op_type]);
983 warn("Exiting subroutine via %s", op_name[op->op_type]);
987 warn("Exiting eval via %s", op_name[op->op_type]);
991 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
994 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1005 register PERL_CONTEXT *cx;
1009 while (cxstack_ix > cxix) {
1010 cx = &cxstack[cxstack_ix];
1011 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1012 (long) cxstack_ix, block_type[cx->cx_type]));
1013 /* Note: we don't need to restore the base context info till the end. */
1014 switch (cx->cx_type) {
1017 continue; /* not break */
1035 die_where(char *message)
1040 register PERL_CONTEXT *cx;
1047 STRLEN klen = strlen(message);
1049 svp = hv_fetch(ERRHV, message, klen, TRUE);
1052 static char prefix[] = "\t(in cleanup) ";
1054 sv_upgrade(*svp, SVt_IV);
1055 (void)SvIOK_only(*svp);
1058 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1059 sv_catpvn(err, prefix, sizeof(prefix)-1);
1060 sv_catpvn(err, message, klen);
1066 sv_setpv(ERRSV, message);
1069 message = SvPVx(ERRSV, na);
1071 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
1079 if (cxix < cxstack_ix)
1083 if (cx->cx_type != CXt_EVAL) {
1084 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1089 if (gimme == G_SCALAR)
1090 *++newsp = &sv_undef;
1095 if (optype == OP_REQUIRE) {
1096 char* msg = SvPVx(ERRSV, na);
1097 DIE("%s", *msg ? msg : "Compilation failed in require");
1099 return pop_return();
1102 PerlIO_printf(PerlIO_stderr(), "%s",message);
1103 PerlIO_flush(PerlIO_stderr());
1112 if (SvTRUE(left) != SvTRUE(right))
1124 RETURNOP(cLOGOP->op_other);
1133 RETURNOP(cLOGOP->op_other);
1139 register I32 cxix = dopoptosub(cxstack_ix);
1140 register PERL_CONTEXT *cx;
1152 if (GIMME != G_ARRAY)
1156 if (DBsub && cxix >= 0 &&
1157 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1161 cxix = dopoptosub(cxix - 1);
1163 cx = &cxstack[cxix];
1164 if (cxstack[cxix].cx_type == CXt_SUB) {
1165 dbcxix = dopoptosub(cxix - 1);
1166 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1167 field below is defined for any cx. */
1168 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1169 cx = &cxstack[dbcxix];
1172 if (GIMME != G_ARRAY) {
1173 hv = cx->blk_oldcop->cop_stash;
1178 sv_setpv(TARG, HvNAME(hv));
1184 hv = cx->blk_oldcop->cop_stash;
1188 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1189 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1190 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1193 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1195 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1196 PUSHs(sv_2mortal(sv));
1197 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1200 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1201 PUSHs(sv_2mortal(newSViv(0)));
1203 gimme = (I32)cx->blk_gimme;
1204 if (gimme == G_VOID)
1207 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1208 if (cx->cx_type == CXt_EVAL) {
1209 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1210 PUSHs(cx->blk_eval.cur_text);
1213 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1214 /* Require, put the name. */
1215 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1219 else if (cx->cx_type == CXt_SUB &&
1220 cx->blk_sub.hasargs &&
1221 curcop->cop_stash == debstash)
1223 AV *ary = cx->blk_sub.argarray;
1224 int off = AvARRAY(ary) - AvALLOC(ary);
1228 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1231 AvREAL_off(dbargs); /* XXX Should be REIFY */
1234 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1235 av_extend(dbargs, AvFILLp(ary) + off);
1236 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1237 AvFILLp(dbargs) = AvFILLp(ary) + off;
1243 sortcv(SV *a, SV *b)
1246 I32 oldsaveix = savestack_ix;
1247 I32 oldscopeix = scopestack_ix;
1251 stack_sp = stack_base;
1254 if (stack_sp != stack_base + 1)
1255 croak("Sort subroutine didn't return single value");
1256 if (!SvNIOKp(*stack_sp))
1257 croak("Sort subroutine didn't return a numeric value");
1258 result = SvIV(*stack_sp);
1259 while (scopestack_ix > oldscopeix) {
1262 leave_scope(oldsaveix);
1275 sv_reset(tmps, curcop->cop_stash);
1288 TAINT_NOT; /* Each statement is presumed innocent */
1289 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1292 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1296 register PERL_CONTEXT *cx;
1297 I32 gimme = G_ARRAY;
1304 DIE("No DB::DB routine defined");
1306 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1318 push_return(op->op_next);
1319 PUSHBLOCK(cx, CXt_SUB, SP);
1322 (void)SvREFCNT_inc(cv);
1324 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1325 RETURNOP(CvSTART(cv));
1339 register PERL_CONTEXT *cx;
1340 I32 gimme = GIMME_V;
1347 if (op->op_flags & OPf_SPECIAL)
1348 svp = save_threadsv(op->op_targ); /* per-thread variable */
1350 #endif /* USE_THREADS */
1352 svp = &curpad[op->op_targ]; /* "my" variable */
1357 (void)save_scalar(gv);
1358 svp = &GvSV(gv); /* symbol table variable */
1363 PUSHBLOCK(cx, CXt_LOOP, SP);
1364 PUSHLOOP(cx, svp, MARK);
1365 if (op->op_flags & OPf_STACKED)
1366 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1368 cx->blk_loop.iterary = curstack;
1369 AvFILLp(curstack) = SP - stack_base;
1370 cx->blk_loop.iterix = MARK - stack_base;
1379 register PERL_CONTEXT *cx;
1380 I32 gimme = GIMME_V;
1386 PUSHBLOCK(cx, CXt_LOOP, SP);
1387 PUSHLOOP(cx, 0, SP);
1395 register PERL_CONTEXT *cx;
1396 struct block_loop cxloop;
1404 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1407 if (gimme == G_VOID)
1409 else if (gimme == G_SCALAR) {
1411 *++newsp = sv_mortalcopy(*SP);
1413 *++newsp = &sv_undef;
1417 *++newsp = sv_mortalcopy(*++mark);
1418 TAINT_NOT; /* Each item is independent */
1424 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1425 curpm = newpm; /* ... and pop $1 et al */
1437 register PERL_CONTEXT *cx;
1438 struct block_sub cxsub;
1439 bool popsub2 = FALSE;
1445 if (curstackinfo->si_type == SI_SORT) {
1446 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1447 if (cxstack_ix > sortcxix)
1449 AvARRAY(curstack)[1] = *SP;
1450 stack_sp = stack_base + 1;
1455 cxix = dopoptosub(cxstack_ix);
1457 DIE("Can't return outside a subroutine");
1458 if (cxix < cxstack_ix)
1462 switch (cx->cx_type) {
1464 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1469 if (optype == OP_REQUIRE &&
1470 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1472 /* Unassume the success we assumed earlier. */
1473 char *name = cx->blk_eval.old_name;
1474 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1475 DIE("%s did not return a true value", name);
1479 DIE("panic: return");
1483 if (gimme == G_SCALAR) {
1485 *++newsp = (popsub2 && SvTEMP(*SP))
1486 ? *SP : sv_mortalcopy(*SP);
1488 *++newsp = &sv_undef;
1490 else if (gimme == G_ARRAY) {
1491 while (++MARK <= SP) {
1492 *++newsp = (popsub2 && SvTEMP(*MARK))
1493 ? *MARK : sv_mortalcopy(*MARK);
1494 TAINT_NOT; /* Each item is independent */
1499 /* Stack values are safe: */
1501 POPSUB2(); /* release CV and @_ ... */
1503 curpm = newpm; /* ... and pop $1 et al */
1506 return pop_return();
1513 register PERL_CONTEXT *cx;
1514 struct block_loop cxloop;
1515 struct block_sub cxsub;
1522 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1524 if (op->op_flags & OPf_SPECIAL) {
1525 cxix = dopoptoloop(cxstack_ix);
1527 DIE("Can't \"last\" outside a block");
1530 cxix = dopoptolabel(cPVOP->op_pv);
1532 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1534 if (cxix < cxstack_ix)
1538 switch (cx->cx_type) {
1540 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1542 nextop = cxloop.last_op->op_next;
1545 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1547 nextop = pop_return();
1551 nextop = pop_return();
1558 if (gimme == G_SCALAR) {
1560 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1561 ? *SP : sv_mortalcopy(*SP);
1563 *++newsp = &sv_undef;
1565 else if (gimme == G_ARRAY) {
1566 while (++MARK <= SP) {
1567 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1568 ? *MARK : sv_mortalcopy(*MARK);
1569 TAINT_NOT; /* Each item is independent */
1575 /* Stack values are safe: */
1578 POPLOOP2(); /* release loop vars ... */
1582 POPSUB2(); /* release CV and @_ ... */
1585 curpm = newpm; /* ... and pop $1 et al */
1594 register PERL_CONTEXT *cx;
1597 if (op->op_flags & OPf_SPECIAL) {
1598 cxix = dopoptoloop(cxstack_ix);
1600 DIE("Can't \"next\" outside a block");
1603 cxix = dopoptolabel(cPVOP->op_pv);
1605 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1607 if (cxix < cxstack_ix)
1611 oldsave = scopestack[scopestack_ix - 1];
1612 LEAVE_SCOPE(oldsave);
1613 return cx->blk_loop.next_op;
1619 register PERL_CONTEXT *cx;
1622 if (op->op_flags & OPf_SPECIAL) {
1623 cxix = dopoptoloop(cxstack_ix);
1625 DIE("Can't \"redo\" outside a block");
1628 cxix = dopoptolabel(cPVOP->op_pv);
1630 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1632 if (cxix < cxstack_ix)
1636 oldsave = scopestack[scopestack_ix - 1];
1637 LEAVE_SCOPE(oldsave);
1638 return cx->blk_loop.redo_op;
1641 static OP* lastgotoprobe;
1644 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1648 static char too_deep[] = "Target of goto is too deeply nested";
1652 if (o->op_type == OP_LEAVE ||
1653 o->op_type == OP_SCOPE ||
1654 o->op_type == OP_LEAVELOOP ||
1655 o->op_type == OP_LEAVETRY)
1657 *ops++ = cUNOPo->op_first;
1662 if (o->op_flags & OPf_KIDS) {
1663 /* First try all the kids at this level, since that's likeliest. */
1664 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1665 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1666 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1669 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1670 if (kid == lastgotoprobe)
1672 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1674 (ops[-1]->op_type != OP_NEXTSTATE &&
1675 ops[-1]->op_type != OP_DBSTATE)))
1677 if (o = dofindlabel(kid, label, ops, oplimit))
1687 return pp_goto(ARGS);
1696 register PERL_CONTEXT *cx;
1697 #define GOTO_DEPTH 64
1698 OP *enterops[GOTO_DEPTH];
1700 int do_dump = (op->op_type == OP_DUMP);
1703 if (op->op_flags & OPf_STACKED) {
1706 /* This egregious kludge implements goto &subroutine */
1707 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1709 register PERL_CONTEXT *cx;
1710 CV* cv = (CV*)SvRV(sv);
1715 if (!CvROOT(cv) && !CvXSUB(cv)) {
1717 SV *tmpstr = sv_newmortal();
1718 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1719 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1721 DIE("Goto undefined subroutine");
1724 /* First do some returnish stuff. */
1725 cxix = dopoptosub(cxstack_ix);
1727 DIE("Can't goto subroutine outside a subroutine");
1728 if (cxix < cxstack_ix)
1731 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1732 DIE("Can't goto subroutine from an eval-string");
1734 if (cx->cx_type == CXt_SUB &&
1735 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1736 AV* av = cx->blk_sub.argarray;
1738 items = AvFILLp(av) + 1;
1740 EXTEND(stack_sp, items); /* @_ could have been extended. */
1741 Copy(AvARRAY(av), stack_sp, items, SV*);
1744 SvREFCNT_dec(GvAV(defgv));
1745 GvAV(defgv) = cx->blk_sub.savearray;
1746 #endif /* USE_THREADS */
1750 if (cx->cx_type == CXt_SUB &&
1751 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1752 SvREFCNT_dec(cx->blk_sub.cv);
1753 oldsave = scopestack[scopestack_ix - 1];
1754 LEAVE_SCOPE(oldsave);
1756 /* Now do some callish stuff. */
1759 if (CvOLDSTYLE(cv)) {
1760 I32 (*fp3)_((int,int,int));
1765 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1766 items = (*fp3)(CvXSUBANY(cv).any_i32,
1767 mark - stack_base + 1,
1769 SP = stack_base + items;
1772 stack_sp--; /* There is no cv arg. */
1773 (void)(*CvXSUB(cv))(cv);
1776 return pop_return();
1779 AV* padlist = CvPADLIST(cv);
1780 SV** svp = AvARRAY(padlist);
1781 if (cx->cx_type == CXt_EVAL) {
1782 in_eval = cx->blk_eval.old_in_eval;
1783 eval_root = cx->blk_eval.old_eval_root;
1784 cx->cx_type = CXt_SUB;
1785 cx->blk_sub.hasargs = 0;
1787 cx->blk_sub.cv = cv;
1788 cx->blk_sub.olddepth = CvDEPTH(cv);
1790 if (CvDEPTH(cv) < 2)
1791 (void)SvREFCNT_inc(cv);
1792 else { /* save temporaries on recursion? */
1793 if (CvDEPTH(cv) == 100 && dowarn)
1794 sub_crush_depth(cv);
1795 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1796 AV *newpad = newAV();
1797 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1798 I32 ix = AvFILLp((AV*)svp[1]);
1799 svp = AvARRAY(svp[0]);
1800 for ( ;ix > 0; ix--) {
1801 if (svp[ix] != &sv_undef) {
1802 char *name = SvPVX(svp[ix]);
1803 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1806 /* outer lexical or anon code */
1807 av_store(newpad, ix,
1808 SvREFCNT_inc(oldpad[ix]) );
1810 else { /* our own lexical */
1812 av_store(newpad, ix, sv = (SV*)newAV());
1813 else if (*name == '%')
1814 av_store(newpad, ix, sv = (SV*)newHV());
1816 av_store(newpad, ix, sv = NEWSV(0,0));
1821 av_store(newpad, ix, sv = NEWSV(0,0));
1825 if (cx->blk_sub.hasargs) {
1828 av_store(newpad, 0, (SV*)av);
1829 AvFLAGS(av) = AVf_REIFY;
1831 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1832 AvFILLp(padlist) = CvDEPTH(cv);
1833 svp = AvARRAY(padlist);
1837 if (!cx->blk_sub.hasargs) {
1838 AV* av = (AV*)curpad[0];
1840 items = AvFILLp(av) + 1;
1842 /* Mark is at the end of the stack. */
1844 Copy(AvARRAY(av), SP + 1, items, SV*);
1849 #endif /* USE_THREADS */
1851 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1853 if (cx->blk_sub.hasargs)
1854 #endif /* USE_THREADS */
1856 AV* av = (AV*)curpad[0];
1860 cx->blk_sub.savearray = GvAV(defgv);
1861 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1862 #endif /* USE_THREADS */
1863 cx->blk_sub.argarray = av;
1866 if (items >= AvMAX(av) + 1) {
1868 if (AvARRAY(av) != ary) {
1869 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1870 SvPVX(av) = (char*)ary;
1872 if (items >= AvMAX(av) + 1) {
1873 AvMAX(av) = items - 1;
1874 Renew(ary,items+1,SV*);
1876 SvPVX(av) = (char*)ary;
1879 Copy(mark,AvARRAY(av),items,SV*);
1880 AvFILLp(av) = items - 1;
1888 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1890 * We do not care about using sv to call CV;
1891 * it's for informational purposes only.
1893 SV *sv = GvSV(DBsub);
1896 if (PERLDB_SUB_NN) {
1897 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1900 gv_efullname3(sv, CvGV(cv), Nullch);
1903 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1904 PUSHMARK( stack_sp );
1905 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1909 RETURNOP(CvSTART(cv));
1913 label = SvPV(sv,na);
1915 else if (op->op_flags & OPf_SPECIAL) {
1917 DIE("goto must have label");
1920 label = cPVOP->op_pv;
1922 if (label && *label) {
1929 for (ix = cxstack_ix; ix >= 0; ix--) {
1931 switch (cx->cx_type) {
1933 gotoprobe = eval_root; /* XXX not good for nested eval */
1936 gotoprobe = cx->blk_oldcop->op_sibling;
1942 gotoprobe = cx->blk_oldcop->op_sibling;
1944 gotoprobe = main_root;
1947 if (CvDEPTH(cx->blk_sub.cv)) {
1948 gotoprobe = CvROOT(cx->blk_sub.cv);
1953 DIE("Can't \"goto\" outside a block");
1957 gotoprobe = main_root;
1960 retop = dofindlabel(gotoprobe, label,
1961 enterops, enterops + GOTO_DEPTH);
1964 lastgotoprobe = gotoprobe;
1967 DIE("Can't find label %s", label);
1969 /* pop unwanted frames */
1971 if (ix < cxstack_ix) {
1978 oldsave = scopestack[scopestack_ix];
1979 LEAVE_SCOPE(oldsave);
1982 /* push wanted frames */
1984 if (*enterops && enterops[1]) {
1986 for (ix = 1; enterops[ix]; ix++) {
1988 /* Eventually we may want to stack the needed arguments
1989 * for each op. For now, we punt on the hard ones. */
1990 if (op->op_type == OP_ENTERITER)
1991 DIE("Can't \"goto\" into the middle of a foreach loop",
1993 (*op->op_ppaddr)(ARGS);
2001 if (!retop) retop = main_start;
2008 restartop = 0; /* hmm, must be GNU unexec().. */
2012 if (top_env->je_prev) {
2030 if (anum == 1 && VMSISH_EXIT)
2043 double value = SvNVx(GvSV(cCOP->cop_gv));
2044 register I32 match = I_32(value);
2047 if (((double)match) > value)
2048 --match; /* was fractional--truncate other way */
2050 match -= cCOP->uop.scop.scop_offset;
2053 else if (match > cCOP->uop.scop.scop_max)
2054 match = cCOP->uop.scop.scop_max;
2055 op = cCOP->uop.scop.scop_next[match];
2065 op = op->op_next; /* can't assume anything */
2067 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2068 match -= cCOP->uop.scop.scop_offset;
2071 else if (match > cCOP->uop.scop.scop_max)
2072 match = cCOP->uop.scop.scop_max;
2073 op = cCOP->uop.scop.scop_next[match];
2082 save_lines(AV *array, SV *sv)
2084 register char *s = SvPVX(sv);
2085 register char *send = SvPVX(sv) + SvCUR(sv);
2087 register I32 line = 1;
2089 while (s && s < send) {
2090 SV *tmpstr = NEWSV(85,0);
2092 sv_upgrade(tmpstr, SVt_PVMG);
2093 t = strchr(s, '\n');
2099 sv_setpvn(tmpstr, s, t - s);
2100 av_store(array, line++, tmpstr);
2115 assert(CATCH_GET == TRUE);
2116 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2120 default: /* topmost level handles it */
2127 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2143 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2144 /* sv Text to convert to OP tree. */
2145 /* startop op_free() this to undo. */
2146 /* code Short string id of the caller. */
2148 dSP; /* Make POPBLOCK work. */
2151 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2155 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2161 /* switch to eval mode */
2163 SAVESPTR(compiling.cop_filegv);
2164 SAVEI16(compiling.cop_line);
2165 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2166 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2167 compiling.cop_line = 1;
2168 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2169 deleting the eval's FILEGV from the stash before gv_check() runs
2170 (i.e. before run-time proper). To work around the coredump that
2171 ensues, we always turn GvMULTI_on for any globals that were
2172 introduced within evals. See force_ident(). GSAR 96-10-12 */
2173 safestr = savepv(tmpbuf);
2174 SAVEDELETE(defstash, safestr, strlen(safestr));
2176 #ifdef OP_IN_REGISTER
2184 op->op_type = 0; /* Avoid uninit warning. */
2185 op->op_flags = 0; /* Avoid uninit warning. */
2186 PUSHBLOCK(cx, CXt_EVAL, SP);
2187 PUSHEVAL(cx, 0, compiling.cop_filegv);
2188 rop = doeval(G_SCALAR, startop);
2192 (*startop)->op_type = OP_NULL;
2193 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2195 *avp = (AV*)SvREFCNT_inc(comppad);
2197 #ifdef OP_IN_REGISTER
2203 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2205 doeval(int gimme, OP** startop)
2218 /* set up a scratch pad */
2223 SAVESPTR(comppad_name);
2224 SAVEI32(comppad_name_fill);
2225 SAVEI32(min_intro_pending);
2226 SAVEI32(max_intro_pending);
2229 for (i = cxstack_ix - 1; i >= 0; i--) {
2230 PERL_CONTEXT *cx = &cxstack[i];
2231 if (cx->cx_type == CXt_EVAL)
2233 else if (cx->cx_type == CXt_SUB) {
2234 caller = cx->blk_sub.cv;
2240 compcv = (CV*)NEWSV(1104,0);
2241 sv_upgrade((SV *)compcv, SVt_PVCV);
2242 CvUNIQUE_on(compcv);
2244 CvOWNER(compcv) = 0;
2245 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2246 MUTEX_INIT(CvMUTEXP(compcv));
2247 #endif /* USE_THREADS */
2250 av_push(comppad, Nullsv);
2251 curpad = AvARRAY(comppad);
2252 comppad_name = newAV();
2253 comppad_name_fill = 0;
2254 min_intro_pending = 0;
2257 av_store(comppad_name, 0, newSVpv("@_", 2));
2258 curpad[0] = (SV*)newAV();
2259 SvPADMY_on(curpad[0]); /* XXX Needed? */
2260 #endif /* USE_THREADS */
2262 comppadlist = newAV();
2263 AvREAL_off(comppadlist);
2264 av_store(comppadlist, 0, (SV*)comppad_name);
2265 av_store(comppadlist, 1, (SV*)comppad);
2266 CvPADLIST(compcv) = comppadlist;
2268 if (!saveop || saveop->op_type != OP_REQUIRE)
2269 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2273 /* make sure we compile in the right package */
2275 newstash = curcop->cop_stash;
2276 if (curstash != newstash) {
2278 curstash = newstash;
2282 SAVEFREESV(beginav);
2284 /* try to compile it */
2288 curcop = &compiling;
2289 curcop->cop_arybase = 0;
2291 rs = newSVpv("\n", 1);
2292 if (saveop && saveop->op_flags & OPf_SPECIAL)
2296 if (yyparse() || error_count || !eval_root) {
2300 I32 optype = 0; /* Might be reset by POPEVAL. */
2307 SP = stack_base + POPMARK; /* pop original mark */
2315 if (optype == OP_REQUIRE) {
2316 char* msg = SvPVx(ERRSV, na);
2317 DIE("%s", *msg ? msg : "Compilation failed in require");
2318 } else if (startop) {
2319 char* msg = SvPVx(ERRSV, na);
2323 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2326 rs = SvREFCNT_inc(nrs);
2328 MUTEX_LOCK(&eval_mutex);
2330 COND_SIGNAL(&eval_cond);
2331 MUTEX_UNLOCK(&eval_mutex);
2332 #endif /* USE_THREADS */
2336 rs = SvREFCNT_inc(nrs);
2337 compiling.cop_line = 0;
2339 *startop = eval_root;
2340 SvREFCNT_dec(CvOUTSIDE(compcv));
2341 CvOUTSIDE(compcv) = Nullcv;
2343 SAVEFREEOP(eval_root);
2345 scalarvoid(eval_root);
2346 else if (gimme & G_ARRAY)
2351 DEBUG_x(dump_eval());
2353 /* Register with debugger: */
2354 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2355 CV *cv = perl_get_cv("DB::postponed", FALSE);
2359 XPUSHs((SV*)compiling.cop_filegv);
2361 perl_call_sv((SV*)cv, G_DISCARD);
2365 /* compiled okay, so do it */
2367 CvDEPTH(compcv) = 1;
2368 SP = stack_base + POPMARK; /* pop original mark */
2369 op = saveop; /* The caller may need it. */
2371 MUTEX_LOCK(&eval_mutex);
2373 COND_SIGNAL(&eval_cond);
2374 MUTEX_UNLOCK(&eval_mutex);
2375 #endif /* USE_THREADS */
2377 RETURNOP(eval_start);
2383 register PERL_CONTEXT *cx;
2388 SV *namesv = Nullsv;
2390 I32 gimme = G_SCALAR;
2391 PerlIO *tryrsfp = 0;
2394 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2395 SET_NUMERIC_STANDARD();
2396 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2397 DIE("Perl %s required--this is only version %s, stopped",
2398 SvPV(sv,na),patchlevel);
2401 name = SvPV(sv, len);
2402 if (!(name && len > 0 && *name))
2403 DIE("Null filename used");
2404 TAINT_PROPER("require");
2405 if (op->op_type == OP_REQUIRE &&
2406 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2410 /* prepare to compile file */
2415 (name[1] == '.' && name[2] == '/')))
2417 || (name[0] && name[1] == ':')
2420 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2423 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2424 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2429 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2432 AV *ar = GvAVn(incgv);
2436 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2439 namesv = NEWSV(806, 0);
2440 for (i = 0; i <= AvFILL(ar); i++) {
2441 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2444 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2446 sv_setpv(namesv, unixdir);
2447 sv_catpv(namesv, unixname);
2449 sv_setpvf(namesv, "%s/%s", dir, name);
2451 tryname = SvPVX(namesv);
2452 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2454 if (tryname[0] == '.' && tryname[1] == '/')
2461 SAVESPTR(compiling.cop_filegv);
2462 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2463 SvREFCNT_dec(namesv);
2465 if (op->op_type == OP_REQUIRE) {
2466 SV *msg = sv_2mortal(newSVpvf("Can't locate '%s' in @INC", name));
2467 SV *dirmsgsv = NEWSV(0, 0);
2468 AV *ar = GvAVn(incgv);
2470 if (instr(SvPVX(msg), ".h "))
2471 sv_catpv(msg, " (change .h to .ph maybe?)");
2472 if (instr(SvPVX(msg), ".ph "))
2473 sv_catpv(msg, " (did you run h2ph?)");
2474 sv_catpv(msg, " (@INC contains:");
2475 for (i = 0; i <= AvFILL(ar); i++) {
2476 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2477 sv_setpvf(dirmsgsv, " %s", dir);
2478 sv_catsv(msg, dirmsgsv);
2480 sv_catpvn(msg, ")", 1);
2481 SvREFCNT_dec(dirmsgsv);
2488 /* Assume success here to prevent recursive requirement. */
2489 (void)hv_store(GvHVn(incgv), name, strlen(name),
2490 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2494 lex_start(sv_2mortal(newSVpv("",0)));
2496 save_aptr(&rsfp_filters);
2497 rsfp_filters = NULL;
2501 name = savepv(name);
2506 /* switch to eval mode */
2508 push_return(op->op_next);
2509 PUSHBLOCK(cx, CXt_EVAL, SP);
2510 PUSHEVAL(cx, name, compiling.cop_filegv);
2512 compiling.cop_line = 0;
2516 MUTEX_LOCK(&eval_mutex);
2517 if (eval_owner && eval_owner != thr)
2519 COND_WAIT(&eval_cond, &eval_mutex);
2521 MUTEX_UNLOCK(&eval_mutex);
2522 #endif /* USE_THREADS */
2523 return DOCATCH(doeval(G_SCALAR, NULL));
2528 return pp_require(ARGS);
2534 register PERL_CONTEXT *cx;
2536 I32 gimme = GIMME_V, was = sub_generation;
2537 char tmpbuf[TYPE_DIGITS(long) + 12];
2542 if (!SvPV(sv,len) || !len)
2544 TAINT_PROPER("eval");
2550 /* switch to eval mode */
2552 SAVESPTR(compiling.cop_filegv);
2553 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2554 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2555 compiling.cop_line = 1;
2556 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2557 deleting the eval's FILEGV from the stash before gv_check() runs
2558 (i.e. before run-time proper). To work around the coredump that
2559 ensues, we always turn GvMULTI_on for any globals that were
2560 introduced within evals. See force_ident(). GSAR 96-10-12 */
2561 safestr = savepv(tmpbuf);
2562 SAVEDELETE(defstash, safestr, strlen(safestr));
2564 hints = op->op_targ;
2566 push_return(op->op_next);
2567 PUSHBLOCK(cx, CXt_EVAL, SP);
2568 PUSHEVAL(cx, 0, compiling.cop_filegv);
2570 /* prepare to compile string */
2572 if (PERLDB_LINE && curstash != debstash)
2573 save_lines(GvAV(compiling.cop_filegv), linestr);
2576 MUTEX_LOCK(&eval_mutex);
2577 if (eval_owner && eval_owner != thr)
2579 COND_WAIT(&eval_cond, &eval_mutex);
2581 MUTEX_UNLOCK(&eval_mutex);
2582 #endif /* USE_THREADS */
2583 ret = doeval(gimme, NULL);
2584 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2585 && ret != op->op_next) { /* Successive compilation. */
2586 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2588 return DOCATCH(ret);
2598 register PERL_CONTEXT *cx;
2600 U8 save_flags = op -> op_flags;
2605 retop = pop_return();
2608 if (gimme == G_VOID)
2610 else if (gimme == G_SCALAR) {
2613 if (SvFLAGS(TOPs) & SVs_TEMP)
2616 *MARK = sv_mortalcopy(TOPs);
2624 /* in case LEAVE wipes old return values */
2625 for (mark = newsp + 1; mark <= SP; mark++) {
2626 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2627 *mark = sv_mortalcopy(*mark);
2628 TAINT_NOT; /* Each item is independent */
2632 curpm = newpm; /* Don't pop $1 et al till now */
2635 * Closures mentioned at top level of eval cannot be referenced
2636 * again, and their presence indirectly causes a memory leak.
2637 * (Note that the fact that compcv and friends are still set here
2638 * is, AFAIK, an accident.) --Chip
2640 if (AvFILLp(comppad_name) >= 0) {
2641 SV **svp = AvARRAY(comppad_name);
2643 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2645 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2647 svp[ix] = &sv_undef;
2651 SvREFCNT_dec(CvOUTSIDE(sv));
2652 CvOUTSIDE(sv) = Nullcv;
2665 assert(CvDEPTH(compcv) == 1);
2667 CvDEPTH(compcv) = 0;
2670 if (optype == OP_REQUIRE &&
2671 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2673 /* Unassume the success we assumed earlier. */
2674 char *name = cx->blk_eval.old_name;
2675 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2676 retop = die("%s did not return a true value", name);
2677 /* die_where() did LEAVE, or we won't be here */
2681 if (!(save_flags & OPf_SPECIAL))
2691 register PERL_CONTEXT *cx;
2692 I32 gimme = GIMME_V;
2697 push_return(cLOGOP->op_other->op_next);
2698 PUSHBLOCK(cx, CXt_EVAL, SP);
2700 eval_root = op; /* Only needed so that goto works right. */
2705 return DOCATCH(op->op_next);
2715 register PERL_CONTEXT *cx;
2723 if (gimme == G_VOID)
2725 else if (gimme == G_SCALAR) {
2728 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2731 *MARK = sv_mortalcopy(TOPs);
2740 /* in case LEAVE wipes old return values */
2741 for (mark = newsp + 1; mark <= SP; mark++) {
2742 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2743 *mark = sv_mortalcopy(*mark);
2744 TAINT_NOT; /* Each item is independent */
2748 curpm = newpm; /* Don't pop $1 et al till now */
2759 register char *s = SvPV_force(sv, len);
2760 register char *send = s + len;
2761 register char *base;
2762 register I32 skipspaces = 0;
2765 bool postspace = FALSE;
2773 croak("Null picture in formline");
2775 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2780 *fpc++ = FF_LINEMARK;
2781 noblank = repeat = FALSE;
2799 case ' ': case '\t':
2810 *fpc++ = FF_LITERAL;
2818 *fpc++ = skipspaces;
2822 *fpc++ = FF_NEWLINE;
2826 arg = fpc - linepc + 1;
2833 *fpc++ = FF_LINEMARK;
2834 noblank = repeat = FALSE;
2843 ischop = s[-1] == '^';
2849 arg = (s - base) - 1;
2851 *fpc++ = FF_LITERAL;
2860 *fpc++ = FF_LINEGLOB;
2862 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2863 arg = ischop ? 512 : 0;
2873 arg |= 256 + (s - f);
2875 *fpc++ = s - base; /* fieldsize for FETCH */
2876 *fpc++ = FF_DECIMAL;
2881 bool ismore = FALSE;
2884 while (*++s == '>') ;
2885 prespace = FF_SPACE;
2887 else if (*s == '|') {
2888 while (*++s == '|') ;
2889 prespace = FF_HALFSPACE;
2894 while (*++s == '<') ;
2897 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2901 *fpc++ = s - base; /* fieldsize for FETCH */
2903 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2921 { /* need to jump to the next word */
2923 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2924 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2925 s = SvPVX(sv) + SvCUR(sv) + z;
2927 Copy(fops, s, arg, U16);
2929 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2934 * The rest of this file was derived from source code contributed
2937 * NOTE: this code was derived from Tom Horsley's qsort replacement
2938 * and should not be confused with the original code.
2941 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2943 Permission granted to distribute under the same terms as perl which are
2946 This program is free software; you can redistribute it and/or modify
2947 it under the terms of either:
2949 a) the GNU General Public License as published by the Free
2950 Software Foundation; either version 1, or (at your option) any
2953 b) the "Artistic License" which comes with this Kit.
2955 Details on the perl license can be found in the perl source code which
2956 may be located via the www.perl.com web page.
2958 This is the most wonderfulest possible qsort I can come up with (and
2959 still be mostly portable) My (limited) tests indicate it consistently
2960 does about 20% fewer calls to compare than does the qsort in the Visual
2961 C++ library, other vendors may vary.
2963 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2964 others I invented myself (or more likely re-invented since they seemed
2965 pretty obvious once I watched the algorithm operate for a while).
2967 Most of this code was written while watching the Marlins sweep the Giants
2968 in the 1997 National League Playoffs - no Braves fans allowed to use this
2969 code (just kidding :-).
2971 I realize that if I wanted to be true to the perl tradition, the only
2972 comment in this file would be something like:
2974 ...they shuffled back towards the rear of the line. 'No, not at the
2975 rear!' the slave-driver shouted. 'Three files up. And stay there...
2977 However, I really needed to violate that tradition just so I could keep
2978 track of what happens myself, not to mention some poor fool trying to
2979 understand this years from now :-).
2982 /* ********************************************************** Configuration */
2984 #ifndef QSORT_ORDER_GUESS
2985 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
2988 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
2989 future processing - a good max upper bound is log base 2 of memory size
2990 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
2991 safely be smaller than that since the program is taking up some space and
2992 most operating systems only let you grab some subset of contiguous
2993 memory (not to mention that you are normally sorting data larger than
2994 1 byte element size :-).
2996 #ifndef QSORT_MAX_STACK
2997 #define QSORT_MAX_STACK 32
3000 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3001 Anything bigger and we use qsort. If you make this too small, the qsort
3002 will probably break (or become less efficient), because it doesn't expect
3003 the middle element of a partition to be the same as the right or left -
3004 you have been warned).
3006 #ifndef QSORT_BREAK_EVEN
3007 #define QSORT_BREAK_EVEN 6
3010 /* ************************************************************* Data Types */
3012 /* hold left and right index values of a partition waiting to be sorted (the
3013 partition includes both left and right - right is NOT one past the end or
3014 anything like that).
3016 struct partition_stack_entry {
3019 #ifdef QSORT_ORDER_GUESS
3020 int qsort_break_even;
3024 /* ******************************************************* Shorthand Macros */
3026 /* Note that these macros will be used from inside the qsort function where
3027 we happen to know that the variable 'elt_size' contains the size of an
3028 array element and the variable 'temp' points to enough space to hold a
3029 temp element and the variable 'array' points to the array being sorted
3030 and 'compare' is the pointer to the compare routine.
3032 Also note that there are very many highly architecture specific ways
3033 these might be sped up, but this is simply the most generally portable
3034 code I could think of.
3037 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3039 #define qsort_cmp(elt1, elt2) \
3040 ((*compare)(array[elt1], array[elt2]))
3042 #ifdef QSORT_ORDER_GUESS
3043 #define QSORT_NOTICE_SWAP swapped++;
3045 #define QSORT_NOTICE_SWAP
3048 /* swaps contents of array elements elt1, elt2.
3050 #define qsort_swap(elt1, elt2) \
3053 temp = array[elt1]; \
3054 array[elt1] = array[elt2]; \
3055 array[elt2] = temp; \
3058 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3059 elt3 and elt3 gets elt1.
3061 #define qsort_rotate(elt1, elt2, elt3) \
3064 temp = array[elt1]; \
3065 array[elt1] = array[elt2]; \
3066 array[elt2] = array[elt3]; \
3067 array[elt3] = temp; \
3070 /* ************************************************************ Debug stuff */
3077 return; /* good place to set a breakpoint */
3080 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3083 doqsort_all_asserts(
3087 int (*compare)(const void * elt1, const void * elt2),
3088 int pc_left, int pc_right, int u_left, int u_right)
3092 qsort_assert(pc_left <= pc_right);
3093 qsort_assert(u_right < pc_left);
3094 qsort_assert(pc_right < u_left);
3095 for (i = u_right + 1; i < pc_left; ++i) {
3096 qsort_assert(qsort_cmp(i, pc_left) < 0);
3098 for (i = pc_left; i < pc_right; ++i) {
3099 qsort_assert(qsort_cmp(i, pc_right) == 0);
3101 for (i = pc_right + 1; i < u_left; ++i) {
3102 qsort_assert(qsort_cmp(pc_right, i) < 0);
3106 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3107 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3108 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3112 #define qsort_assert(t) ((void)0)
3114 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3118 /* ****************************************************************** qsort */
3124 I32 (*compare)(SV *a, SV *b))
3128 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3129 int next_stack_entry = 0;
3133 #ifdef QSORT_ORDER_GUESS
3134 int qsort_break_even;
3138 /* Make sure we actually have work to do.
3140 if (num_elts <= 1) {
3144 /* Setup the initial partition definition and fall into the sorting loop
3147 part_right = (int)(num_elts - 1);
3148 #ifdef QSORT_ORDER_GUESS
3149 qsort_break_even = QSORT_BREAK_EVEN;
3151 #define qsort_break_even QSORT_BREAK_EVEN
3154 if ((part_right - part_left) >= qsort_break_even) {
3155 /* OK, this is gonna get hairy, so lets try to document all the
3156 concepts and abbreviations and variables and what they keep
3159 pc: pivot chunk - the set of array elements we accumulate in the
3160 middle of the partition, all equal in value to the original
3161 pivot element selected. The pc is defined by:
3163 pc_left - the leftmost array index of the pc
3164 pc_right - the rightmost array index of the pc
3166 we start with pc_left == pc_right and only one element
3167 in the pivot chunk (but it can grow during the scan).
3169 u: uncompared elements - the set of elements in the partition
3170 we have not yet compared to the pivot value. There are two
3171 uncompared sets during the scan - one to the left of the pc
3172 and one to the right.
3174 u_right - the rightmost index of the left side's uncompared set
3175 u_left - the leftmost index of the right side's uncompared set
3177 The leftmost index of the left sides's uncompared set
3178 doesn't need its own variable because it is always defined
3179 by the leftmost edge of the whole partition (part_left). The
3180 same goes for the rightmost edge of the right partition
3183 We know there are no uncompared elements on the left once we
3184 get u_right < part_left and no uncompared elements on the
3185 right once u_left > part_right. When both these conditions
3186 are met, we have completed the scan of the partition.
3188 Any elements which are between the pivot chunk and the
3189 uncompared elements should be less than the pivot value on
3190 the left side and greater than the pivot value on the right
3191 side (in fact, the goal of the whole algorithm is to arrange
3192 for that to be true and make the groups of less-than and
3193 greater-then elements into new partitions to sort again).
3195 As you marvel at the complexity of the code and wonder why it
3196 has to be so confusing. Consider some of the things this level
3197 of confusion brings:
3199 Once I do a compare, I squeeze every ounce of juice out of it. I
3200 never do compare calls I don't have to do, and I certainly never
3203 I also never swap any elements unless I can prove there is a
3204 good reason. Many sort algorithms will swap a known value with
3205 an uncompared value just to get things in the right place (or
3206 avoid complexity :-), but that uncompared value, once it gets
3207 compared, may then have to be swapped again. A lot of the
3208 complexity of this code is due to the fact that it never swaps
3209 anything except compared values, and it only swaps them when the
3210 compare shows they are out of position.
3212 int pc_left, pc_right;
3213 int u_right, u_left;
3217 pc_left = ((part_left + part_right) / 2);
3219 u_right = pc_left - 1;
3220 u_left = pc_right + 1;
3222 /* Qsort works best when the pivot value is also the median value
3223 in the partition (unfortunately you can't find the median value
3224 without first sorting :-), so to give the algorithm a helping
3225 hand, we pick 3 elements and sort them and use the median value
3226 of that tiny set as the pivot value.
3228 Some versions of qsort like to use the left middle and right as
3229 the 3 elements to sort so they can insure the ends of the
3230 partition will contain values which will stop the scan in the
3231 compare loop, but when you have to call an arbitrarily complex
3232 routine to do a compare, its really better to just keep track of
3233 array index values to know when you hit the edge of the
3234 partition and avoid the extra compare. An even better reason to
3235 avoid using a compare call is the fact that you can drop off the
3236 edge of the array if someone foolishly provides you with an
3237 unstable compare function that doesn't always provide consistent
3240 So, since it is simpler for us to compare the three adjacent
3241 elements in the middle of the partition, those are the ones we
3242 pick here (conveniently pointed at by u_right, pc_left, and
3243 u_left). The values of the left, center, and right elements
3244 are refered to as l c and r in the following comments.
3247 #ifdef QSORT_ORDER_GUESS
3250 s = qsort_cmp(u_right, pc_left);
3253 s = qsort_cmp(pc_left, u_left);
3254 /* if l < c, c < r - already in order - nothing to do */
3256 /* l < c, c == r - already in order, pc grows */
3258 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3260 /* l < c, c > r - need to know more */
3261 s = qsort_cmp(u_right, u_left);
3263 /* l < c, c > r, l < r - swap c & r to get ordered */
3264 qsort_swap(pc_left, u_left);
3265 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3266 } else if (s == 0) {
3267 /* l < c, c > r, l == r - swap c&r, grow pc */
3268 qsort_swap(pc_left, u_left);
3270 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3272 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3273 qsort_rotate(pc_left, u_right, u_left);
3274 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3277 } else if (s == 0) {
3279 s = qsort_cmp(pc_left, u_left);
3281 /* l == c, c < r - already in order, grow pc */
3283 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3284 } else if (s == 0) {
3285 /* l == c, c == r - already in order, grow pc both ways */
3288 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3290 /* l == c, c > r - swap l & r, grow pc */
3291 qsort_swap(u_right, u_left);
3293 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3297 s = qsort_cmp(pc_left, u_left);
3299 /* l > c, c < r - need to know more */
3300 s = qsort_cmp(u_right, u_left);
3302 /* l > c, c < r, l < r - swap l & c to get ordered */
3303 qsort_swap(u_right, pc_left);
3304 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3305 } else if (s == 0) {
3306 /* l > c, c < r, l == r - swap l & c, grow pc */
3307 qsort_swap(u_right, pc_left);
3309 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3311 /* l > c, c < r, l > r - rotate lcr into crl to order */
3312 qsort_rotate(u_right, pc_left, u_left);
3313 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3315 } else if (s == 0) {
3316 /* l > c, c == r - swap ends, grow pc */
3317 qsort_swap(u_right, u_left);
3319 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3321 /* l > c, c > r - swap ends to get in order */
3322 qsort_swap(u_right, u_left);
3323 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3326 /* We now know the 3 middle elements have been compared and
3327 arranged in the desired order, so we can shrink the uncompared
3332 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3334 /* The above massive nested if was the simple part :-). We now have
3335 the middle 3 elements ordered and we need to scan through the
3336 uncompared sets on either side, swapping elements that are on
3337 the wrong side or simply shuffling equal elements around to get
3338 all equal elements into the pivot chunk.
3342 int still_work_on_left;
3343 int still_work_on_right;
3345 /* Scan the uncompared values on the left. If I find a value
3346 equal to the pivot value, move it over so it is adjacent to
3347 the pivot chunk and expand the pivot chunk. If I find a value
3348 less than the pivot value, then just leave it - its already
3349 on the correct side of the partition. If I find a greater
3350 value, then stop the scan.
3352 while (still_work_on_left = (u_right >= part_left)) {
3353 s = qsort_cmp(u_right, pc_left);
3356 } else if (s == 0) {
3358 if (pc_left != u_right) {
3359 qsort_swap(u_right, pc_left);
3365 qsort_assert(u_right < pc_left);
3366 qsort_assert(pc_left <= pc_right);
3367 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3368 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3371 /* Do a mirror image scan of uncompared values on the right
3373 while (still_work_on_right = (u_left <= part_right)) {
3374 s = qsort_cmp(pc_right, u_left);
3377 } else if (s == 0) {
3379 if (pc_right != u_left) {
3380 qsort_swap(pc_right, u_left);
3386 qsort_assert(u_left > pc_right);
3387 qsort_assert(pc_left <= pc_right);
3388 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3389 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3392 if (still_work_on_left) {
3393 /* I know I have a value on the left side which needs to be
3394 on the right side, but I need to know more to decide
3395 exactly the best thing to do with it.
3397 if (still_work_on_right) {
3398 /* I know I have values on both side which are out of
3399 position. This is a big win because I kill two birds
3400 with one swap (so to speak). I can advance the
3401 uncompared pointers on both sides after swapping both
3402 of them into the right place.
3404 qsort_swap(u_right, u_left);
3407 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3409 /* I have an out of position value on the left, but the
3410 right is fully scanned, so I "slide" the pivot chunk
3411 and any less-than values left one to make room for the
3412 greater value over on the right. If the out of position
3413 value is immediately adjacent to the pivot chunk (there
3414 are no less-than values), I can do that with a swap,
3415 otherwise, I have to rotate one of the less than values
3416 into the former position of the out of position value
3417 and the right end of the pivot chunk into the left end
3421 if (pc_left == u_right) {
3422 qsort_swap(u_right, pc_right);
3423 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3425 qsort_rotate(u_right, pc_left, pc_right);
3426 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3431 } else if (still_work_on_right) {
3432 /* Mirror image of complex case above: I have an out of
3433 position value on the right, but the left is fully
3434 scanned, so I need to shuffle things around to make room
3435 for the right value on the left.
3438 if (pc_right == u_left) {
3439 qsort_swap(u_left, pc_left);
3440 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3442 qsort_rotate(pc_right, pc_left, u_left);
3443 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3448 /* No more scanning required on either side of partition,
3449 break out of loop and figure out next set of partitions
3455 /* The elements in the pivot chunk are now in the right place. They
3456 will never move or be compared again. All I have to do is decide
3457 what to do with the stuff to the left and right of the pivot
3460 Notes on the QSORT_ORDER_GUESS ifdef code:
3462 1. If I just built these partitions without swapping any (or
3463 very many) elements, there is a chance that the elements are
3464 already ordered properly (being properly ordered will
3465 certainly result in no swapping, but the converse can't be
3468 2. A (properly written) insertion sort will run faster on
3469 already ordered data than qsort will.
3471 3. Perhaps there is some way to make a good guess about
3472 switching to an insertion sort earlier than partition size 6
3473 (for instance - we could save the partition size on the stack
3474 and increase the size each time we find we didn't swap, thus
3475 switching to insertion sort earlier for partitions with a
3476 history of not swapping).
3478 4. Naturally, if I just switch right away, it will make
3479 artificial benchmarks with pure ascending (or descending)
3480 data look really good, but is that a good reason in general?
3484 #ifdef QSORT_ORDER_GUESS
3486 #if QSORT_ORDER_GUESS == 1
3487 qsort_break_even = (part_right - part_left) + 1;
3489 #if QSORT_ORDER_GUESS == 2
3490 qsort_break_even *= 2;
3492 #if QSORT_ORDER_GUESS == 3
3493 int prev_break = qsort_break_even;
3494 qsort_break_even *= qsort_break_even;
3495 if (qsort_break_even < prev_break) {
3496 qsort_break_even = (part_right - part_left) + 1;
3500 qsort_break_even = QSORT_BREAK_EVEN;
3504 if (part_left < pc_left) {
3505 /* There are elements on the left which need more processing.
3506 Check the right as well before deciding what to do.
3508 if (pc_right < part_right) {
3509 /* We have two partitions to be sorted. Stack the biggest one
3510 and process the smallest one on the next iteration. This
3511 minimizes the stack height by insuring that any additional
3512 stack entries must come from the smallest partition which
3513 (because it is smallest) will have the fewest
3514 opportunities to generate additional stack entries.
3516 if ((part_right - pc_right) > (pc_left - part_left)) {
3517 /* stack the right partition, process the left */
3518 partition_stack[next_stack_entry].left = pc_right + 1;
3519 partition_stack[next_stack_entry].right = part_right;
3520 #ifdef QSORT_ORDER_GUESS
3521 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3523 part_right = pc_left - 1;
3525 /* stack the left partition, process the right */
3526 partition_stack[next_stack_entry].left = part_left;
3527 partition_stack[next_stack_entry].right = pc_left - 1;
3528 #ifdef QSORT_ORDER_GUESS
3529 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3531 part_left = pc_right + 1;
3533 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3536 /* The elements on the left are the only remaining elements
3537 that need sorting, arrange for them to be processed as the
3540 part_right = pc_left - 1;
3542 } else if (pc_right < part_right) {
3543 /* There is only one chunk on the right to be sorted, make it
3544 the new partition and loop back around.
3546 part_left = pc_right + 1;
3548 /* This whole partition wound up in the pivot chunk, so
3549 we need to get a new partition off the stack.
3551 if (next_stack_entry == 0) {
3552 /* the stack is empty - we are done */
3556 part_left = partition_stack[next_stack_entry].left;
3557 part_right = partition_stack[next_stack_entry].right;
3558 #ifdef QSORT_ORDER_GUESS
3559 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3563 /* This partition is too small to fool with qsort complexity, just
3564 do an ordinary insertion sort to minimize overhead.
3567 /* Assume 1st element is in right place already, and start checking
3568 at 2nd element to see where it should be inserted.
3570 for (i = part_left + 1; i <= part_right; ++i) {
3572 /* Scan (backwards - just in case 'i' is already in right place)
3573 through the elements already sorted to see if the ith element
3574 belongs ahead of one of them.
3576 for (j = i - 1; j >= part_left; --j) {
3577 if (qsort_cmp(i, j) >= 0) {
3578 /* i belongs right after j
3585 /* Looks like we really need to move some things
3589 for (k = i - 1; k >= j; --k)
3590 array[k + 1] = array[k];
3595 /* That partition is now sorted, grab the next one, or get out
3596 of the loop if there aren't any more.
3599 if (next_stack_entry == 0) {
3600 /* the stack is empty - we are done */
3604 part_left = partition_stack[next_stack_entry].left;
3605 part_right = partition_stack[next_stack_entry].right;
3606 #ifdef QSORT_ORDER_GUESS
3607 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3612 /* Believe it or not, the array is sorted at this point! */