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 /* JMR: Check against the last compiled regexp
90 To know for sure, we'd need the length of precomp.
91 But we don't have it, so we must ... take a guess. */
92 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
93 memNE(pm->op_pmregexp->precomp, t, len + 1))
95 if (pm->op_pmregexp) {
96 ReREFCNT_dec(pm->op_pmregexp);
97 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
100 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
101 pm->op_pmregexp = pregcomp(t, t + len, pm);
105 if (!pm->op_pmregexp->prelen && curpm)
107 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
108 pm->op_pmflags |= PMf_WHITE;
110 if (pm->op_pmflags & PMf_KEEP) {
111 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
112 cLOGOP->op_first->op_next = op->op_next;
120 register PMOP *pm = (PMOP*) cLOGOP->op_other;
121 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
122 register SV *dstr = cx->sb_dstr;
123 register char *s = cx->sb_s;
124 register char *m = cx->sb_m;
125 char *orig = cx->sb_orig;
126 register REGEXP *rx = cx->sb_rx;
128 rxres_restore(&cx->sb_rxres, rx);
130 if (cx->sb_iters++) {
131 if (cx->sb_iters > cx->sb_maxiters)
132 DIE("Substitution loop");
134 if (!cx->sb_rxtainted)
135 cx->sb_rxtainted = SvTAINTED(TOPs);
136 sv_catsv(dstr, POPs);
139 if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
140 s == m, Nullsv, NULL,
141 cx->sb_safebase ? 0 : REXEC_COPY_STR))
143 SV *targ = cx->sb_targ;
144 sv_catpvn(dstr, s, cx->sb_strend - s);
146 TAINT_IF(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));
155 (void)SvPOK_only(targ);
159 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
160 LEAVE_SCOPE(cx->sb_oldsave);
162 RETURNOP(pm->op_next);
165 if (rx->subbase && rx->subbase != orig) {
168 cx->sb_orig = orig = rx->subbase;
170 cx->sb_strend = s + (cx->sb_strend - m);
172 cx->sb_m = m = rx->startp[0];
173 sv_catpvn(dstr, s, m-s);
174 cx->sb_s = rx->endp[0];
175 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
176 rxres_save(&cx->sb_rxres, rx);
177 RETURNOP(pm->op_pmreplstart);
181 rxres_save(void **rsp, REGEXP *rx)
186 if (!p || p[1] < rx->nparens) {
187 i = 6 + rx->nparens * 2;
195 *p++ = (UV)rx->subbase;
196 rx->subbase = Nullch;
200 *p++ = (UV)rx->subbeg;
201 *p++ = (UV)rx->subend;
202 for (i = 0; i <= rx->nparens; ++i) {
203 *p++ = (UV)rx->startp[i];
204 *p++ = (UV)rx->endp[i];
209 rxres_restore(void **rsp, REGEXP *rx)
214 Safefree(rx->subbase);
215 rx->subbase = (char*)(*p);
220 rx->subbeg = (char*)(*p++);
221 rx->subend = (char*)(*p++);
222 for (i = 0; i <= rx->nparens; ++i) {
223 rx->startp[i] = (char*)(*p++);
224 rx->endp[i] = (char*)(*p++);
229 rxres_free(void **rsp)
234 Safefree((char*)(*p));
242 djSP; dMARK; dORIGMARK;
243 register SV *form = *++MARK;
255 bool chopspace = (strchr(chopset, ' ') != Nullch);
262 if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
263 SvREADONLY_off(form);
267 SvPV_force(formtarget, len);
268 t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */
271 /* need to jump to the next word */
272 s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN;
281 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
282 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
283 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
284 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
285 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
287 case FF_CHECKNL: name = "CHECKNL"; break;
288 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
289 case FF_SPACE: name = "SPACE"; break;
290 case FF_HALFSPACE: name = "HALFSPACE"; break;
291 case FF_ITEM: name = "ITEM"; break;
292 case FF_CHOP: name = "CHOP"; break;
293 case FF_LINEGLOB: name = "LINEGLOB"; break;
294 case FF_NEWLINE: name = "NEWLINE"; break;
295 case FF_MORE: name = "MORE"; break;
296 case FF_LINEMARK: name = "LINEMARK"; break;
297 case FF_END: name = "END"; break;
300 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
302 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
331 warn("Not enough format arguments");
336 item = s = SvPV(sv, len);
338 if (itemsize > fieldsize)
339 itemsize = fieldsize;
340 send = chophere = s + itemsize;
352 item = s = SvPV(sv, len);
354 if (itemsize <= fieldsize) {
355 send = chophere = s + itemsize;
366 itemsize = fieldsize;
367 send = chophere = s + itemsize;
368 while (s < send || (s == send && isSPACE(*s))) {
378 if (strchr(chopset, *s))
383 itemsize = chophere - item;
388 arg = fieldsize - itemsize;
397 arg = fieldsize - itemsize;
411 int ch = *t++ = *s++;
415 if ( !((*t++ = *s++) & ~31) )
425 while (*s && isSPACE(*s))
432 item = s = SvPV(sv, len);
445 SvCUR_set(formtarget, t - SvPVX(formtarget));
446 sv_catpvn(formtarget, item, itemsize);
447 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
448 t = SvPVX(formtarget) + SvCUR(formtarget);
453 /* If the field is marked with ^ and the value is undefined,
456 if ((arg & 512) && !SvOK(sv)) {
464 /* Formats aren't yet marked for locales, so assume "yes". */
467 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
469 sprintf(t, "%*.0f", (int) fieldsize, value);
476 while (t-- > linemark && *t == ' ') ;
484 if (arg) { /* repeat until fields exhausted? */
486 SvCUR_set(formtarget, t - SvPVX(formtarget));
487 lines += FmLINES(formtarget);
490 if (strnEQ(linemark, linemark - arg, arg))
491 DIE("Runaway format");
493 FmLINES(formtarget) = lines;
495 RETURNOP(cLISTOP->op_first);
506 arg = fieldsize - itemsize;
513 if (strnEQ(s," ",3)) {
514 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
525 SvCUR_set(formtarget, t - SvPVX(formtarget));
526 FmLINES(formtarget) += lines;
538 if (stack_base + *markstack_ptr == sp) {
540 if (GIMME_V == G_SCALAR)
542 RETURNOP(op->op_next->op_next);
544 stack_sp = stack_base + *markstack_ptr + 1;
545 pp_pushmark(ARGS); /* push dst */
546 pp_pushmark(ARGS); /* push src */
547 ENTER; /* enter outer scope */
551 /* SAVE_DEFSV does *not* suffice here */
552 save_sptr(&THREADSV(0));
554 SAVESPTR(GvSV(defgv));
555 #endif /* USE_THREADS */
556 ENTER; /* enter inner scope */
559 src = stack_base[*markstack_ptr];
564 if (op->op_type == OP_MAPSTART)
565 pp_pushmark(ARGS); /* push top */
566 return ((LOGOP*)op->op_next)->op_other;
571 DIE("panic: mapstart"); /* uses grepstart */
577 I32 diff = (sp - stack_base) - *markstack_ptr;
585 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
586 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
587 count = (sp - stack_base) - markstack_ptr[-1] + 2;
592 markstack_ptr[-1] += shift;
593 *markstack_ptr += shift;
597 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
600 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
602 LEAVE; /* exit inner scope */
605 if (markstack_ptr[-1] > *markstack_ptr) {
609 (void)POPMARK; /* pop top */
610 LEAVE; /* exit outer scope */
611 (void)POPMARK; /* pop src */
612 items = --*markstack_ptr - markstack_ptr[-1];
613 (void)POPMARK; /* pop dst */
614 SP = stack_base + POPMARK; /* pop original mark */
615 if (gimme == G_SCALAR) {
619 else if (gimme == G_ARRAY)
626 ENTER; /* enter inner scope */
629 src = stack_base[markstack_ptr[-1]];
633 RETURNOP(cLOGOP->op_other);
640 djSP; dMARK; dORIGMARK;
642 SV **myorigmark = ORIGMARK;
648 OP* nextop = op->op_next;
650 if (gimme != G_ARRAY) {
655 if (op->op_flags & OPf_STACKED) {
657 if (op->op_flags & OPf_SPECIAL) {
658 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
659 kid = kUNOP->op_first; /* pass rv2gv */
660 kid = kUNOP->op_first; /* pass leave */
661 sortcop = kid->op_next;
662 stash = curcop->cop_stash;
665 cv = sv_2cv(*++MARK, &stash, &gv, 0);
666 if (!(cv && CvROOT(cv))) {
668 SV *tmpstr = sv_newmortal();
669 gv_efullname3(tmpstr, gv, Nullch);
670 if (cv && CvXSUB(cv))
671 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
672 DIE("Undefined sort subroutine \"%s\" called",
677 DIE("Xsub called in sort");
678 DIE("Undefined subroutine in sort");
680 DIE("Not a CODE reference in sort");
682 sortcop = CvSTART(cv);
683 SAVESPTR(CvROOT(cv)->op_ppaddr);
684 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
687 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
692 stash = curcop->cop_stash;
696 while (MARK < SP) { /* This may or may not shift down one here. */
698 if (*up = *++MARK) { /* Weed out nulls. */
700 if (!sortcop && !SvPOK(*up))
701 (void)sv_2pv(*up, &na);
705 max = --up - myorigmark;
711 bool oldcatch = CATCH_GET;
719 AvREAL_off(sortstack);
720 av_extend(sortstack, 32);
723 SWITCHSTACK(curstack, sortstack);
724 if (sortstash != stash) {
725 firstgv = gv_fetchpv("a", TRUE, SVt_PV);
726 secondgv = gv_fetchpv("b", TRUE, SVt_PV);
730 SAVESPTR(GvSV(firstgv));
731 SAVESPTR(GvSV(secondgv));
733 PUSHBLOCK(cx, CXt_NULL, stack_base);
734 if (!(op->op_flags & OPf_SPECIAL)) {
735 bool hasargs = FALSE;
736 cx->cx_type = CXt_SUB;
737 cx->blk_gimme = G_SCALAR;
740 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
742 sortcxix = cxstack_ix;
744 qsortsv(myorigmark+1, max, sortcv);
747 SWITCHSTACK(sortstack, oldstack);
754 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
755 qsortsv(ORIGMARK+1, max,
756 (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
759 stack_sp = ORIGMARK + max;
767 if (GIMME == G_ARRAY)
768 return cCONDOP->op_true;
769 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
776 if (GIMME == G_ARRAY) {
777 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
781 SV *targ = PAD_SV(op->op_targ);
783 if ((op->op_private & OPpFLIP_LINENUM)
784 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
786 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
787 if (op->op_flags & OPf_SPECIAL) {
795 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
808 if (GIMME == G_ARRAY) {
814 if (SvNIOKp(left) || !SvPOKp(left) ||
815 (looks_like_number(left) && *SvPVX(left) != '0') )
820 EXTEND_MORTAL(max - i + 1);
821 EXTEND(SP, max - i + 1);
824 sv = sv_2mortal(newSViv(i++));
829 SV *final = sv_mortalcopy(right);
831 char *tmps = SvPV(final, len);
833 sv = sv_mortalcopy(left);
834 while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
835 strNE(SvPVX(sv),tmps) ) {
837 sv = sv_2mortal(newSVsv(sv));
840 if (strEQ(SvPVX(sv),tmps))
846 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
848 if ((op->op_private & OPpFLIP_LINENUM)
849 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
851 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
852 sv_catpv(targ, "E0");
863 dopoptolabel(char *label)
867 register PERL_CONTEXT *cx;
869 for (i = cxstack_ix; i >= 0; i--) {
871 switch (cx->cx_type) {
874 warn("Exiting substitution via %s", op_name[op->op_type]);
878 warn("Exiting subroutine via %s", op_name[op->op_type]);
882 warn("Exiting eval via %s", op_name[op->op_type]);
886 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
889 if (!cx->blk_loop.label ||
890 strNE(label, cx->blk_loop.label) ) {
891 DEBUG_l(deb("(Skipping label #%ld %s)\n",
892 (long)i, cx->blk_loop.label));
895 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
905 I32 gimme = block_gimme();
906 return (gimme == G_VOID) ? G_SCALAR : gimme;
915 cxix = dopoptosub(cxstack_ix);
919 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;
1048 STRLEN klen = strlen(message);
1050 svp = hv_fetch(ERRHV, message, klen, TRUE);
1053 static char prefix[] = "\t(in cleanup) ";
1055 sv_upgrade(*svp, SVt_IV);
1056 (void)SvIOK_only(*svp);
1059 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1060 sv_catpvn(err, prefix, sizeof(prefix)-1);
1061 sv_catpvn(err, message, klen);
1067 sv_setpv(ERRSV, message);
1069 cxix = dopoptoeval(cxstack_ix);
1073 if (cxix < cxstack_ix)
1077 if (cx->cx_type != CXt_EVAL) {
1078 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1083 if (gimme == G_SCALAR)
1084 *++newsp = &sv_undef;
1089 if (optype == OP_REQUIRE) {
1090 char* msg = SvPVx(ERRSV, na);
1091 DIE("%s", *msg ? msg : "Compilation failed in require");
1093 return pop_return();
1096 PerlIO_printf(PerlIO_stderr(), "%s",message);
1097 PerlIO_flush(PerlIO_stderr());
1106 if (SvTRUE(left) != SvTRUE(right))
1118 RETURNOP(cLOGOP->op_other);
1127 RETURNOP(cLOGOP->op_other);
1133 register I32 cxix = dopoptosub(cxstack_ix);
1134 register PERL_CONTEXT *cx;
1146 if (GIMME != G_ARRAY)
1150 if (DBsub && cxix >= 0 &&
1151 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1155 cxix = dopoptosub(cxix - 1);
1157 cx = &cxstack[cxix];
1158 if (cxstack[cxix].cx_type == CXt_SUB) {
1159 dbcxix = dopoptosub(cxix - 1);
1160 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1161 field below is defined for any cx. */
1162 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1163 cx = &cxstack[dbcxix];
1166 if (GIMME != G_ARRAY) {
1167 hv = cx->blk_oldcop->cop_stash;
1172 sv_setpv(TARG, HvNAME(hv));
1178 hv = cx->blk_oldcop->cop_stash;
1182 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
1183 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1184 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1187 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1189 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1190 PUSHs(sv_2mortal(sv));
1191 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1194 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1195 PUSHs(sv_2mortal(newSViv(0)));
1197 gimme = (I32)cx->blk_gimme;
1198 if (gimme == G_VOID)
1201 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1202 if (cx->cx_type == CXt_EVAL) {
1203 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1204 PUSHs(cx->blk_eval.cur_text);
1207 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1208 /* Require, put the name. */
1209 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1213 else if (cx->cx_type == CXt_SUB &&
1214 cx->blk_sub.hasargs &&
1215 curcop->cop_stash == debstash)
1217 AV *ary = cx->blk_sub.argarray;
1218 int off = AvARRAY(ary) - AvALLOC(ary);
1222 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1225 AvREAL_off(dbargs); /* XXX Should be REIFY */
1228 if (AvMAX(dbargs) < AvFILLp(ary) + off)
1229 av_extend(dbargs, AvFILLp(ary) + off);
1230 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*);
1231 AvFILLp(dbargs) = AvFILLp(ary) + off;
1237 sortcv(SV *a, SV *b)
1240 I32 oldsaveix = savestack_ix;
1241 I32 oldscopeix = scopestack_ix;
1245 stack_sp = stack_base;
1248 if (stack_sp != stack_base + 1)
1249 croak("Sort subroutine didn't return single value");
1250 if (!SvNIOKp(*stack_sp))
1251 croak("Sort subroutine didn't return a numeric value");
1252 result = SvIV(*stack_sp);
1253 while (scopestack_ix > oldscopeix) {
1256 leave_scope(oldsaveix);
1269 sv_reset(tmps, curcop->cop_stash);
1282 TAINT_NOT; /* Each statement is presumed innocent */
1283 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1286 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1290 register PERL_CONTEXT *cx;
1291 I32 gimme = G_ARRAY;
1298 DIE("No DB::DB routine defined");
1300 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1312 push_return(op->op_next);
1313 PUSHBLOCK(cx, CXt_SUB, sp);
1316 (void)SvREFCNT_inc(cv);
1318 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1319 RETURNOP(CvSTART(cv));
1333 register PERL_CONTEXT *cx;
1334 I32 gimme = GIMME_V;
1341 if (op->op_flags & OPf_SPECIAL)
1342 svp = save_threadsv(op->op_targ); /* per-thread variable */
1344 #endif /* USE_THREADS */
1346 svp = &curpad[op->op_targ]; /* "my" variable */
1351 (void)save_scalar(gv);
1352 svp = &GvSV(gv); /* symbol table variable */
1357 PUSHBLOCK(cx, CXt_LOOP, SP);
1358 PUSHLOOP(cx, svp, MARK);
1359 if (op->op_flags & OPf_STACKED)
1360 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1362 cx->blk_loop.iterary = curstack;
1363 AvFILLp(curstack) = sp - stack_base;
1364 cx->blk_loop.iterix = MARK - stack_base;
1373 register PERL_CONTEXT *cx;
1374 I32 gimme = GIMME_V;
1380 PUSHBLOCK(cx, CXt_LOOP, SP);
1381 PUSHLOOP(cx, 0, SP);
1389 register PERL_CONTEXT *cx;
1390 struct block_loop cxloop;
1398 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1401 if (gimme == G_VOID)
1403 else if (gimme == G_SCALAR) {
1405 *++newsp = sv_mortalcopy(*SP);
1407 *++newsp = &sv_undef;
1411 *++newsp = sv_mortalcopy(*++mark);
1412 TAINT_NOT; /* Each item is independent */
1418 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1419 curpm = newpm; /* ... and pop $1 et al */
1431 register PERL_CONTEXT *cx;
1432 struct block_sub cxsub;
1433 bool popsub2 = FALSE;
1439 if (curstack == sortstack) {
1440 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1441 if (cxstack_ix > sortcxix)
1443 AvARRAY(curstack)[1] = *SP;
1444 stack_sp = stack_base + 1;
1449 cxix = dopoptosub(cxstack_ix);
1451 DIE("Can't return outside a subroutine");
1452 if (cxix < cxstack_ix)
1456 switch (cx->cx_type) {
1458 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1463 if (optype == OP_REQUIRE &&
1464 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1466 /* Unassume the success we assumed earlier. */
1467 char *name = cx->blk_eval.old_name;
1468 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1469 DIE("%s did not return a true value", name);
1473 DIE("panic: return");
1477 if (gimme == G_SCALAR) {
1479 *++newsp = (popsub2 && SvTEMP(*SP))
1480 ? *SP : sv_mortalcopy(*SP);
1482 *++newsp = &sv_undef;
1484 else if (gimme == G_ARRAY) {
1485 while (++MARK <= SP) {
1486 *++newsp = (popsub2 && SvTEMP(*MARK))
1487 ? *MARK : sv_mortalcopy(*MARK);
1488 TAINT_NOT; /* Each item is independent */
1493 /* Stack values are safe: */
1495 POPSUB2(); /* release CV and @_ ... */
1497 curpm = newpm; /* ... and pop $1 et al */
1500 return pop_return();
1507 register PERL_CONTEXT *cx;
1508 struct block_loop cxloop;
1509 struct block_sub cxsub;
1516 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1518 if (op->op_flags & OPf_SPECIAL) {
1519 cxix = dopoptoloop(cxstack_ix);
1521 DIE("Can't \"last\" outside a block");
1524 cxix = dopoptolabel(cPVOP->op_pv);
1526 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1528 if (cxix < cxstack_ix)
1532 switch (cx->cx_type) {
1534 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1536 nextop = cxloop.last_op->op_next;
1539 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1541 nextop = pop_return();
1545 nextop = pop_return();
1552 if (gimme == G_SCALAR) {
1554 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1555 ? *SP : sv_mortalcopy(*SP);
1557 *++newsp = &sv_undef;
1559 else if (gimme == G_ARRAY) {
1560 while (++MARK <= SP) {
1561 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1562 ? *MARK : sv_mortalcopy(*MARK);
1563 TAINT_NOT; /* Each item is independent */
1569 /* Stack values are safe: */
1572 POPLOOP2(); /* release loop vars ... */
1576 POPSUB2(); /* release CV and @_ ... */
1579 curpm = newpm; /* ... and pop $1 et al */
1588 register PERL_CONTEXT *cx;
1591 if (op->op_flags & OPf_SPECIAL) {
1592 cxix = dopoptoloop(cxstack_ix);
1594 DIE("Can't \"next\" outside a block");
1597 cxix = dopoptolabel(cPVOP->op_pv);
1599 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1601 if (cxix < cxstack_ix)
1605 oldsave = scopestack[scopestack_ix - 1];
1606 LEAVE_SCOPE(oldsave);
1607 return cx->blk_loop.next_op;
1613 register PERL_CONTEXT *cx;
1616 if (op->op_flags & OPf_SPECIAL) {
1617 cxix = dopoptoloop(cxstack_ix);
1619 DIE("Can't \"redo\" outside a block");
1622 cxix = dopoptolabel(cPVOP->op_pv);
1624 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1626 if (cxix < cxstack_ix)
1630 oldsave = scopestack[scopestack_ix - 1];
1631 LEAVE_SCOPE(oldsave);
1632 return cx->blk_loop.redo_op;
1635 static OP* lastgotoprobe;
1638 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1642 static char too_deep[] = "Target of goto is too deeply nested";
1646 if (o->op_type == OP_LEAVE ||
1647 o->op_type == OP_SCOPE ||
1648 o->op_type == OP_LEAVELOOP ||
1649 o->op_type == OP_LEAVETRY)
1651 *ops++ = cUNOPo->op_first;
1656 if (o->op_flags & OPf_KIDS) {
1657 /* First try all the kids at this level, since that's likeliest. */
1658 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1659 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1660 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1663 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1664 if (kid == lastgotoprobe)
1666 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1668 (ops[-1]->op_type != OP_NEXTSTATE &&
1669 ops[-1]->op_type != OP_DBSTATE)))
1671 if (o = dofindlabel(kid, label, ops, oplimit))
1681 return pp_goto(ARGS);
1690 register PERL_CONTEXT *cx;
1691 #define GOTO_DEPTH 64
1692 OP *enterops[GOTO_DEPTH];
1694 int do_dump = (op->op_type == OP_DUMP);
1697 if (op->op_flags & OPf_STACKED) {
1700 /* This egregious kludge implements goto &subroutine */
1701 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1703 register PERL_CONTEXT *cx;
1704 CV* cv = (CV*)SvRV(sv);
1709 if (!CvROOT(cv) && !CvXSUB(cv)) {
1711 SV *tmpstr = sv_newmortal();
1712 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1713 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1715 DIE("Goto undefined subroutine");
1718 /* First do some returnish stuff. */
1719 cxix = dopoptosub(cxstack_ix);
1721 DIE("Can't goto subroutine outside a subroutine");
1722 if (cxix < cxstack_ix)
1725 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1726 DIE("Can't goto subroutine from an eval-string");
1728 if (cx->cx_type == CXt_SUB &&
1729 cx->blk_sub.hasargs) { /* put @_ back onto stack */
1730 AV* av = cx->blk_sub.argarray;
1732 items = AvFILLp(av) + 1;
1734 EXTEND(stack_sp, items); /* @_ could have been extended. */
1735 Copy(AvARRAY(av), stack_sp, items, SV*);
1738 SvREFCNT_dec(GvAV(defgv));
1739 GvAV(defgv) = cx->blk_sub.savearray;
1740 #endif /* USE_THREADS */
1744 if (cx->cx_type == CXt_SUB &&
1745 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1746 SvREFCNT_dec(cx->blk_sub.cv);
1747 oldsave = scopestack[scopestack_ix - 1];
1748 LEAVE_SCOPE(oldsave);
1750 /* Now do some callish stuff. */
1753 if (CvOLDSTYLE(cv)) {
1754 I32 (*fp3)_((int,int,int));
1759 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1760 items = (*fp3)(CvXSUBANY(cv).any_i32,
1761 mark - stack_base + 1,
1763 sp = stack_base + items;
1766 stack_sp--; /* There is no cv arg. */
1767 (void)(*CvXSUB(cv))(cv);
1770 return pop_return();
1773 AV* padlist = CvPADLIST(cv);
1774 SV** svp = AvARRAY(padlist);
1775 if (cx->cx_type == CXt_EVAL) {
1776 in_eval = cx->blk_eval.old_in_eval;
1777 eval_root = cx->blk_eval.old_eval_root;
1778 cx->cx_type = CXt_SUB;
1779 cx->blk_sub.hasargs = 0;
1781 cx->blk_sub.cv = cv;
1782 cx->blk_sub.olddepth = CvDEPTH(cv);
1784 if (CvDEPTH(cv) < 2)
1785 (void)SvREFCNT_inc(cv);
1786 else { /* save temporaries on recursion? */
1787 if (CvDEPTH(cv) == 100 && dowarn)
1788 sub_crush_depth(cv);
1789 if (CvDEPTH(cv) > AvFILLp(padlist)) {
1790 AV *newpad = newAV();
1791 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1792 I32 ix = AvFILLp((AV*)svp[1]);
1793 svp = AvARRAY(svp[0]);
1794 for ( ;ix > 0; ix--) {
1795 if (svp[ix] != &sv_undef) {
1796 char *name = SvPVX(svp[ix]);
1797 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1800 /* outer lexical or anon code */
1801 av_store(newpad, ix,
1802 SvREFCNT_inc(oldpad[ix]) );
1804 else { /* our own lexical */
1806 av_store(newpad, ix, sv = (SV*)newAV());
1807 else if (*name == '%')
1808 av_store(newpad, ix, sv = (SV*)newHV());
1810 av_store(newpad, ix, sv = NEWSV(0,0));
1815 av_store(newpad, ix, sv = NEWSV(0,0));
1819 if (cx->blk_sub.hasargs) {
1822 av_store(newpad, 0, (SV*)av);
1823 AvFLAGS(av) = AVf_REIFY;
1825 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1826 AvFILLp(padlist) = CvDEPTH(cv);
1827 svp = AvARRAY(padlist);
1831 if (!cx->blk_sub.hasargs) {
1832 AV* av = (AV*)curpad[0];
1834 items = AvFILLp(av) + 1;
1836 /* Mark is at the end of the stack. */
1838 Copy(AvARRAY(av), sp + 1, items, SV*);
1843 #endif /* USE_THREADS */
1845 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1847 if (cx->blk_sub.hasargs)
1848 #endif /* USE_THREADS */
1850 AV* av = (AV*)curpad[0];
1854 cx->blk_sub.savearray = GvAV(defgv);
1855 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1856 #endif /* USE_THREADS */
1857 cx->blk_sub.argarray = av;
1860 if (items >= AvMAX(av) + 1) {
1862 if (AvARRAY(av) != ary) {
1863 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1864 SvPVX(av) = (char*)ary;
1866 if (items >= AvMAX(av) + 1) {
1867 AvMAX(av) = items - 1;
1868 Renew(ary,items+1,SV*);
1870 SvPVX(av) = (char*)ary;
1873 Copy(mark,AvARRAY(av),items,SV*);
1874 AvFILLp(av) = items - 1;
1882 if (PERLDB_SUB && curstash != debstash) {
1884 * We do not care about using sv to call CV;
1885 * it's for informational purposes only.
1887 SV *sv = GvSV(DBsub);
1889 gv_efullname3(sv, CvGV(cv), Nullch);
1891 RETURNOP(CvSTART(cv));
1895 label = SvPV(sv,na);
1897 else if (op->op_flags & OPf_SPECIAL) {
1899 DIE("goto must have label");
1902 label = cPVOP->op_pv;
1904 if (label && *label) {
1911 for (ix = cxstack_ix; ix >= 0; ix--) {
1913 switch (cx->cx_type) {
1915 gotoprobe = eval_root; /* XXX not good for nested eval */
1918 gotoprobe = cx->blk_oldcop->op_sibling;
1924 gotoprobe = cx->blk_oldcop->op_sibling;
1926 gotoprobe = main_root;
1929 if (CvDEPTH(cx->blk_sub.cv)) {
1930 gotoprobe = CvROOT(cx->blk_sub.cv);
1935 DIE("Can't \"goto\" outside a block");
1939 gotoprobe = main_root;
1942 retop = dofindlabel(gotoprobe, label,
1943 enterops, enterops + GOTO_DEPTH);
1946 lastgotoprobe = gotoprobe;
1949 DIE("Can't find label %s", label);
1951 /* pop unwanted frames */
1953 if (ix < cxstack_ix) {
1960 oldsave = scopestack[scopestack_ix];
1961 LEAVE_SCOPE(oldsave);
1964 /* push wanted frames */
1966 if (*enterops && enterops[1]) {
1968 for (ix = 1; enterops[ix]; ix++) {
1970 /* Eventually we may want to stack the needed arguments
1971 * for each op. For now, we punt on the hard ones. */
1972 if (op->op_type == OP_ENTERITER)
1973 DIE("Can't \"goto\" into the middle of a foreach loop",
1975 (*op->op_ppaddr)(ARGS);
1983 if (!retop) retop = main_start;
1990 restartop = 0; /* hmm, must be GNU unexec().. */
1994 if (curstack == signalstack) {
2012 if (anum == 1 && VMSISH_EXIT)
2025 double value = SvNVx(GvSV(cCOP->cop_gv));
2026 register I32 match = I_32(value);
2029 if (((double)match) > value)
2030 --match; /* was fractional--truncate other way */
2032 match -= cCOP->uop.scop.scop_offset;
2035 else if (match > cCOP->uop.scop.scop_max)
2036 match = cCOP->uop.scop.scop_max;
2037 op = cCOP->uop.scop.scop_next[match];
2047 op = op->op_next; /* can't assume anything */
2049 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
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];
2064 save_lines(AV *array, SV *sv)
2066 register char *s = SvPVX(sv);
2067 register char *send = SvPVX(sv) + SvCUR(sv);
2069 register I32 line = 1;
2071 while (s && s < send) {
2072 SV *tmpstr = NEWSV(85,0);
2074 sv_upgrade(tmpstr, SVt_PVMG);
2075 t = strchr(s, '\n');
2081 sv_setpvn(tmpstr, s, t - s);
2082 av_store(array, line++, tmpstr);
2097 assert(CATCH_GET == TRUE);
2098 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2102 default: /* topmost level handles it */
2109 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2125 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2126 /* sv Text to convert to OP tree. */
2127 /* startop op_free() this to undo. */
2128 /* code Short string id of the caller. */
2130 dSP; /* Make POPBLOCK work. */
2133 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2137 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2143 /* switch to eval mode */
2145 SAVESPTR(compiling.cop_filegv);
2146 SAVEI16(compiling.cop_line);
2147 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2148 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2149 compiling.cop_line = 1;
2150 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2151 deleting the eval's FILEGV from the stash before gv_check() runs
2152 (i.e. before run-time proper). To work around the coredump that
2153 ensues, we always turn GvMULTI_on for any globals that were
2154 introduced within evals. See force_ident(). GSAR 96-10-12 */
2155 safestr = savepv(tmpbuf);
2156 SAVEDELETE(defstash, safestr, strlen(safestr));
2158 #ifdef OP_IN_REGISTER
2166 op->op_type = 0; /* Avoid uninit warning. */
2167 op->op_flags = 0; /* Avoid uninit warning. */
2168 PUSHBLOCK(cx, CXt_EVAL, SP);
2169 PUSHEVAL(cx, 0, compiling.cop_filegv);
2170 rop = doeval(G_SCALAR, startop);
2174 (*startop)->op_type = OP_NULL;
2175 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2177 *avp = (AV*)SvREFCNT_inc(comppad);
2179 #ifdef OP_IN_REGISTER
2185 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2187 doeval(int gimme, OP** startop)
2200 /* set up a scratch pad */
2205 SAVESPTR(comppad_name);
2206 SAVEI32(comppad_name_fill);
2207 SAVEI32(min_intro_pending);
2208 SAVEI32(max_intro_pending);
2211 for (i = cxstack_ix - 1; i >= 0; i--) {
2212 PERL_CONTEXT *cx = &cxstack[i];
2213 if (cx->cx_type == CXt_EVAL)
2215 else if (cx->cx_type == CXt_SUB) {
2216 caller = cx->blk_sub.cv;
2222 compcv = (CV*)NEWSV(1104,0);
2223 sv_upgrade((SV *)compcv, SVt_PVCV);
2224 CvUNIQUE_on(compcv);
2226 CvOWNER(compcv) = 0;
2227 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2228 MUTEX_INIT(CvMUTEXP(compcv));
2229 #endif /* USE_THREADS */
2232 av_push(comppad, Nullsv);
2233 curpad = AvARRAY(comppad);
2234 comppad_name = newAV();
2235 comppad_name_fill = 0;
2236 min_intro_pending = 0;
2239 av_store(comppad_name, 0, newSVpv("@_", 2));
2240 curpad[0] = (SV*)newAV();
2241 SvPADMY_on(curpad[0]); /* XXX Needed? */
2242 #endif /* USE_THREADS */
2244 comppadlist = newAV();
2245 AvREAL_off(comppadlist);
2246 av_store(comppadlist, 0, (SV*)comppad_name);
2247 av_store(comppadlist, 1, (SV*)comppad);
2248 CvPADLIST(compcv) = comppadlist;
2250 if (!saveop || saveop->op_type != OP_REQUIRE)
2251 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2255 /* make sure we compile in the right package */
2257 newstash = curcop->cop_stash;
2258 if (curstash != newstash) {
2260 curstash = newstash;
2264 SAVEFREESV(beginav);
2266 /* try to compile it */
2270 curcop = &compiling;
2271 curcop->cop_arybase = 0;
2273 rs = newSVpv("\n", 1);
2274 if (saveop && saveop->op_flags & OPf_SPECIAL)
2278 if (yyparse() || error_count || !eval_root) {
2282 I32 optype = 0; /* Might be reset by POPEVAL. */
2289 SP = stack_base + POPMARK; /* pop original mark */
2297 if (optype == OP_REQUIRE) {
2298 char* msg = SvPVx(ERRSV, na);
2299 DIE("%s", *msg ? msg : "Compilation failed in require");
2300 } else if (startop) {
2301 char* msg = SvPVx(ERRSV, na);
2305 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2308 rs = SvREFCNT_inc(nrs);
2310 MUTEX_LOCK(&eval_mutex);
2312 COND_SIGNAL(&eval_cond);
2313 MUTEX_UNLOCK(&eval_mutex);
2314 #endif /* USE_THREADS */
2318 rs = SvREFCNT_inc(nrs);
2319 compiling.cop_line = 0;
2321 *startop = eval_root;
2322 SvREFCNT_dec(CvOUTSIDE(compcv));
2323 CvOUTSIDE(compcv) = Nullcv;
2325 SAVEFREEOP(eval_root);
2327 scalarvoid(eval_root);
2328 else if (gimme & G_ARRAY)
2333 DEBUG_x(dump_eval());
2335 /* Register with debugger: */
2336 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2337 CV *cv = perl_get_cv("DB::postponed", FALSE);
2341 XPUSHs((SV*)compiling.cop_filegv);
2343 perl_call_sv((SV*)cv, G_DISCARD);
2347 /* compiled okay, so do it */
2349 CvDEPTH(compcv) = 1;
2350 SP = stack_base + POPMARK; /* pop original mark */
2351 op = saveop; /* The caller may need it. */
2353 MUTEX_LOCK(&eval_mutex);
2355 COND_SIGNAL(&eval_cond);
2356 MUTEX_UNLOCK(&eval_mutex);
2357 #endif /* USE_THREADS */
2359 RETURNOP(eval_start);
2365 register PERL_CONTEXT *cx;
2370 SV *namesv = Nullsv;
2372 I32 gimme = G_SCALAR;
2373 PerlIO *tryrsfp = 0;
2376 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2377 SET_NUMERIC_STANDARD();
2378 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2379 DIE("Perl %s required--this is only version %s, stopped",
2380 SvPV(sv,na),patchlevel);
2383 name = SvPV(sv, len);
2384 if (!(name && len > 0 && *name))
2385 DIE("Null filename used");
2386 TAINT_PROPER("require");
2387 if (op->op_type == OP_REQUIRE &&
2388 (svp = hv_fetch(GvHVn(incgv), name, len, 0)) &&
2392 /* prepare to compile file */
2397 (name[1] == '.' && name[2] == '/')))
2399 || (name[0] && name[1] == ':')
2402 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2405 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2406 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2411 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2414 AV *ar = GvAVn(incgv);
2418 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2421 namesv = NEWSV(806, 0);
2422 for (i = 0; i <= AvFILL(ar); i++) {
2423 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2426 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2428 sv_setpv(namesv, unixdir);
2429 sv_catpv(namesv, unixname);
2431 sv_setpvf(namesv, "%s/%s", dir, name);
2433 tryname = SvPVX(namesv);
2434 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2436 if (tryname[0] == '.' && tryname[1] == '/')
2443 SAVESPTR(compiling.cop_filegv);
2444 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2445 SvREFCNT_dec(namesv);
2447 if (op->op_type == OP_REQUIRE) {
2448 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2449 SV *dirmsgsv = NEWSV(0, 0);
2450 AV *ar = GvAVn(incgv);
2452 if (instr(SvPVX(msg), ".h "))
2453 sv_catpv(msg, " (change .h to .ph maybe?)");
2454 if (instr(SvPVX(msg), ".ph "))
2455 sv_catpv(msg, " (did you run h2ph?)");
2456 sv_catpv(msg, " (@INC contains:");
2457 for (i = 0; i <= AvFILL(ar); i++) {
2458 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2459 sv_setpvf(dirmsgsv, " %s", dir);
2460 sv_catsv(msg, dirmsgsv);
2462 sv_catpvn(msg, ")", 1);
2463 SvREFCNT_dec(dirmsgsv);
2470 /* Assume success here to prevent recursive requirement. */
2471 (void)hv_store(GvHVn(incgv), name, strlen(name),
2472 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2476 lex_start(sv_2mortal(newSVpv("",0)));
2478 save_aptr(&rsfp_filters);
2479 rsfp_filters = NULL;
2483 name = savepv(name);
2488 /* switch to eval mode */
2490 push_return(op->op_next);
2491 PUSHBLOCK(cx, CXt_EVAL, SP);
2492 PUSHEVAL(cx, name, compiling.cop_filegv);
2494 compiling.cop_line = 0;
2498 MUTEX_LOCK(&eval_mutex);
2499 if (eval_owner && eval_owner != thr)
2501 COND_WAIT(&eval_cond, &eval_mutex);
2503 MUTEX_UNLOCK(&eval_mutex);
2504 #endif /* USE_THREADS */
2505 return DOCATCH(doeval(G_SCALAR, NULL));
2510 return pp_require(ARGS);
2516 register PERL_CONTEXT *cx;
2518 I32 gimme = GIMME_V, was = sub_generation;
2519 char tmpbuf[TYPE_DIGITS(long) + 12];
2524 if (!SvPV(sv,len) || !len)
2526 TAINT_PROPER("eval");
2532 /* switch to eval mode */
2534 SAVESPTR(compiling.cop_filegv);
2535 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2536 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2537 compiling.cop_line = 1;
2538 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2539 deleting the eval's FILEGV from the stash before gv_check() runs
2540 (i.e. before run-time proper). To work around the coredump that
2541 ensues, we always turn GvMULTI_on for any globals that were
2542 introduced within evals. See force_ident(). GSAR 96-10-12 */
2543 safestr = savepv(tmpbuf);
2544 SAVEDELETE(defstash, safestr, strlen(safestr));
2546 hints = op->op_targ;
2548 push_return(op->op_next);
2549 PUSHBLOCK(cx, CXt_EVAL, SP);
2550 PUSHEVAL(cx, 0, compiling.cop_filegv);
2552 /* prepare to compile string */
2554 if (PERLDB_LINE && curstash != debstash)
2555 save_lines(GvAV(compiling.cop_filegv), linestr);
2558 MUTEX_LOCK(&eval_mutex);
2559 if (eval_owner && eval_owner != thr)
2561 COND_WAIT(&eval_cond, &eval_mutex);
2563 MUTEX_UNLOCK(&eval_mutex);
2564 #endif /* USE_THREADS */
2565 ret = doeval(gimme, NULL);
2566 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2567 && ret != op->op_next) { /* Successive compilation. */
2568 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2570 return DOCATCH(ret);
2580 register PERL_CONTEXT *cx;
2582 U8 save_flags = op -> op_flags;
2587 retop = pop_return();
2590 if (gimme == G_VOID)
2592 else if (gimme == G_SCALAR) {
2595 if (SvFLAGS(TOPs) & SVs_TEMP)
2598 *MARK = sv_mortalcopy(TOPs);
2606 /* in case LEAVE wipes old return values */
2607 for (mark = newsp + 1; mark <= SP; mark++) {
2608 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2609 *mark = sv_mortalcopy(*mark);
2610 TAINT_NOT; /* Each item is independent */
2614 curpm = newpm; /* Don't pop $1 et al till now */
2617 * Closures mentioned at top level of eval cannot be referenced
2618 * again, and their presence indirectly causes a memory leak.
2619 * (Note that the fact that compcv and friends are still set here
2620 * is, AFAIK, an accident.) --Chip
2622 if (AvFILLp(comppad_name) >= 0) {
2623 SV **svp = AvARRAY(comppad_name);
2625 for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
2627 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2629 svp[ix] = &sv_undef;
2633 SvREFCNT_dec(CvOUTSIDE(sv));
2634 CvOUTSIDE(sv) = Nullcv;
2647 assert(CvDEPTH(compcv) == 1);
2649 CvDEPTH(compcv) = 0;
2652 if (optype == OP_REQUIRE &&
2653 !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp))
2655 /* Unassume the success we assumed earlier. */
2656 char *name = cx->blk_eval.old_name;
2657 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2658 retop = die("%s did not return a true value", name);
2659 /* die_where() did LEAVE, or we won't be here */
2663 if (!(save_flags & OPf_SPECIAL))
2673 register PERL_CONTEXT *cx;
2674 I32 gimme = GIMME_V;
2679 push_return(cLOGOP->op_other->op_next);
2680 PUSHBLOCK(cx, CXt_EVAL, SP);
2682 eval_root = op; /* Only needed so that goto works right. */
2687 return DOCATCH(op->op_next);
2697 register PERL_CONTEXT *cx;
2705 if (gimme == G_VOID)
2707 else if (gimme == G_SCALAR) {
2710 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2713 *MARK = sv_mortalcopy(TOPs);
2722 /* in case LEAVE wipes old return values */
2723 for (mark = newsp + 1; mark <= SP; mark++) {
2724 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2725 *mark = sv_mortalcopy(*mark);
2726 TAINT_NOT; /* Each item is independent */
2730 curpm = newpm; /* Don't pop $1 et al till now */
2741 register char *s = SvPV_force(sv, len);
2742 register char *send = s + len;
2743 register char *base;
2744 register I32 skipspaces = 0;
2747 bool postspace = FALSE;
2755 croak("Null picture in formline");
2757 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2762 *fpc++ = FF_LINEMARK;
2763 noblank = repeat = FALSE;
2781 case ' ': case '\t':
2792 *fpc++ = FF_LITERAL;
2800 *fpc++ = skipspaces;
2804 *fpc++ = FF_NEWLINE;
2808 arg = fpc - linepc + 1;
2815 *fpc++ = FF_LINEMARK;
2816 noblank = repeat = FALSE;
2825 ischop = s[-1] == '^';
2831 arg = (s - base) - 1;
2833 *fpc++ = FF_LITERAL;
2842 *fpc++ = FF_LINEGLOB;
2844 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2845 arg = ischop ? 512 : 0;
2855 arg |= 256 + (s - f);
2857 *fpc++ = s - base; /* fieldsize for FETCH */
2858 *fpc++ = FF_DECIMAL;
2863 bool ismore = FALSE;
2866 while (*++s == '>') ;
2867 prespace = FF_SPACE;
2869 else if (*s == '|') {
2870 while (*++s == '|') ;
2871 prespace = FF_HALFSPACE;
2876 while (*++s == '<') ;
2879 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2883 *fpc++ = s - base; /* fieldsize for FETCH */
2885 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2903 { /* need to jump to the next word */
2905 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2906 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2907 s = SvPVX(sv) + SvCUR(sv) + z;
2909 Copy(fops, s, arg, U16);
2911 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2916 * The rest of this file was derived from source code contributed
2919 * NOTE: this code was derived from Tom Horsley's qsort replacement
2920 * and should not be confused with the original code.
2923 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2925 Permission granted to distribute under the same terms as perl which are
2928 This program is free software; you can redistribute it and/or modify
2929 it under the terms of either:
2931 a) the GNU General Public License as published by the Free
2932 Software Foundation; either version 1, or (at your option) any
2935 b) the "Artistic License" which comes with this Kit.
2937 Details on the perl license can be found in the perl source code which
2938 may be located via the www.perl.com web page.
2940 This is the most wonderfulest possible qsort I can come up with (and
2941 still be mostly portable) My (limited) tests indicate it consistently
2942 does about 20% fewer calls to compare than does the qsort in the Visual
2943 C++ library, other vendors may vary.
2945 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2946 others I invented myself (or more likely re-invented since they seemed
2947 pretty obvious once I watched the algorithm operate for a while).
2949 Most of this code was written while watching the Marlins sweep the Giants
2950 in the 1997 National League Playoffs - no Braves fans allowed to use this
2951 code (just kidding :-).
2953 I realize that if I wanted to be true to the perl tradition, the only
2954 comment in this file would be something like:
2956 ...they shuffled back towards the rear of the line. 'No, not at the
2957 rear!' the slave-driver shouted. 'Three files up. And stay there...
2959 However, I really needed to violate that tradition just so I could keep
2960 track of what happens myself, not to mention some poor fool trying to
2961 understand this years from now :-).
2964 /* ********************************************************** Configuration */
2966 #ifndef QSORT_ORDER_GUESS
2967 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
2970 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
2971 future processing - a good max upper bound is log base 2 of memory size
2972 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
2973 safely be smaller than that since the program is taking up some space and
2974 most operating systems only let you grab some subset of contiguous
2975 memory (not to mention that you are normally sorting data larger than
2976 1 byte element size :-).
2978 #ifndef QSORT_MAX_STACK
2979 #define QSORT_MAX_STACK 32
2982 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
2983 Anything bigger and we use qsort. If you make this too small, the qsort
2984 will probably break (or become less efficient), because it doesn't expect
2985 the middle element of a partition to be the same as the right or left -
2986 you have been warned).
2988 #ifndef QSORT_BREAK_EVEN
2989 #define QSORT_BREAK_EVEN 6
2992 /* ************************************************************* Data Types */
2994 /* hold left and right index values of a partition waiting to be sorted (the
2995 partition includes both left and right - right is NOT one past the end or
2996 anything like that).
2998 struct partition_stack_entry {
3001 #ifdef QSORT_ORDER_GUESS
3002 int qsort_break_even;
3006 /* ******************************************************* Shorthand Macros */
3008 /* Note that these macros will be used from inside the qsort function where
3009 we happen to know that the variable 'elt_size' contains the size of an
3010 array element and the variable 'temp' points to enough space to hold a
3011 temp element and the variable 'array' points to the array being sorted
3012 and 'compare' is the pointer to the compare routine.
3014 Also note that there are very many highly architecture specific ways
3015 these might be sped up, but this is simply the most generally portable
3016 code I could think of.
3019 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3021 #define qsort_cmp(elt1, elt2) \
3022 ((*compare)(array[elt1], array[elt2]))
3024 #ifdef QSORT_ORDER_GUESS
3025 #define QSORT_NOTICE_SWAP swapped++;
3027 #define QSORT_NOTICE_SWAP
3030 /* swaps contents of array elements elt1, elt2.
3032 #define qsort_swap(elt1, elt2) \
3035 temp = array[elt1]; \
3036 array[elt1] = array[elt2]; \
3037 array[elt2] = temp; \
3040 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3041 elt3 and elt3 gets elt1.
3043 #define qsort_rotate(elt1, elt2, elt3) \
3046 temp = array[elt1]; \
3047 array[elt1] = array[elt2]; \
3048 array[elt2] = array[elt3]; \
3049 array[elt3] = temp; \
3052 /* ************************************************************ Debug stuff */
3059 return; /* good place to set a breakpoint */
3062 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3065 doqsort_all_asserts(
3069 int (*compare)(const void * elt1, const void * elt2),
3070 int pc_left, int pc_right, int u_left, int u_right)
3074 qsort_assert(pc_left <= pc_right);
3075 qsort_assert(u_right < pc_left);
3076 qsort_assert(pc_right < u_left);
3077 for (i = u_right + 1; i < pc_left; ++i) {
3078 qsort_assert(qsort_cmp(i, pc_left) < 0);
3080 for (i = pc_left; i < pc_right; ++i) {
3081 qsort_assert(qsort_cmp(i, pc_right) == 0);
3083 for (i = pc_right + 1; i < u_left; ++i) {
3084 qsort_assert(qsort_cmp(pc_right, i) < 0);
3088 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3089 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3090 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3094 #define qsort_assert(t) ((void)0)
3096 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3100 /* ****************************************************************** qsort */
3106 I32 (*compare)(SV *a, SV *b))
3110 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3111 int next_stack_entry = 0;
3115 #ifdef QSORT_ORDER_GUESS
3116 int qsort_break_even;
3120 /* Make sure we actually have work to do.
3122 if (num_elts <= 1) {
3126 /* Setup the initial partition definition and fall into the sorting loop
3129 part_right = (int)(num_elts - 1);
3130 #ifdef QSORT_ORDER_GUESS
3131 qsort_break_even = QSORT_BREAK_EVEN;
3133 #define qsort_break_even QSORT_BREAK_EVEN
3136 if ((part_right - part_left) >= qsort_break_even) {
3137 /* OK, this is gonna get hairy, so lets try to document all the
3138 concepts and abbreviations and variables and what they keep
3141 pc: pivot chunk - the set of array elements we accumulate in the
3142 middle of the partition, all equal in value to the original
3143 pivot element selected. The pc is defined by:
3145 pc_left - the leftmost array index of the pc
3146 pc_right - the rightmost array index of the pc
3148 we start with pc_left == pc_right and only one element
3149 in the pivot chunk (but it can grow during the scan).
3151 u: uncompared elements - the set of elements in the partition
3152 we have not yet compared to the pivot value. There are two
3153 uncompared sets during the scan - one to the left of the pc
3154 and one to the right.
3156 u_right - the rightmost index of the left side's uncompared set
3157 u_left - the leftmost index of the right side's uncompared set
3159 The leftmost index of the left sides's uncompared set
3160 doesn't need its own variable because it is always defined
3161 by the leftmost edge of the whole partition (part_left). The
3162 same goes for the rightmost edge of the right partition
3165 We know there are no uncompared elements on the left once we
3166 get u_right < part_left and no uncompared elements on the
3167 right once u_left > part_right. When both these conditions
3168 are met, we have completed the scan of the partition.
3170 Any elements which are between the pivot chunk and the
3171 uncompared elements should be less than the pivot value on
3172 the left side and greater than the pivot value on the right
3173 side (in fact, the goal of the whole algorithm is to arrange
3174 for that to be true and make the groups of less-than and
3175 greater-then elements into new partitions to sort again).
3177 As you marvel at the complexity of the code and wonder why it
3178 has to be so confusing. Consider some of the things this level
3179 of confusion brings:
3181 Once I do a compare, I squeeze every ounce of juice out of it. I
3182 never do compare calls I don't have to do, and I certainly never
3185 I also never swap any elements unless I can prove there is a
3186 good reason. Many sort algorithms will swap a known value with
3187 an uncompared value just to get things in the right place (or
3188 avoid complexity :-), but that uncompared value, once it gets
3189 compared, may then have to be swapped again. A lot of the
3190 complexity of this code is due to the fact that it never swaps
3191 anything except compared values, and it only swaps them when the
3192 compare shows they are out of position.
3194 int pc_left, pc_right;
3195 int u_right, u_left;
3199 pc_left = ((part_left + part_right) / 2);
3201 u_right = pc_left - 1;
3202 u_left = pc_right + 1;
3204 /* Qsort works best when the pivot value is also the median value
3205 in the partition (unfortunately you can't find the median value
3206 without first sorting :-), so to give the algorithm a helping
3207 hand, we pick 3 elements and sort them and use the median value
3208 of that tiny set as the pivot value.
3210 Some versions of qsort like to use the left middle and right as
3211 the 3 elements to sort so they can insure the ends of the
3212 partition will contain values which will stop the scan in the
3213 compare loop, but when you have to call an arbitrarily complex
3214 routine to do a compare, its really better to just keep track of
3215 array index values to know when you hit the edge of the
3216 partition and avoid the extra compare. An even better reason to
3217 avoid using a compare call is the fact that you can drop off the
3218 edge of the array if someone foolishly provides you with an
3219 unstable compare function that doesn't always provide consistent
3222 So, since it is simpler for us to compare the three adjacent
3223 elements in the middle of the partition, those are the ones we
3224 pick here (conveniently pointed at by u_right, pc_left, and
3225 u_left). The values of the left, center, and right elements
3226 are refered to as l c and r in the following comments.
3229 #ifdef QSORT_ORDER_GUESS
3232 s = qsort_cmp(u_right, pc_left);
3235 s = qsort_cmp(pc_left, u_left);
3236 /* if l < c, c < r - already in order - nothing to do */
3238 /* l < c, c == r - already in order, pc grows */
3240 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3242 /* l < c, c > r - need to know more */
3243 s = qsort_cmp(u_right, u_left);
3245 /* l < c, c > r, l < r - swap c & r to get ordered */
3246 qsort_swap(pc_left, u_left);
3247 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3248 } else if (s == 0) {
3249 /* l < c, c > r, l == r - swap c&r, grow pc */
3250 qsort_swap(pc_left, u_left);
3252 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3254 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3255 qsort_rotate(pc_left, u_right, u_left);
3256 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3259 } else if (s == 0) {
3261 s = qsort_cmp(pc_left, u_left);
3263 /* l == c, c < r - already in order, grow pc */
3265 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3266 } else if (s == 0) {
3267 /* l == c, c == r - already in order, grow pc both ways */
3270 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3272 /* l == c, c > r - swap l & r, grow pc */
3273 qsort_swap(u_right, u_left);
3275 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3279 s = qsort_cmp(pc_left, u_left);
3281 /* l > c, c < r - need to know more */
3282 s = qsort_cmp(u_right, u_left);
3284 /* l > c, c < r, l < r - swap l & c to get ordered */
3285 qsort_swap(u_right, pc_left);
3286 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3287 } else if (s == 0) {
3288 /* l > c, c < r, l == r - swap l & c, grow pc */
3289 qsort_swap(u_right, pc_left);
3291 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3293 /* l > c, c < r, l > r - rotate lcr into crl to order */
3294 qsort_rotate(u_right, pc_left, u_left);
3295 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3297 } else if (s == 0) {
3298 /* l > c, c == r - swap ends, grow pc */
3299 qsort_swap(u_right, u_left);
3301 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3303 /* l > c, c > r - swap ends to get in order */
3304 qsort_swap(u_right, u_left);
3305 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3308 /* We now know the 3 middle elements have been compared and
3309 arranged in the desired order, so we can shrink the uncompared
3314 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3316 /* The above massive nested if was the simple part :-). We now have
3317 the middle 3 elements ordered and we need to scan through the
3318 uncompared sets on either side, swapping elements that are on
3319 the wrong side or simply shuffling equal elements around to get
3320 all equal elements into the pivot chunk.
3324 int still_work_on_left;
3325 int still_work_on_right;
3327 /* Scan the uncompared values on the left. If I find a value
3328 equal to the pivot value, move it over so it is adjacent to
3329 the pivot chunk and expand the pivot chunk. If I find a value
3330 less than the pivot value, then just leave it - its already
3331 on the correct side of the partition. If I find a greater
3332 value, then stop the scan.
3334 while (still_work_on_left = (u_right >= part_left)) {
3335 s = qsort_cmp(u_right, pc_left);
3338 } else if (s == 0) {
3340 if (pc_left != u_right) {
3341 qsort_swap(u_right, pc_left);
3347 qsort_assert(u_right < pc_left);
3348 qsort_assert(pc_left <= pc_right);
3349 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3350 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3353 /* Do a mirror image scan of uncompared values on the right
3355 while (still_work_on_right = (u_left <= part_right)) {
3356 s = qsort_cmp(pc_right, u_left);
3359 } else if (s == 0) {
3361 if (pc_right != u_left) {
3362 qsort_swap(pc_right, u_left);
3368 qsort_assert(u_left > pc_right);
3369 qsort_assert(pc_left <= pc_right);
3370 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3371 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3374 if (still_work_on_left) {
3375 /* I know I have a value on the left side which needs to be
3376 on the right side, but I need to know more to decide
3377 exactly the best thing to do with it.
3379 if (still_work_on_right) {
3380 /* I know I have values on both side which are out of
3381 position. This is a big win because I kill two birds
3382 with one swap (so to speak). I can advance the
3383 uncompared pointers on both sides after swapping both
3384 of them into the right place.
3386 qsort_swap(u_right, u_left);
3389 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3391 /* I have an out of position value on the left, but the
3392 right is fully scanned, so I "slide" the pivot chunk
3393 and any less-than values left one to make room for the
3394 greater value over on the right. If the out of position
3395 value is immediately adjacent to the pivot chunk (there
3396 are no less-than values), I can do that with a swap,
3397 otherwise, I have to rotate one of the less than values
3398 into the former position of the out of position value
3399 and the right end of the pivot chunk into the left end
3403 if (pc_left == u_right) {
3404 qsort_swap(u_right, pc_right);
3405 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3407 qsort_rotate(u_right, pc_left, pc_right);
3408 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3413 } else if (still_work_on_right) {
3414 /* Mirror image of complex case above: I have an out of
3415 position value on the right, but the left is fully
3416 scanned, so I need to shuffle things around to make room
3417 for the right value on the left.
3420 if (pc_right == u_left) {
3421 qsort_swap(u_left, pc_left);
3422 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3424 qsort_rotate(pc_right, pc_left, u_left);
3425 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3430 /* No more scanning required on either side of partition,
3431 break out of loop and figure out next set of partitions
3437 /* The elements in the pivot chunk are now in the right place. They
3438 will never move or be compared again. All I have to do is decide
3439 what to do with the stuff to the left and right of the pivot
3442 Notes on the QSORT_ORDER_GUESS ifdef code:
3444 1. If I just built these partitions without swapping any (or
3445 very many) elements, there is a chance that the elements are
3446 already ordered properly (being properly ordered will
3447 certainly result in no swapping, but the converse can't be
3450 2. A (properly written) insertion sort will run faster on
3451 already ordered data than qsort will.
3453 3. Perhaps there is some way to make a good guess about
3454 switching to an insertion sort earlier than partition size 6
3455 (for instance - we could save the partition size on the stack
3456 and increase the size each time we find we didn't swap, thus
3457 switching to insertion sort earlier for partitions with a
3458 history of not swapping).
3460 4. Naturally, if I just switch right away, it will make
3461 artificial benchmarks with pure ascending (or descending)
3462 data look really good, but is that a good reason in general?
3466 #ifdef QSORT_ORDER_GUESS
3468 #if QSORT_ORDER_GUESS == 1
3469 qsort_break_even = (part_right - part_left) + 1;
3471 #if QSORT_ORDER_GUESS == 2
3472 qsort_break_even *= 2;
3474 #if QSORT_ORDER_GUESS == 3
3475 int prev_break = qsort_break_even;
3476 qsort_break_even *= qsort_break_even;
3477 if (qsort_break_even < prev_break) {
3478 qsort_break_even = (part_right - part_left) + 1;
3482 qsort_break_even = QSORT_BREAK_EVEN;
3486 if (part_left < pc_left) {
3487 /* There are elements on the left which need more processing.
3488 Check the right as well before deciding what to do.
3490 if (pc_right < part_right) {
3491 /* We have two partitions to be sorted. Stack the biggest one
3492 and process the smallest one on the next iteration. This
3493 minimizes the stack height by insuring that any additional
3494 stack entries must come from the smallest partition which
3495 (because it is smallest) will have the fewest
3496 opportunities to generate additional stack entries.
3498 if ((part_right - pc_right) > (pc_left - part_left)) {
3499 /* stack the right partition, process the left */
3500 partition_stack[next_stack_entry].left = pc_right + 1;
3501 partition_stack[next_stack_entry].right = part_right;
3502 #ifdef QSORT_ORDER_GUESS
3503 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3505 part_right = pc_left - 1;
3507 /* stack the left partition, process the right */
3508 partition_stack[next_stack_entry].left = part_left;
3509 partition_stack[next_stack_entry].right = pc_left - 1;
3510 #ifdef QSORT_ORDER_GUESS
3511 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3513 part_left = pc_right + 1;
3515 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3518 /* The elements on the left are the only remaining elements
3519 that need sorting, arrange for them to be processed as the
3522 part_right = pc_left - 1;
3524 } else if (pc_right < part_right) {
3525 /* There is only one chunk on the right to be sorted, make it
3526 the new partition and loop back around.
3528 part_left = pc_right + 1;
3530 /* This whole partition wound up in the pivot chunk, so
3531 we need to get a new partition off the stack.
3533 if (next_stack_entry == 0) {
3534 /* the stack is empty - we are done */
3538 part_left = partition_stack[next_stack_entry].left;
3539 part_right = partition_stack[next_stack_entry].right;
3540 #ifdef QSORT_ORDER_GUESS
3541 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3545 /* This partition is too small to fool with qsort complexity, just
3546 do an ordinary insertion sort to minimize overhead.
3549 /* Assume 1st element is in right place already, and start checking
3550 at 2nd element to see where it should be inserted.
3552 for (i = part_left + 1; i <= part_right; ++i) {
3554 /* Scan (backwards - just in case 'i' is already in right place)
3555 through the elements already sorted to see if the ith element
3556 belongs ahead of one of them.
3558 for (j = i - 1; j >= part_left; --j) {
3559 if (qsort_cmp(i, j) >= 0) {
3560 /* i belongs right after j
3567 /* Looks like we really need to move some things
3571 for (k = i - 1; k >= j; --k)
3572 array[k + 1] = array[k];
3577 /* That partition is now sorted, grab the next one, or get out
3578 of the loop if there aren't any more.
3581 if (next_stack_entry == 0) {
3582 /* the stack is empty - we are done */
3586 part_left = partition_stack[next_stack_entry].left;
3587 part_right = partition_stack[next_stack_entry].right;
3588 #ifdef QSORT_ORDER_GUESS
3589 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3594 /* Believe it or not, the array is sorted at this point! */