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) {
925 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
932 dopoptosub(I32 startingblock)
936 register PERL_CONTEXT *cx;
937 for (i = startingblock; i >= 0; i--) {
939 switch (cx->cx_type) {
944 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
952 dopoptoeval(I32 startingblock)
956 register PERL_CONTEXT *cx;
957 for (i = startingblock; i >= 0; i--) {
959 switch (cx->cx_type) {
963 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
971 dopoptoloop(I32 startingblock)
975 register PERL_CONTEXT *cx;
976 for (i = startingblock; i >= 0; i--) {
978 switch (cx->cx_type) {
981 warn("Exiting substitution via %s", op_name[op->op_type]);
985 warn("Exiting subroutine via %s", op_name[op->op_type]);
989 warn("Exiting eval via %s", op_name[op->op_type]);
993 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
996 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1007 register PERL_CONTEXT *cx;
1011 while (cxstack_ix > cxix) {
1012 cx = &cxstack[cxstack_ix];
1013 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1014 (long) cxstack_ix, block_type[cx->cx_type]));
1015 /* Note: we don't need to restore the base context info till the end. */
1016 switch (cx->cx_type) {
1019 continue; /* not break */
1037 die_where(char *message)
1042 register PERL_CONTEXT *cx;
1049 STRLEN klen = strlen(message);
1051 svp = hv_fetch(ERRHV, message, klen, TRUE);
1054 static char prefix[] = "\t(in cleanup) ";
1056 sv_upgrade(*svp, SVt_IV);
1057 (void)SvIOK_only(*svp);
1060 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1061 sv_catpvn(err, prefix, sizeof(prefix)-1);
1062 sv_catpvn(err, message, klen);
1068 sv_setpv(ERRSV, message);
1071 message = SvPVx(ERRSV, na);
1073 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) {
1081 if (cxix < cxstack_ix)
1085 if (cx->cx_type != CXt_EVAL) {
1086 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1091 if (gimme == G_SCALAR)
1092 *++newsp = &sv_undef;
1097 if (optype == OP_REQUIRE) {
1098 char* msg = SvPVx(ERRSV, na);
1099 DIE("%s", *msg ? msg : "Compilation failed in require");
1101 return pop_return();
1104 PerlIO_printf(PerlIO_stderr(), "%s",message);
1105 PerlIO_flush(PerlIO_stderr());
1114 if (SvTRUE(left) != SvTRUE(right))
1126 RETURNOP(cLOGOP->op_other);
1135 RETURNOP(cLOGOP->op_other);
1141 register I32 cxix = dopoptosub(cxstack_ix);
1142 register PERL_CONTEXT *cx;
1154 if (GIMME != G_ARRAY)
1158 if (DBsub && cxix >= 0 &&
1159 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1163 cxix = dopoptosub(cxix - 1);
1165 cx = &cxstack[cxix];
1166 if (cxstack[cxix].cx_type == CXt_SUB) {
1167 dbcxix = dopoptosub(cxix - 1);
1168 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1169 field below is defined for any cx. */
1170 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1171 cx = &cxstack[dbcxix];
1174 if (GIMME != G_ARRAY) {
1175 hv = cx->blk_oldcop->cop_stash;
1180 sv_setpv(TARG, HvNAME(hv));
1186 hv = cx->blk_oldcop->cop_stash;
1190 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1191 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1192 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1195 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1197 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1198 PUSHs(sv_2mortal(sv));
1199 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1202 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1203 PUSHs(sv_2mortal(newSViv(0)));
1205 gimme = (I32)cx->blk_gimme;
1206 if (gimme == G_VOID)
1209 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1210 if (cx->cx_type == CXt_EVAL) {
1211 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1212 PUSHs(cx->blk_eval.cur_text);
1215 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1216 /* Require, put the name. */
1217 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1221 else if (cx->cx_type == CXt_SUB &&
1222 cx->blk_sub.hasargs &&
1223 curcop->cop_stash == debstash)
1225 AV *ary = cx->blk_sub.argarray;
1226 int off = AvARRAY(ary) - AvALLOC(ary);
1230 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1233 AvREAL_off(dbargs); /* XXX Should be REIFY */
1236 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1237 av_extend(dbargs, AvFILLp(ary) + off);
1238 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1239 AvFILLp(dbargs) = AvFILLp(ary) + off;
1245 sortcv(SV *a, SV *b)
1248 I32 oldsaveix = savestack_ix;
1249 I32 oldscopeix = scopestack_ix;
1253 stack_sp = stack_base;
1256 if (stack_sp != stack_base + 1)
1257 croak("Sort subroutine didn't return single value");
1258 if (!SvNIOKp(*stack_sp))
1259 croak("Sort subroutine didn't return a numeric value");
1260 result = SvIV(*stack_sp);
1261 while (scopestack_ix > oldscopeix) {
1264 leave_scope(oldsaveix);
1277 sv_reset(tmps, curcop->cop_stash);
1290 TAINT_NOT; /* Each statement is presumed innocent */
1291 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1294 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1298 register PERL_CONTEXT *cx;
1299 I32 gimme = G_ARRAY;
1306 DIE("No DB::DB routine defined");
1308 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1320 push_return(op->op_next);
1321 PUSHBLOCK(cx, CXt_SUB, SP);
1324 (void)SvREFCNT_inc(cv);
1326 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1327 RETURNOP(CvSTART(cv));
1341 register PERL_CONTEXT *cx;
1342 I32 gimme = GIMME_V;
1349 if (op->op_flags & OPf_SPECIAL)
1350 svp = save_threadsv(op->op_targ); /* per-thread variable */
1352 #endif /* USE_THREADS */
1354 svp = &curpad[op->op_targ]; /* "my" variable */
1359 (void)save_scalar(gv);
1360 svp = &GvSV(gv); /* symbol table variable */
1365 PUSHBLOCK(cx, CXt_LOOP, SP);
1366 PUSHLOOP(cx, svp, MARK);
1367 if (op->op_flags & OPf_STACKED)
1368 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1370 cx->blk_loop.iterary = curstack;
1371 AvFILLp(curstack) = SP - stack_base;
1372 cx->blk_loop.iterix = MARK - stack_base;
1381 register PERL_CONTEXT *cx;
1382 I32 gimme = GIMME_V;
1388 PUSHBLOCK(cx, CXt_LOOP, SP);
1389 PUSHLOOP(cx, 0, SP);
1397 register PERL_CONTEXT *cx;
1398 struct block_loop cxloop;
1406 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1409 if (gimme == G_VOID)
1411 else if (gimme == G_SCALAR) {
1413 *++newsp = sv_mortalcopy(*SP);
1415 *++newsp = &sv_undef;
1419 *++newsp = sv_mortalcopy(*++mark);
1420 TAINT_NOT; /* Each item is independent */
1426 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1427 curpm = newpm; /* ... and pop $1 et al */
1439 register PERL_CONTEXT *cx;
1440 struct block_sub cxsub;
1441 bool popsub2 = FALSE;
1447 if (curstackinfo->si_type == SI_SORT) {
1448 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1449 if (cxstack_ix > sortcxix)
1451 AvARRAY(curstack)[1] = *SP;
1452 stack_sp = stack_base + 1;
1457 cxix = dopoptosub(cxstack_ix);
1459 DIE("Can't return outside a subroutine");
1460 if (cxix < cxstack_ix)
1464 switch (cx->cx_type) {
1466 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1471 if (optype == OP_REQUIRE &&
1472 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1474 /* Unassume the success we assumed earlier. */
1475 char *name = cx->blk_eval.old_name;
1476 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1477 DIE("%s did not return a true value", name);
1481 DIE("panic: return");
1485 if (gimme == G_SCALAR) {
1487 *++newsp = (popsub2 && SvTEMP(*SP))
1488 ? *SP : sv_mortalcopy(*SP);
1490 *++newsp = &sv_undef;
1492 else if (gimme == G_ARRAY) {
1493 while (++MARK <= SP) {
1494 *++newsp = (popsub2 && SvTEMP(*MARK))
1495 ? *MARK : sv_mortalcopy(*MARK);
1496 TAINT_NOT; /* Each item is independent */
1501 /* Stack values are safe: */
1503 POPSUB2(); /* release CV and @_ ... */
1505 curpm = newpm; /* ... and pop $1 et al */
1508 return pop_return();
1515 register PERL_CONTEXT *cx;
1516 struct block_loop cxloop;
1517 struct block_sub cxsub;
1524 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1526 if (op->op_flags & OPf_SPECIAL) {
1527 cxix = dopoptoloop(cxstack_ix);
1529 DIE("Can't \"last\" outside a block");
1532 cxix = dopoptolabel(cPVOP->op_pv);
1534 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1536 if (cxix < cxstack_ix)
1540 switch (cx->cx_type) {
1542 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1544 nextop = cxloop.last_op->op_next;
1547 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1549 nextop = pop_return();
1553 nextop = pop_return();
1560 if (gimme == G_SCALAR) {
1562 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1563 ? *SP : sv_mortalcopy(*SP);
1565 *++newsp = &sv_undef;
1567 else if (gimme == G_ARRAY) {
1568 while (++MARK <= SP) {
1569 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1570 ? *MARK : sv_mortalcopy(*MARK);
1571 TAINT_NOT; /* Each item is independent */
1577 /* Stack values are safe: */
1580 POPLOOP2(); /* release loop vars ... */
1584 POPSUB2(); /* release CV and @_ ... */
1587 curpm = newpm; /* ... and pop $1 et al */
1596 register PERL_CONTEXT *cx;
1599 if (op->op_flags & OPf_SPECIAL) {
1600 cxix = dopoptoloop(cxstack_ix);
1602 DIE("Can't \"next\" outside a block");
1605 cxix = dopoptolabel(cPVOP->op_pv);
1607 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1609 if (cxix < cxstack_ix)
1613 oldsave = scopestack[scopestack_ix - 1];
1614 LEAVE_SCOPE(oldsave);
1615 return cx->blk_loop.next_op;
1621 register PERL_CONTEXT *cx;
1624 if (op->op_flags & OPf_SPECIAL) {
1625 cxix = dopoptoloop(cxstack_ix);
1627 DIE("Can't \"redo\" outside a block");
1630 cxix = dopoptolabel(cPVOP->op_pv);
1632 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1634 if (cxix < cxstack_ix)
1638 oldsave = scopestack[scopestack_ix - 1];
1639 LEAVE_SCOPE(oldsave);
1640 return cx->blk_loop.redo_op;
1643 static OP* lastgotoprobe;
1646 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1650 static char too_deep[] = "Target of goto is too deeply nested";
1654 if (o->op_type == OP_LEAVE ||
1655 o->op_type == OP_SCOPE ||
1656 o->op_type == OP_LEAVELOOP ||
1657 o->op_type == OP_LEAVETRY)
1659 *ops++ = cUNOPo->op_first;
1664 if (o->op_flags & OPf_KIDS) {
1665 /* First try all the kids at this level, since that's likeliest. */
1666 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1667 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1668 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1671 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1672 if (kid == lastgotoprobe)
1674 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1676 (ops[-1]->op_type != OP_NEXTSTATE &&
1677 ops[-1]->op_type != OP_DBSTATE)))
1679 if (o = dofindlabel(kid, label, ops, oplimit))
1689 return pp_goto(ARGS);
1698 register PERL_CONTEXT *cx;
1699 #define GOTO_DEPTH 64
1700 OP *enterops[GOTO_DEPTH];
1702 int do_dump = (op->op_type == OP_DUMP);
1705 if (op->op_flags & OPf_STACKED) {
1708 /* This egregious kludge implements goto &subroutine */
1709 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1711 register PERL_CONTEXT *cx;
1712 CV* cv = (CV*)SvRV(sv);
1717 if (!CvROOT(cv) && !CvXSUB(cv)) {
1719 SV *tmpstr = sv_newmortal();
1720 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1721 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1723 DIE("Goto undefined subroutine");
1726 /* First do some returnish stuff. */
1727 cxix = dopoptosub(cxstack_ix);
1729 DIE("Can't goto subroutine outside a subroutine");
1730 if (cxix < cxstack_ix)
1733 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1734 DIE("Can't goto subroutine from an eval-string");
1736 if (cx->cx_type == CXt_SUB &&
1737 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1738 AV* av = cx->blk_sub.argarray;
1740 items = AvFILLp(av) + 1;
1742 EXTEND(stack_sp, items); /* @_ could have been extended. */
1743 Copy(AvARRAY(av), stack_sp, items, SV*);
1746 SvREFCNT_dec(GvAV(defgv));
1747 GvAV(defgv) = cx->blk_sub.savearray;
1748 #endif /* USE_THREADS */
1752 if (cx->cx_type == CXt_SUB &&
1753 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1754 SvREFCNT_dec(cx->blk_sub.cv);
1755 oldsave = scopestack[scopestack_ix - 1];
1756 LEAVE_SCOPE(oldsave);
1758 /* Now do some callish stuff. */
1761 if (CvOLDSTYLE(cv)) {
1762 I32 (*fp3)_((int,int,int));
1767 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1768 items = (*fp3)(CvXSUBANY(cv).any_i32,
1769 mark - stack_base + 1,
1771 SP = stack_base + items;
1774 stack_sp--; /* There is no cv arg. */
1775 (void)(*CvXSUB(cv))(cv);
1778 return pop_return();
1781 AV* padlist = CvPADLIST(cv);
1782 SV** svp = AvARRAY(padlist);
1783 if (cx->cx_type == CXt_EVAL) {
1784 in_eval = cx->blk_eval.old_in_eval;
1785 eval_root = cx->blk_eval.old_eval_root;
1786 cx->cx_type = CXt_SUB;
1787 cx->blk_sub.hasargs = 0;
1789 cx->blk_sub.cv = cv;
1790 cx->blk_sub.olddepth = CvDEPTH(cv);
1792 if (CvDEPTH(cv) < 2)
1793 (void)SvREFCNT_inc(cv);
1794 else { /* save temporaries on recursion? */
1795 if (CvDEPTH(cv) == 100 && dowarn)
1796 sub_crush_depth(cv);
1797 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1798 AV *newpad = newAV();
1799 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1800 I32 ix = AvFILLp((AV*)svp[1]);
1801 svp = AvARRAY(svp[0]);
1802 for ( ;ix > 0; ix--) {
1803 if (svp[ix] != &sv_undef) {
1804 char *name = SvPVX(svp[ix]);
1805 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1808 /* outer lexical or anon code */
1809 av_store(newpad, ix,
1810 SvREFCNT_inc(oldpad[ix]) );
1812 else { /* our own lexical */
1814 av_store(newpad, ix, sv = (SV*)newAV());
1815 else if (*name == '%')
1816 av_store(newpad, ix, sv = (SV*)newHV());
1818 av_store(newpad, ix, sv = NEWSV(0,0));
1823 av_store(newpad, ix, sv = NEWSV(0,0));
1827 if (cx->blk_sub.hasargs) {
1830 av_store(newpad, 0, (SV*)av);
1831 AvFLAGS(av) = AVf_REIFY;
1833 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1834 AvFILLp(padlist) = CvDEPTH(cv);
1835 svp = AvARRAY(padlist);
1839 if (!cx->blk_sub.hasargs) {
1840 AV* av = (AV*)curpad[0];
1842 items = AvFILLp(av) + 1;
1844 /* Mark is at the end of the stack. */
1846 Copy(AvARRAY(av), SP + 1, items, SV*);
1851 #endif /* USE_THREADS */
1853 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1855 if (cx->blk_sub.hasargs)
1856 #endif /* USE_THREADS */
1858 AV* av = (AV*)curpad[0];
1862 cx->blk_sub.savearray = GvAV(defgv);
1863 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1864 #endif /* USE_THREADS */
1865 cx->blk_sub.argarray = av;
1868 if (items >= AvMAX(av) + 1) {
1870 if (AvARRAY(av) != ary) {
1871 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1872 SvPVX(av) = (char*)ary;
1874 if (items >= AvMAX(av) + 1) {
1875 AvMAX(av) = items - 1;
1876 Renew(ary,items+1,SV*);
1878 SvPVX(av) = (char*)ary;
1881 Copy(mark,AvARRAY(av),items,SV*);
1882 AvFILLp(av) = items - 1;
1890 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
1892 * We do not care about using sv to call CV;
1893 * it's for informational purposes only.
1895 SV *sv = GvSV(DBsub);
1898 if (PERLDB_SUB_NN) {
1899 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
1902 gv_efullname3(sv, CvGV(cv), Nullch);
1905 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
1906 PUSHMARK( stack_sp );
1907 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
1911 RETURNOP(CvSTART(cv));
1915 label = SvPV(sv,na);
1917 else if (op->op_flags & OPf_SPECIAL) {
1919 DIE("goto must have label");
1922 label = cPVOP->op_pv;
1924 if (label && *label) {
1931 for (ix = cxstack_ix; ix >= 0; ix--) {
1933 switch (cx->cx_type) {
1935 gotoprobe = eval_root; /* XXX not good for nested eval */
1938 gotoprobe = cx->blk_oldcop->op_sibling;
1944 gotoprobe = cx->blk_oldcop->op_sibling;
1946 gotoprobe = main_root;
1949 if (CvDEPTH(cx->blk_sub.cv)) {
1950 gotoprobe = CvROOT(cx->blk_sub.cv);
1955 DIE("Can't \"goto\" outside a block");
1959 gotoprobe = main_root;
1962 retop = dofindlabel(gotoprobe, label,
1963 enterops, enterops + GOTO_DEPTH);
1966 lastgotoprobe = gotoprobe;
1969 DIE("Can't find label %s", label);
1971 /* pop unwanted frames */
1973 if (ix < cxstack_ix) {
1980 oldsave = scopestack[scopestack_ix];
1981 LEAVE_SCOPE(oldsave);
1984 /* push wanted frames */
1986 if (*enterops && enterops[1]) {
1988 for (ix = 1; enterops[ix]; ix++) {
1990 /* Eventually we may want to stack the needed arguments
1991 * for each op. For now, we punt on the hard ones. */
1992 if (op->op_type == OP_ENTERITER)
1993 DIE("Can't \"goto\" into the middle of a foreach loop",
1995 (*op->op_ppaddr)(ARGS);
2003 if (!retop) retop = main_start;
2010 restartop = 0; /* hmm, must be GNU unexec().. */
2014 if (top_env->je_prev) {
2032 if (anum == 1 && VMSISH_EXIT)
2045 double value = SvNVx(GvSV(cCOP->cop_gv));
2046 register I32 match = I_32(value);
2049 if (((double)match) > value)
2050 --match; /* was fractional--truncate other way */
2052 match -= cCOP->uop.scop.scop_offset;
2055 else if (match > cCOP->uop.scop.scop_max)
2056 match = cCOP->uop.scop.scop_max;
2057 op = cCOP->uop.scop.scop_next[match];
2067 op = op->op_next; /* can't assume anything */
2069 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2070 match -= cCOP->uop.scop.scop_offset;
2073 else if (match > cCOP->uop.scop.scop_max)
2074 match = cCOP->uop.scop.scop_max;
2075 op = cCOP->uop.scop.scop_next[match];
2084 save_lines(AV *array, SV *sv)
2086 register char *s = SvPVX(sv);
2087 register char *send = SvPVX(sv) + SvCUR(sv);
2089 register I32 line = 1;
2091 while (s && s < send) {
2092 SV *tmpstr = NEWSV(85,0);
2094 sv_upgrade(tmpstr, SVt_PVMG);
2095 t = strchr(s, '\n');
2101 sv_setpvn(tmpstr, s, t - s);
2102 av_store(array, line++, tmpstr);
2117 assert(CATCH_GET == TRUE);
2118 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2122 default: /* topmost level handles it */
2129 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2145 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2146 /* sv Text to convert to OP tree. */
2147 /* startop op_free() this to undo. */
2148 /* code Short string id of the caller. */
2150 dSP; /* Make POPBLOCK work. */
2153 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2157 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2163 /* switch to eval mode */
2165 SAVESPTR(compiling.cop_filegv);
2166 SAVEI16(compiling.cop_line);
2167 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2168 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2169 compiling.cop_line = 1;
2170 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2171 deleting the eval's FILEGV from the stash before gv_check() runs
2172 (i.e. before run-time proper). To work around the coredump that
2173 ensues, we always turn GvMULTI_on for any globals that were
2174 introduced within evals. See force_ident(). GSAR 96-10-12 */
2175 safestr = savepv(tmpbuf);
2176 SAVEDELETE(defstash, safestr, strlen(safestr));
2178 #ifdef OP_IN_REGISTER
2186 op->op_type = 0; /* Avoid uninit warning. */
2187 op->op_flags = 0; /* Avoid uninit warning. */
2188 PUSHBLOCK(cx, CXt_EVAL, SP);
2189 PUSHEVAL(cx, 0, compiling.cop_filegv);
2190 rop = doeval(G_SCALAR, startop);
2194 (*startop)->op_type = OP_NULL;
2195 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2197 *avp = (AV*)SvREFCNT_inc(comppad);
2199 #ifdef OP_IN_REGISTER
2205 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2207 doeval(int gimme, OP** startop)
2220 /* set up a scratch pad */
2225 SAVESPTR(comppad_name);
2226 SAVEI32(comppad_name_fill);
2227 SAVEI32(min_intro_pending);
2228 SAVEI32(max_intro_pending);
2231 for (i = cxstack_ix - 1; i >= 0; i--) {
2232 PERL_CONTEXT *cx = &cxstack[i];
2233 if (cx->cx_type == CXt_EVAL)
2235 else if (cx->cx_type == CXt_SUB) {
2236 caller = cx->blk_sub.cv;
2242 compcv = (CV*)NEWSV(1104,0);
2243 sv_upgrade((SV *)compcv, SVt_PVCV);
2244 CvUNIQUE_on(compcv);
2246 CvOWNER(compcv) = 0;
2247 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2248 MUTEX_INIT(CvMUTEXP(compcv));
2249 #endif /* USE_THREADS */
2252 av_push(comppad, Nullsv);
2253 curpad = AvARRAY(comppad);
2254 comppad_name = newAV();
2255 comppad_name_fill = 0;
2256 min_intro_pending = 0;
2259 av_store(comppad_name, 0, newSVpv("@_", 2));
2260 curpad[0] = (SV*)newAV();
2261 SvPADMY_on(curpad[0]); /* XXX Needed? */
2262 #endif /* USE_THREADS */
2264 comppadlist = newAV();
2265 AvREAL_off(comppadlist);
2266 av_store(comppadlist, 0, (SV*)comppad_name);
2267 av_store(comppadlist, 1, (SV*)comppad);
2268 CvPADLIST(compcv) = comppadlist;
2270 if (!saveop || saveop->op_type != OP_REQUIRE)
2271 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2275 /* make sure we compile in the right package */
2277 newstash = curcop->cop_stash;
2278 if (curstash != newstash) {
2280 curstash = newstash;
2284 SAVEFREESV(beginav);
2286 /* try to compile it */
2290 curcop = &compiling;
2291 curcop->cop_arybase = 0;
2293 rs = newSVpv("\n", 1);
2294 if (saveop && saveop->op_flags & OPf_SPECIAL)
2298 if (yyparse() || error_count || !eval_root) {
2302 I32 optype = 0; /* Might be reset by POPEVAL. */
2309 SP = stack_base + POPMARK; /* pop original mark */
2317 if (optype == OP_REQUIRE) {
2318 char* msg = SvPVx(ERRSV, na);
2319 DIE("%s", *msg ? msg : "Compilation failed in require");
2320 } else if (startop) {
2321 char* msg = SvPVx(ERRSV, na);
2325 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2328 rs = SvREFCNT_inc(nrs);
2330 MUTEX_LOCK(&eval_mutex);
2332 COND_SIGNAL(&eval_cond);
2333 MUTEX_UNLOCK(&eval_mutex);
2334 #endif /* USE_THREADS */
2338 rs = SvREFCNT_inc(nrs);
2339 compiling.cop_line = 0;
2341 *startop = eval_root;
2342 SvREFCNT_dec(CvOUTSIDE(compcv));
2343 CvOUTSIDE(compcv) = Nullcv;
2345 SAVEFREEOP(eval_root);
2347 scalarvoid(eval_root);
2348 else if (gimme & G_ARRAY)
2353 DEBUG_x(dump_eval());
2355 /* Register with debugger: */
2356 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2357 CV *cv = perl_get_cv("DB::postponed", FALSE);
2361 XPUSHs((SV*)compiling.cop_filegv);
2363 perl_call_sv((SV*)cv, G_DISCARD);
2367 /* compiled okay, so do it */
2369 CvDEPTH(compcv) = 1;
2370 SP = stack_base + POPMARK; /* pop original mark */
2371 op = saveop; /* The caller may need it. */
2373 MUTEX_LOCK(&eval_mutex);
2375 COND_SIGNAL(&eval_cond);
2376 MUTEX_UNLOCK(&eval_mutex);
2377 #endif /* USE_THREADS */
2379 RETURNOP(eval_start);
2385 register PERL_CONTEXT *cx;
2390 SV *namesv = Nullsv;
2392 I32 gimme = G_SCALAR;
2393 PerlIO *tryrsfp = 0;
2396 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2397 SET_NUMERIC_STANDARD();
2398 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2399 DIE("Perl %s required--this is only version %s, stopped",
2400 SvPV(sv,na),patchlevel);
2403 name = SvPV(sv, len);
2404 if (!(name && len > 0 && *name))
2405 DIE("Null filename used");
2406 TAINT_PROPER("require");
2407 if (op->op_type == OP_REQUIRE &&
2408 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2412 /* prepare to compile file */
2417 (name[1] == '.' && name[2] == '/')))
2419 || (name[0] && name[1] == ':')
2422 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2425 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2426 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2431 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2434 AV *ar = GvAVn(incgv);
2438 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2441 namesv = NEWSV(806, 0);
2442 for (i = 0; i <= AvFILL(ar); i++) {
2443 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2446 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2448 sv_setpv(namesv, unixdir);
2449 sv_catpv(namesv, unixname);
2451 sv_setpvf(namesv, "%s/%s", dir, name);
2453 tryname = SvPVX(namesv);
2454 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2456 if (tryname[0] == '.' && tryname[1] == '/')
2463 SAVESPTR(compiling.cop_filegv);
2464 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2465 SvREFCNT_dec(namesv);
2467 if (op->op_type == OP_REQUIRE) {
2468 SV *msg = sv_2mortal(newSVpvf("Can't locate '%s' in @INC", name));
2469 SV *dirmsgsv = NEWSV(0, 0);
2470 AV *ar = GvAVn(incgv);
2472 if (instr(SvPVX(msg), ".h "))
2473 sv_catpv(msg, " (change .h to .ph maybe?)");
2474 if (instr(SvPVX(msg), ".ph "))
2475 sv_catpv(msg, " (did you run h2ph?)");
2476 sv_catpv(msg, " (@INC contains:");
2477 for (i = 0; i <= AvFILL(ar); i++) {
2478 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2479 sv_setpvf(dirmsgsv, " %s", dir);
2480 sv_catsv(msg, dirmsgsv);
2482 sv_catpvn(msg, ")", 1);
2483 SvREFCNT_dec(dirmsgsv);
2490 /* Assume success here to prevent recursive requirement. */
2491 (void)hv_store(GvHVn(incgv), name, strlen(name),
2492 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2496 lex_start(sv_2mortal(newSVpv("",0)));
2498 save_aptr(&rsfp_filters);
2499 rsfp_filters = NULL;
2503 name = savepv(name);
2508 /* switch to eval mode */
2510 push_return(op->op_next);
2511 PUSHBLOCK(cx, CXt_EVAL, SP);
2512 PUSHEVAL(cx, name, compiling.cop_filegv);
2514 compiling.cop_line = 0;
2518 MUTEX_LOCK(&eval_mutex);
2519 if (eval_owner && eval_owner != thr)
2521 COND_WAIT(&eval_cond, &eval_mutex);
2523 MUTEX_UNLOCK(&eval_mutex);
2524 #endif /* USE_THREADS */
2525 return DOCATCH(doeval(G_SCALAR, NULL));
2530 return pp_require(ARGS);
2536 register PERL_CONTEXT *cx;
2538 I32 gimme = GIMME_V, was = sub_generation;
2539 char tmpbuf[TYPE_DIGITS(long) + 12];
2544 if (!SvPV(sv,len) || !len)
2546 TAINT_PROPER("eval");
2552 /* switch to eval mode */
2554 SAVESPTR(compiling.cop_filegv);
2555 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2556 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2557 compiling.cop_line = 1;
2558 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2559 deleting the eval's FILEGV from the stash before gv_check() runs
2560 (i.e. before run-time proper). To work around the coredump that
2561 ensues, we always turn GvMULTI_on for any globals that were
2562 introduced within evals. See force_ident(). GSAR 96-10-12 */
2563 safestr = savepv(tmpbuf);
2564 SAVEDELETE(defstash, safestr, strlen(safestr));
2566 hints = op->op_targ;
2568 push_return(op->op_next);
2569 PUSHBLOCK(cx, CXt_EVAL, SP);
2570 PUSHEVAL(cx, 0, compiling.cop_filegv);
2572 /* prepare to compile string */
2574 if (PERLDB_LINE && curstash != debstash)
2575 save_lines(GvAV(compiling.cop_filegv), linestr);
2578 MUTEX_LOCK(&eval_mutex);
2579 if (eval_owner && eval_owner != thr)
2581 COND_WAIT(&eval_cond, &eval_mutex);
2583 MUTEX_UNLOCK(&eval_mutex);
2584 #endif /* USE_THREADS */
2585 ret = doeval(gimme, NULL);
2586 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2587 && ret != op->op_next) { /* Successive compilation. */
2588 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2590 return DOCATCH(ret);
2600 register PERL_CONTEXT *cx;
2602 U8 save_flags = op -> op_flags;
2607 retop = pop_return();
2610 if (gimme == G_VOID)
2612 else if (gimme == G_SCALAR) {
2615 if (SvFLAGS(TOPs) & SVs_TEMP)
2618 *MARK = sv_mortalcopy(TOPs);
2626 /* in case LEAVE wipes old return values */
2627 for (mark = newsp + 1; mark <= SP; mark++) {
2628 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2629 *mark = sv_mortalcopy(*mark);
2630 TAINT_NOT; /* Each item is independent */
2634 curpm = newpm; /* Don't pop $1 et al till now */
2637 * Closures mentioned at top level of eval cannot be referenced
2638 * again, and their presence indirectly causes a memory leak.
2639 * (Note that the fact that compcv and friends are still set here
2640 * is, AFAIK, an accident.) --Chip
2642 if (AvFILLp(comppad_name) >= 0) {
2643 SV **svp = AvARRAY(comppad_name);
2645 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2647 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2649 svp[ix] = &sv_undef;
2653 SvREFCNT_dec(CvOUTSIDE(sv));
2654 CvOUTSIDE(sv) = Nullcv;
2667 assert(CvDEPTH(compcv) == 1);
2669 CvDEPTH(compcv) = 0;
2672 if (optype == OP_REQUIRE &&
2673 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
2675 /* Unassume the success we assumed earlier. */
2676 char *name = cx->blk_eval.old_name;
2677 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2678 retop = die("%s did not return a true value", name);
2679 /* die_where() did LEAVE, or we won't be here */
2683 if (!(save_flags & OPf_SPECIAL))
2693 register PERL_CONTEXT *cx;
2694 I32 gimme = GIMME_V;
2699 push_return(cLOGOP->op_other->op_next);
2700 PUSHBLOCK(cx, CXt_EVAL, SP);
2702 eval_root = op; /* Only needed so that goto works right. */
2707 return DOCATCH(op->op_next);
2717 register PERL_CONTEXT *cx;
2725 if (gimme == G_VOID)
2727 else if (gimme == G_SCALAR) {
2730 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2733 *MARK = sv_mortalcopy(TOPs);
2742 /* in case LEAVE wipes old return values */
2743 for (mark = newsp + 1; mark <= SP; mark++) {
2744 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2745 *mark = sv_mortalcopy(*mark);
2746 TAINT_NOT; /* Each item is independent */
2750 curpm = newpm; /* Don't pop $1 et al till now */
2761 register char *s = SvPV_force(sv, len);
2762 register char *send = s + len;
2763 register char *base;
2764 register I32 skipspaces = 0;
2767 bool postspace = FALSE;
2775 croak("Null picture in formline");
2777 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2782 *fpc++ = FF_LINEMARK;
2783 noblank = repeat = FALSE;
2801 case ' ': case '\t':
2812 *fpc++ = FF_LITERAL;
2820 *fpc++ = skipspaces;
2824 *fpc++ = FF_NEWLINE;
2828 arg = fpc - linepc + 1;
2835 *fpc++ = FF_LINEMARK;
2836 noblank = repeat = FALSE;
2845 ischop = s[-1] == '^';
2851 arg = (s - base) - 1;
2853 *fpc++ = FF_LITERAL;
2862 *fpc++ = FF_LINEGLOB;
2864 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2865 arg = ischop ? 512 : 0;
2875 arg |= 256 + (s - f);
2877 *fpc++ = s - base; /* fieldsize for FETCH */
2878 *fpc++ = FF_DECIMAL;
2883 bool ismore = FALSE;
2886 while (*++s == '>') ;
2887 prespace = FF_SPACE;
2889 else if (*s == '|') {
2890 while (*++s == '|') ;
2891 prespace = FF_HALFSPACE;
2896 while (*++s == '<') ;
2899 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2903 *fpc++ = s - base; /* fieldsize for FETCH */
2905 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2923 { /* need to jump to the next word */
2925 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2926 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2927 s = SvPVX(sv) + SvCUR(sv) + z;
2929 Copy(fops, s, arg, U16);
2931 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2936 * The rest of this file was derived from source code contributed
2939 * NOTE: this code was derived from Tom Horsley's qsort replacement
2940 * and should not be confused with the original code.
2943 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2945 Permission granted to distribute under the same terms as perl which are
2948 This program is free software; you can redistribute it and/or modify
2949 it under the terms of either:
2951 a) the GNU General Public License as published by the Free
2952 Software Foundation; either version 1, or (at your option) any
2955 b) the "Artistic License" which comes with this Kit.
2957 Details on the perl license can be found in the perl source code which
2958 may be located via the www.perl.com web page.
2960 This is the most wonderfulest possible qsort I can come up with (and
2961 still be mostly portable) My (limited) tests indicate it consistently
2962 does about 20% fewer calls to compare than does the qsort in the Visual
2963 C++ library, other vendors may vary.
2965 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2966 others I invented myself (or more likely re-invented since they seemed
2967 pretty obvious once I watched the algorithm operate for a while).
2969 Most of this code was written while watching the Marlins sweep the Giants
2970 in the 1997 National League Playoffs - no Braves fans allowed to use this
2971 code (just kidding :-).
2973 I realize that if I wanted to be true to the perl tradition, the only
2974 comment in this file would be something like:
2976 ...they shuffled back towards the rear of the line. 'No, not at the
2977 rear!' the slave-driver shouted. 'Three files up. And stay there...
2979 However, I really needed to violate that tradition just so I could keep
2980 track of what happens myself, not to mention some poor fool trying to
2981 understand this years from now :-).
2984 /* ********************************************************** Configuration */
2986 #ifndef QSORT_ORDER_GUESS
2987 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
2990 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
2991 future processing - a good max upper bound is log base 2 of memory size
2992 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
2993 safely be smaller than that since the program is taking up some space and
2994 most operating systems only let you grab some subset of contiguous
2995 memory (not to mention that you are normally sorting data larger than
2996 1 byte element size :-).
2998 #ifndef QSORT_MAX_STACK
2999 #define QSORT_MAX_STACK 32
3002 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3003 Anything bigger and we use qsort. If you make this too small, the qsort
3004 will probably break (or become less efficient), because it doesn't expect
3005 the middle element of a partition to be the same as the right or left -
3006 you have been warned).
3008 #ifndef QSORT_BREAK_EVEN
3009 #define QSORT_BREAK_EVEN 6
3012 /* ************************************************************* Data Types */
3014 /* hold left and right index values of a partition waiting to be sorted (the
3015 partition includes both left and right - right is NOT one past the end or
3016 anything like that).
3018 struct partition_stack_entry {
3021 #ifdef QSORT_ORDER_GUESS
3022 int qsort_break_even;
3026 /* ******************************************************* Shorthand Macros */
3028 /* Note that these macros will be used from inside the qsort function where
3029 we happen to know that the variable 'elt_size' contains the size of an
3030 array element and the variable 'temp' points to enough space to hold a
3031 temp element and the variable 'array' points to the array being sorted
3032 and 'compare' is the pointer to the compare routine.
3034 Also note that there are very many highly architecture specific ways
3035 these might be sped up, but this is simply the most generally portable
3036 code I could think of.
3039 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3041 #define qsort_cmp(elt1, elt2) \
3042 ((*compare)(array[elt1], array[elt2]))
3044 #ifdef QSORT_ORDER_GUESS
3045 #define QSORT_NOTICE_SWAP swapped++;
3047 #define QSORT_NOTICE_SWAP
3050 /* swaps contents of array elements elt1, elt2.
3052 #define qsort_swap(elt1, elt2) \
3055 temp = array[elt1]; \
3056 array[elt1] = array[elt2]; \
3057 array[elt2] = temp; \
3060 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3061 elt3 and elt3 gets elt1.
3063 #define qsort_rotate(elt1, elt2, elt3) \
3066 temp = array[elt1]; \
3067 array[elt1] = array[elt2]; \
3068 array[elt2] = array[elt3]; \
3069 array[elt3] = temp; \
3072 /* ************************************************************ Debug stuff */
3079 return; /* good place to set a breakpoint */
3082 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3085 doqsort_all_asserts(
3089 int (*compare)(const void * elt1, const void * elt2),
3090 int pc_left, int pc_right, int u_left, int u_right)
3094 qsort_assert(pc_left <= pc_right);
3095 qsort_assert(u_right < pc_left);
3096 qsort_assert(pc_right < u_left);
3097 for (i = u_right + 1; i < pc_left; ++i) {
3098 qsort_assert(qsort_cmp(i, pc_left) < 0);
3100 for (i = pc_left; i < pc_right; ++i) {
3101 qsort_assert(qsort_cmp(i, pc_right) == 0);
3103 for (i = pc_right + 1; i < u_left; ++i) {
3104 qsort_assert(qsort_cmp(pc_right, i) < 0);
3108 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3109 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3110 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3114 #define qsort_assert(t) ((void)0)
3116 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3120 /* ****************************************************************** qsort */
3126 I32 (*compare)(SV *a, SV *b))
3130 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3131 int next_stack_entry = 0;
3135 #ifdef QSORT_ORDER_GUESS
3136 int qsort_break_even;
3140 /* Make sure we actually have work to do.
3142 if (num_elts <= 1) {
3146 /* Setup the initial partition definition and fall into the sorting loop
3149 part_right = (int)(num_elts - 1);
3150 #ifdef QSORT_ORDER_GUESS
3151 qsort_break_even = QSORT_BREAK_EVEN;
3153 #define qsort_break_even QSORT_BREAK_EVEN
3156 if ((part_right - part_left) >= qsort_break_even) {
3157 /* OK, this is gonna get hairy, so lets try to document all the
3158 concepts and abbreviations and variables and what they keep
3161 pc: pivot chunk - the set of array elements we accumulate in the
3162 middle of the partition, all equal in value to the original
3163 pivot element selected. The pc is defined by:
3165 pc_left - the leftmost array index of the pc
3166 pc_right - the rightmost array index of the pc
3168 we start with pc_left == pc_right and only one element
3169 in the pivot chunk (but it can grow during the scan).
3171 u: uncompared elements - the set of elements in the partition
3172 we have not yet compared to the pivot value. There are two
3173 uncompared sets during the scan - one to the left of the pc
3174 and one to the right.
3176 u_right - the rightmost index of the left side's uncompared set
3177 u_left - the leftmost index of the right side's uncompared set
3179 The leftmost index of the left sides's uncompared set
3180 doesn't need its own variable because it is always defined
3181 by the leftmost edge of the whole partition (part_left). The
3182 same goes for the rightmost edge of the right partition
3185 We know there are no uncompared elements on the left once we
3186 get u_right < part_left and no uncompared elements on the
3187 right once u_left > part_right. When both these conditions
3188 are met, we have completed the scan of the partition.
3190 Any elements which are between the pivot chunk and the
3191 uncompared elements should be less than the pivot value on
3192 the left side and greater than the pivot value on the right
3193 side (in fact, the goal of the whole algorithm is to arrange
3194 for that to be true and make the groups of less-than and
3195 greater-then elements into new partitions to sort again).
3197 As you marvel at the complexity of the code and wonder why it
3198 has to be so confusing. Consider some of the things this level
3199 of confusion brings:
3201 Once I do a compare, I squeeze every ounce of juice out of it. I
3202 never do compare calls I don't have to do, and I certainly never
3205 I also never swap any elements unless I can prove there is a
3206 good reason. Many sort algorithms will swap a known value with
3207 an uncompared value just to get things in the right place (or
3208 avoid complexity :-), but that uncompared value, once it gets
3209 compared, may then have to be swapped again. A lot of the
3210 complexity of this code is due to the fact that it never swaps
3211 anything except compared values, and it only swaps them when the
3212 compare shows they are out of position.
3214 int pc_left, pc_right;
3215 int u_right, u_left;
3219 pc_left = ((part_left + part_right) / 2);
3221 u_right = pc_left - 1;
3222 u_left = pc_right + 1;
3224 /* Qsort works best when the pivot value is also the median value
3225 in the partition (unfortunately you can't find the median value
3226 without first sorting :-), so to give the algorithm a helping
3227 hand, we pick 3 elements and sort them and use the median value
3228 of that tiny set as the pivot value.
3230 Some versions of qsort like to use the left middle and right as
3231 the 3 elements to sort so they can insure the ends of the
3232 partition will contain values which will stop the scan in the
3233 compare loop, but when you have to call an arbitrarily complex
3234 routine to do a compare, its really better to just keep track of
3235 array index values to know when you hit the edge of the
3236 partition and avoid the extra compare. An even better reason to
3237 avoid using a compare call is the fact that you can drop off the
3238 edge of the array if someone foolishly provides you with an
3239 unstable compare function that doesn't always provide consistent
3242 So, since it is simpler for us to compare the three adjacent
3243 elements in the middle of the partition, those are the ones we
3244 pick here (conveniently pointed at by u_right, pc_left, and
3245 u_left). The values of the left, center, and right elements
3246 are refered to as l c and r in the following comments.
3249 #ifdef QSORT_ORDER_GUESS
3252 s = qsort_cmp(u_right, pc_left);
3255 s = qsort_cmp(pc_left, u_left);
3256 /* if l < c, c < r - already in order - nothing to do */
3258 /* l < c, c == r - already in order, pc grows */
3260 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3262 /* l < c, c > r - need to know more */
3263 s = qsort_cmp(u_right, u_left);
3265 /* l < c, c > r, l < r - swap c & r to get ordered */
3266 qsort_swap(pc_left, u_left);
3267 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3268 } else if (s == 0) {
3269 /* l < c, c > r, l == r - swap c&r, grow pc */
3270 qsort_swap(pc_left, u_left);
3272 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3274 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3275 qsort_rotate(pc_left, u_right, u_left);
3276 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3279 } else if (s == 0) {
3281 s = qsort_cmp(pc_left, u_left);
3283 /* l == c, c < r - already in order, grow pc */
3285 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3286 } else if (s == 0) {
3287 /* l == c, c == r - already in order, grow pc both ways */
3290 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3292 /* l == c, c > r - swap l & r, grow pc */
3293 qsort_swap(u_right, u_left);
3295 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3299 s = qsort_cmp(pc_left, u_left);
3301 /* l > c, c < r - need to know more */
3302 s = qsort_cmp(u_right, u_left);
3304 /* l > c, c < r, l < r - swap l & c to get ordered */
3305 qsort_swap(u_right, pc_left);
3306 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3307 } else if (s == 0) {
3308 /* l > c, c < r, l == r - swap l & c, grow pc */
3309 qsort_swap(u_right, pc_left);
3311 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3313 /* l > c, c < r, l > r - rotate lcr into crl to order */
3314 qsort_rotate(u_right, pc_left, u_left);
3315 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3317 } else if (s == 0) {
3318 /* l > c, c == r - swap ends, grow pc */
3319 qsort_swap(u_right, u_left);
3321 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3323 /* l > c, c > r - swap ends to get in order */
3324 qsort_swap(u_right, u_left);
3325 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3328 /* We now know the 3 middle elements have been compared and
3329 arranged in the desired order, so we can shrink the uncompared
3334 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3336 /* The above massive nested if was the simple part :-). We now have
3337 the middle 3 elements ordered and we need to scan through the
3338 uncompared sets on either side, swapping elements that are on
3339 the wrong side or simply shuffling equal elements around to get
3340 all equal elements into the pivot chunk.
3344 int still_work_on_left;
3345 int still_work_on_right;
3347 /* Scan the uncompared values on the left. If I find a value
3348 equal to the pivot value, move it over so it is adjacent to
3349 the pivot chunk and expand the pivot chunk. If I find a value
3350 less than the pivot value, then just leave it - its already
3351 on the correct side of the partition. If I find a greater
3352 value, then stop the scan.
3354 while (still_work_on_left = (u_right >= part_left)) {
3355 s = qsort_cmp(u_right, pc_left);
3358 } else if (s == 0) {
3360 if (pc_left != u_right) {
3361 qsort_swap(u_right, pc_left);
3367 qsort_assert(u_right < pc_left);
3368 qsort_assert(pc_left <= pc_right);
3369 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3370 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3373 /* Do a mirror image scan of uncompared values on the right
3375 while (still_work_on_right = (u_left <= part_right)) {
3376 s = qsort_cmp(pc_right, u_left);
3379 } else if (s == 0) {
3381 if (pc_right != u_left) {
3382 qsort_swap(pc_right, u_left);
3388 qsort_assert(u_left > pc_right);
3389 qsort_assert(pc_left <= pc_right);
3390 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3391 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3394 if (still_work_on_left) {
3395 /* I know I have a value on the left side which needs to be
3396 on the right side, but I need to know more to decide
3397 exactly the best thing to do with it.
3399 if (still_work_on_right) {
3400 /* I know I have values on both side which are out of
3401 position. This is a big win because I kill two birds
3402 with one swap (so to speak). I can advance the
3403 uncompared pointers on both sides after swapping both
3404 of them into the right place.
3406 qsort_swap(u_right, u_left);
3409 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3411 /* I have an out of position value on the left, but the
3412 right is fully scanned, so I "slide" the pivot chunk
3413 and any less-than values left one to make room for the
3414 greater value over on the right. If the out of position
3415 value is immediately adjacent to the pivot chunk (there
3416 are no less-than values), I can do that with a swap,
3417 otherwise, I have to rotate one of the less than values
3418 into the former position of the out of position value
3419 and the right end of the pivot chunk into the left end
3423 if (pc_left == u_right) {
3424 qsort_swap(u_right, pc_right);
3425 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3427 qsort_rotate(u_right, pc_left, pc_right);
3428 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3433 } else if (still_work_on_right) {
3434 /* Mirror image of complex case above: I have an out of
3435 position value on the right, but the left is fully
3436 scanned, so I need to shuffle things around to make room
3437 for the right value on the left.
3440 if (pc_right == u_left) {
3441 qsort_swap(u_left, pc_left);
3442 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3444 qsort_rotate(pc_right, pc_left, u_left);
3445 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3450 /* No more scanning required on either side of partition,
3451 break out of loop and figure out next set of partitions
3457 /* The elements in the pivot chunk are now in the right place. They
3458 will never move or be compared again. All I have to do is decide
3459 what to do with the stuff to the left and right of the pivot
3462 Notes on the QSORT_ORDER_GUESS ifdef code:
3464 1. If I just built these partitions without swapping any (or
3465 very many) elements, there is a chance that the elements are
3466 already ordered properly (being properly ordered will
3467 certainly result in no swapping, but the converse can't be
3470 2. A (properly written) insertion sort will run faster on
3471 already ordered data than qsort will.
3473 3. Perhaps there is some way to make a good guess about
3474 switching to an insertion sort earlier than partition size 6
3475 (for instance - we could save the partition size on the stack
3476 and increase the size each time we find we didn't swap, thus
3477 switching to insertion sort earlier for partitions with a
3478 history of not swapping).
3480 4. Naturally, if I just switch right away, it will make
3481 artificial benchmarks with pure ascending (or descending)
3482 data look really good, but is that a good reason in general?
3486 #ifdef QSORT_ORDER_GUESS
3488 #if QSORT_ORDER_GUESS == 1
3489 qsort_break_even = (part_right - part_left) + 1;
3491 #if QSORT_ORDER_GUESS == 2
3492 qsort_break_even *= 2;
3494 #if QSORT_ORDER_GUESS == 3
3495 int prev_break = qsort_break_even;
3496 qsort_break_even *= qsort_break_even;
3497 if (qsort_break_even < prev_break) {
3498 qsort_break_even = (part_right - part_left) + 1;
3502 qsort_break_even = QSORT_BREAK_EVEN;
3506 if (part_left < pc_left) {
3507 /* There are elements on the left which need more processing.
3508 Check the right as well before deciding what to do.
3510 if (pc_right < part_right) {
3511 /* We have two partitions to be sorted. Stack the biggest one
3512 and process the smallest one on the next iteration. This
3513 minimizes the stack height by insuring that any additional
3514 stack entries must come from the smallest partition which
3515 (because it is smallest) will have the fewest
3516 opportunities to generate additional stack entries.
3518 if ((part_right - pc_right) > (pc_left - part_left)) {
3519 /* stack the right partition, process the left */
3520 partition_stack[next_stack_entry].left = pc_right + 1;
3521 partition_stack[next_stack_entry].right = part_right;
3522 #ifdef QSORT_ORDER_GUESS
3523 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3525 part_right = pc_left - 1;
3527 /* stack the left partition, process the right */
3528 partition_stack[next_stack_entry].left = part_left;
3529 partition_stack[next_stack_entry].right = pc_left - 1;
3530 #ifdef QSORT_ORDER_GUESS
3531 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3533 part_left = pc_right + 1;
3535 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3538 /* The elements on the left are the only remaining elements
3539 that need sorting, arrange for them to be processed as the
3542 part_right = pc_left - 1;
3544 } else if (pc_right < part_right) {
3545 /* There is only one chunk on the right to be sorted, make it
3546 the new partition and loop back around.
3548 part_left = pc_right + 1;
3550 /* This whole partition wound up in the pivot chunk, so
3551 we need to get a new partition off the stack.
3553 if (next_stack_entry == 0) {
3554 /* the stack is empty - we are done */
3558 part_left = partition_stack[next_stack_entry].left;
3559 part_right = partition_stack[next_stack_entry].right;
3560 #ifdef QSORT_ORDER_GUESS
3561 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3565 /* This partition is too small to fool with qsort complexity, just
3566 do an ordinary insertion sort to minimize overhead.
3569 /* Assume 1st element is in right place already, and start checking
3570 at 2nd element to see where it should be inserted.
3572 for (i = part_left + 1; i <= part_right; ++i) {
3574 /* Scan (backwards - just in case 'i' is already in right place)
3575 through the elements already sorted to see if the ith element
3576 belongs ahead of one of them.
3578 for (j = i - 1; j >= part_left; --j) {
3579 if (qsort_cmp(i, j) >= 0) {
3580 /* i belongs right after j
3587 /* Looks like we really need to move some things
3591 for (k = i - 1; k >= j; --k)
3592 array[k + 1] = array[k];
3597 /* That partition is now sorted, grab the next one, or get out
3598 of the loop if there aren't any more.
3601 if (next_stack_entry == 0) {
3602 /* the stack is empty - we are done */
3606 part_left = partition_stack[next_stack_entry].left;
3607 part_right = partition_stack[next_stack_entry].right;
3608 #ifdef QSORT_ORDER_GUESS
3609 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3614 /* Believe it or not, the array is sorted at this point! */