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 if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp
91 || strnNE(pm->op_pmregexp->precomp, t, len)
92 || pm->op_pmregexp->precomp[len]) {
93 if (pm->op_pmregexp) {
94 ReREFCNT_dec(pm->op_pmregexp);
95 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
98 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
99 pm->op_pmregexp = pregcomp(t, t + len, pm);
103 if (!pm->op_pmregexp->prelen && curpm)
105 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
106 pm->op_pmflags |= PMf_WHITE;
108 if (pm->op_pmflags & PMf_KEEP) {
109 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
110 cLOGOP->op_first->op_next = op->op_next;
118 register PMOP *pm = (PMOP*) cLOGOP->op_other;
119 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
120 register SV *dstr = cx->sb_dstr;
121 register char *s = cx->sb_s;
122 register char *m = cx->sb_m;
123 char *orig = cx->sb_orig;
124 register REGEXP *rx = cx->sb_rx;
126 rxres_restore(&cx->sb_rxres, rx);
128 if (cx->sb_iters++) {
129 if (cx->sb_iters > cx->sb_maxiters)
130 DIE("Substitution loop");
132 if (!cx->sb_rxtainted)
133 cx->sb_rxtainted = SvTAINTED(TOPs);
134 sv_catsv(dstr, POPs);
137 if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
138 s == m, Nullsv, NULL,
139 cx->sb_safebase ? 0 : REXEC_COPY_STR))
141 SV *targ = cx->sb_targ;
142 sv_catpvn(dstr, s, cx->sb_strend - s);
144 TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
146 (void)SvOOK_off(targ);
147 Safefree(SvPVX(targ));
148 SvPVX(targ) = SvPVX(dstr);
149 SvCUR_set(targ, SvCUR(dstr));
150 SvLEN_set(targ, SvLEN(dstr));
153 (void)SvPOK_only(targ);
157 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
158 LEAVE_SCOPE(cx->sb_oldsave);
160 RETURNOP(pm->op_next);
163 if (rx->subbase && rx->subbase != orig) {
166 cx->sb_orig = orig = rx->subbase;
168 cx->sb_strend = s + (cx->sb_strend - m);
170 cx->sb_m = m = rx->startp[0];
171 sv_catpvn(dstr, s, m-s);
172 cx->sb_s = rx->endp[0];
173 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
174 rxres_save(&cx->sb_rxres, rx);
175 RETURNOP(pm->op_pmreplstart);
179 rxres_save(void **rsp, REGEXP *rx)
184 if (!p || p[1] < rx->nparens) {
185 i = 6 + rx->nparens * 2;
193 *p++ = (UV)rx->subbase;
194 rx->subbase = Nullch;
198 *p++ = (UV)rx->subbeg;
199 *p++ = (UV)rx->subend;
200 for (i = 0; i <= rx->nparens; ++i) {
201 *p++ = (UV)rx->startp[i];
202 *p++ = (UV)rx->endp[i];
207 rxres_restore(void **rsp, REGEXP *rx)
212 Safefree(rx->subbase);
213 rx->subbase = (char*)(*p);
218 rx->subbeg = (char*)(*p++);
219 rx->subend = (char*)(*p++);
220 for (i = 0; i <= rx->nparens; ++i) {
221 rx->startp[i] = (char*)(*p++);
222 rx->endp[i] = (char*)(*p++);
227 rxres_free(void **rsp)
232 Safefree((char*)(*p));
240 djSP; dMARK; dORIGMARK;
241 register SV *form = *++MARK;
253 bool chopspace = (strchr(chopset, ' ') != Nullch);
260 if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
261 SvREADONLY_off(form);
265 SvPV_force(formtarget, len);
266 t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */
269 /* need to jump to the next word */
270 s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN;
279 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
280 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
281 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
282 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
283 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
285 case FF_CHECKNL: name = "CHECKNL"; break;
286 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
287 case FF_SPACE: name = "SPACE"; break;
288 case FF_HALFSPACE: name = "HALFSPACE"; break;
289 case FF_ITEM: name = "ITEM"; break;
290 case FF_CHOP: name = "CHOP"; break;
291 case FF_LINEGLOB: name = "LINEGLOB"; break;
292 case FF_NEWLINE: name = "NEWLINE"; break;
293 case FF_MORE: name = "MORE"; break;
294 case FF_LINEMARK: name = "LINEMARK"; break;
295 case FF_END: name = "END"; break;
298 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
300 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
329 warn("Not enough format arguments");
334 item = s = SvPV(sv, len);
336 if (itemsize > fieldsize)
337 itemsize = fieldsize;
338 send = chophere = s + itemsize;
350 item = s = SvPV(sv, len);
352 if (itemsize <= fieldsize) {
353 send = chophere = s + itemsize;
364 itemsize = fieldsize;
365 send = chophere = s + itemsize;
366 while (s < send || (s == send && isSPACE(*s))) {
376 if (strchr(chopset, *s))
381 itemsize = chophere - item;
386 arg = fieldsize - itemsize;
395 arg = fieldsize - itemsize;
409 int ch = *t++ = *s++;
413 if ( !((*t++ = *s++) & ~31) )
423 while (*s && isSPACE(*s))
430 item = s = SvPV(sv, len);
443 SvCUR_set(formtarget, t - SvPVX(formtarget));
444 sv_catpvn(formtarget, item, itemsize);
445 SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1);
446 t = SvPVX(formtarget) + SvCUR(formtarget);
451 /* If the field is marked with ^ and the value is undefined,
454 if ((arg & 512) && !SvOK(sv)) {
462 /* Formats aren't yet marked for locales, so assume "yes". */
465 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
467 sprintf(t, "%*.0f", (int) fieldsize, value);
474 while (t-- > linemark && *t == ' ') ;
482 if (arg) { /* repeat until fields exhausted? */
484 SvCUR_set(formtarget, t - SvPVX(formtarget));
485 lines += FmLINES(formtarget);
488 if (strnEQ(linemark, linemark - arg, arg))
489 DIE("Runaway format");
491 FmLINES(formtarget) = lines;
493 RETURNOP(cLISTOP->op_first);
504 arg = fieldsize - itemsize;
511 if (strnEQ(s," ",3)) {
512 while (s > SvPVX(formtarget) && isSPACE(s[-1]))
523 SvCUR_set(formtarget, t - SvPVX(formtarget));
524 FmLINES(formtarget) += lines;
536 if (stack_base + *markstack_ptr == sp) {
538 if (GIMME_V == G_SCALAR)
540 RETURNOP(op->op_next->op_next);
542 stack_sp = stack_base + *markstack_ptr + 1;
543 pp_pushmark(ARGS); /* push dst */
544 pp_pushmark(ARGS); /* push src */
545 ENTER; /* enter outer scope */
549 /* SAVE_DEFSV does *not* suffice here */
550 save_sptr(av_fetch(thr->threadsv, find_threadsv("_"), FALSE));
552 SAVESPTR(GvSV(defgv));
553 #endif /* USE_THREADS */
554 ENTER; /* enter inner scope */
557 src = stack_base[*markstack_ptr];
562 if (op->op_type == OP_MAPSTART)
563 pp_pushmark(ARGS); /* push top */
564 return ((LOGOP*)op->op_next)->op_other;
569 DIE("panic: mapstart"); /* uses grepstart */
575 I32 diff = (sp - stack_base) - *markstack_ptr;
583 if (diff > markstack_ptr[-1] - markstack_ptr[-2]) {
584 shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]);
585 count = (sp - stack_base) - markstack_ptr[-1] + 2;
590 markstack_ptr[-1] += shift;
591 *markstack_ptr += shift;
595 dst = stack_base + (markstack_ptr[-2] += diff) - 1;
598 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
600 LEAVE; /* exit inner scope */
603 if (markstack_ptr[-1] > *markstack_ptr) {
607 (void)POPMARK; /* pop top */
608 LEAVE; /* exit outer scope */
609 (void)POPMARK; /* pop src */
610 items = --*markstack_ptr - markstack_ptr[-1];
611 (void)POPMARK; /* pop dst */
612 SP = stack_base + POPMARK; /* pop original mark */
613 if (gimme == G_SCALAR) {
617 else if (gimme == G_ARRAY)
624 ENTER; /* enter inner scope */
627 src = stack_base[markstack_ptr[-1]];
631 RETURNOP(cLOGOP->op_other);
638 djSP; dMARK; dORIGMARK;
640 SV **myorigmark = ORIGMARK;
646 OP* nextop = op->op_next;
648 if (gimme != G_ARRAY) {
653 if (op->op_flags & OPf_STACKED) {
655 if (op->op_flags & OPf_SPECIAL) {
656 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
657 kid = kUNOP->op_first; /* pass rv2gv */
658 kid = kUNOP->op_first; /* pass leave */
659 sortcop = kid->op_next;
660 stash = curcop->cop_stash;
663 cv = sv_2cv(*++MARK, &stash, &gv, 0);
664 if (!(cv && CvROOT(cv))) {
666 SV *tmpstr = sv_newmortal();
667 gv_efullname3(tmpstr, gv, Nullch);
668 if (cv && CvXSUB(cv))
669 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
670 DIE("Undefined sort subroutine \"%s\" called",
675 DIE("Xsub called in sort");
676 DIE("Undefined subroutine in sort");
678 DIE("Not a CODE reference in sort");
680 sortcop = CvSTART(cv);
681 SAVESPTR(CvROOT(cv)->op_ppaddr);
682 CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
685 curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
690 stash = curcop->cop_stash;
694 while (MARK < SP) { /* This may or may not shift down one here. */
696 if (*up = *++MARK) { /* Weed out nulls. */
698 if (!sortcop && !SvPOK(*up))
699 (void)sv_2pv(*up, &na);
703 max = --up - myorigmark;
709 bool oldcatch = CATCH_GET;
717 AvREAL_off(sortstack);
718 av_extend(sortstack, 32);
721 SWITCHSTACK(curstack, sortstack);
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);
745 SWITCHSTACK(sortstack, oldstack);
752 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
753 qsortsv(ORIGMARK+1, max,
754 (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
757 stack_sp = ORIGMARK + max;
765 if (GIMME == G_ARRAY)
766 return cCONDOP->op_true;
767 return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
774 if (GIMME == G_ARRAY) {
775 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
779 SV *targ = PAD_SV(op->op_targ);
781 if ((op->op_private & OPpFLIP_LINENUM)
782 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
784 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
785 if (op->op_flags & OPf_SPECIAL) {
793 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
806 if (GIMME == G_ARRAY) {
812 if (SvNIOKp(left) || !SvPOKp(left) ||
813 (looks_like_number(left) && *SvPVX(left) != '0') )
818 EXTEND_MORTAL(max - i + 1);
819 EXTEND(SP, max - i + 1);
822 sv = sv_2mortal(newSViv(i++));
827 SV *final = sv_mortalcopy(right);
829 char *tmps = SvPV(final, len);
831 sv = sv_mortalcopy(left);
832 while (!SvNIOKp(sv) && SvCUR(sv) <= len &&
833 strNE(SvPVX(sv),tmps) ) {
835 sv = sv_2mortal(newSVsv(sv));
838 if (strEQ(SvPVX(sv),tmps))
844 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
846 if ((op->op_private & OPpFLIP_LINENUM)
847 ? last_in_gv && SvIV(sv) == IoLINES(GvIOp(last_in_gv))
849 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
850 sv_catpv(targ, "E0");
861 dopoptolabel(char *label)
865 register PERL_CONTEXT *cx;
867 for (i = cxstack_ix; i >= 0; i--) {
869 switch (cx->cx_type) {
872 warn("Exiting substitution via %s", op_name[op->op_type]);
876 warn("Exiting subroutine via %s", op_name[op->op_type]);
880 warn("Exiting eval via %s", op_name[op->op_type]);
884 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
887 if (!cx->blk_loop.label ||
888 strNE(label, cx->blk_loop.label) ) {
889 DEBUG_l(deb("(Skipping label #%ld %s)\n",
890 (long)i, cx->blk_loop.label));
893 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
903 I32 gimme = block_gimme();
904 return (gimme == G_VOID) ? G_SCALAR : gimme;
913 cxix = dopoptosub(cxstack_ix);
917 switch (cxstack[cxix].blk_gimme) {
923 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
930 dopoptosub(I32 startingblock)
934 register PERL_CONTEXT *cx;
935 for (i = startingblock; i >= 0; i--) {
937 switch (cx->cx_type) {
942 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
950 dopoptoeval(I32 startingblock)
954 register PERL_CONTEXT *cx;
955 for (i = startingblock; i >= 0; i--) {
957 switch (cx->cx_type) {
961 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
969 dopoptoloop(I32 startingblock)
973 register PERL_CONTEXT *cx;
974 for (i = startingblock; i >= 0; i--) {
976 switch (cx->cx_type) {
979 warn("Exiting substitution via %s", op_name[op->op_type]);
983 warn("Exiting subroutine via %s", op_name[op->op_type]);
987 warn("Exiting eval via %s", op_name[op->op_type]);
991 warn("Exiting pseudo-block via %s", op_name[op->op_type]);
994 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
1005 register PERL_CONTEXT *cx;
1009 while (cxstack_ix > cxix) {
1010 cx = &cxstack[cxstack_ix];
1011 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1012 (long) cxstack_ix+1, block_type[cx->cx_type]));
1013 /* Note: we don't need to restore the base context info till the end. */
1014 switch (cx->cx_type) {
1017 continue; /* not break */
1035 die_where(char *message)
1040 register PERL_CONTEXT *cx;
1046 STRLEN klen = strlen(message);
1048 svp = hv_fetch(ERRHV, message, klen, TRUE);
1051 static char prefix[] = "\t(in cleanup) ";
1053 sv_upgrade(*svp, SVt_IV);
1054 (void)SvIOK_only(*svp);
1057 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1058 sv_catpvn(err, prefix, sizeof(prefix)-1);
1059 sv_catpvn(err, message, klen);
1065 sv_setpv(ERRSV, message);
1067 cxix = dopoptoeval(cxstack_ix);
1071 if (cxix < cxstack_ix)
1075 if (cx->cx_type != CXt_EVAL) {
1076 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
1081 if (gimme == G_SCALAR)
1082 *++newsp = &sv_undef;
1087 if (optype == OP_REQUIRE) {
1088 char* msg = SvPVx(ERRSV, na);
1089 DIE("%s", *msg ? msg : "Compilation failed in require");
1091 return pop_return();
1094 PerlIO_printf(PerlIO_stderr(), "%s",message);
1095 PerlIO_flush(PerlIO_stderr());
1104 if (SvTRUE(left) != SvTRUE(right))
1116 RETURNOP(cLOGOP->op_other);
1125 RETURNOP(cLOGOP->op_other);
1131 register I32 cxix = dopoptosub(cxstack_ix);
1132 register PERL_CONTEXT *cx;
1143 if (GIMME != G_ARRAY)
1147 if (DBsub && cxix >= 0 &&
1148 cxstack[cxix].blk_sub.cv == GvCV(DBsub))
1152 cxix = dopoptosub(cxix - 1);
1154 cx = &cxstack[cxix];
1155 if (cxstack[cxix].cx_type == CXt_SUB) {
1156 dbcxix = dopoptosub(cxix - 1);
1157 /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
1158 field below is defined for any cx. */
1159 if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
1160 cx = &cxstack[dbcxix];
1163 if (GIMME != G_ARRAY) {
1166 sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash));
1171 PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
1172 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1173 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1176 if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
1178 gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
1179 PUSHs(sv_2mortal(sv));
1180 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1183 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1184 PUSHs(sv_2mortal(newSViv(0)));
1186 gimme = (I32)cx->blk_gimme;
1187 if (gimme == G_VOID)
1190 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1191 if (cx->cx_type == CXt_EVAL) {
1192 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1193 PUSHs(cx->blk_eval.cur_text);
1196 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1197 /* Require, put the name. */
1198 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
1202 else if (cx->cx_type == CXt_SUB &&
1203 cx->blk_sub.hasargs &&
1204 curcop->cop_stash == debstash)
1206 AV *ary = cx->blk_sub.argarray;
1207 int off = AvARRAY(ary) - AvALLOC(ary);
1211 dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1214 AvREAL_off(dbargs); /* XXX Should be REIFY */
1217 if (AvMAX(dbargs) < AvFILL(ary) + off)
1218 av_extend(dbargs, AvFILL(ary) + off);
1219 Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*);
1220 AvFILL(dbargs) = AvFILL(ary) + off;
1226 sortcv(SV *a, SV *b)
1229 I32 oldsaveix = savestack_ix;
1230 I32 oldscopeix = scopestack_ix;
1234 stack_sp = stack_base;
1237 if (stack_sp != stack_base + 1)
1238 croak("Sort subroutine didn't return single value");
1239 if (!SvNIOKp(*stack_sp))
1240 croak("Sort subroutine didn't return a numeric value");
1241 result = SvIV(*stack_sp);
1242 while (scopestack_ix > oldscopeix) {
1245 leave_scope(oldsaveix);
1258 sv_reset(tmps, curcop->cop_stash);
1271 TAINT_NOT; /* Each statement is presumed innocent */
1272 stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
1275 if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace))
1279 register PERL_CONTEXT *cx;
1280 I32 gimme = G_ARRAY;
1287 DIE("No DB::DB routine defined");
1289 if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
1301 push_return(op->op_next);
1302 PUSHBLOCK(cx, CXt_SUB, sp);
1305 (void)SvREFCNT_inc(cv);
1307 curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
1308 RETURNOP(CvSTART(cv));
1322 register PERL_CONTEXT *cx;
1323 I32 gimme = GIMME_V;
1330 if (op->op_flags & OPf_SPECIAL)
1331 svp = save_threadsv(op->op_targ); /* per-thread variable */
1333 #endif /* USE_THREADS */
1335 svp = &curpad[op->op_targ]; /* "my" variable */
1339 svp = &GvSV((GV*)POPs); /* symbol table variable */
1345 PUSHBLOCK(cx, CXt_LOOP, SP);
1346 PUSHLOOP(cx, svp, MARK);
1347 if (op->op_flags & OPf_STACKED)
1348 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1350 cx->blk_loop.iterary = curstack;
1351 AvFILL(curstack) = sp - stack_base;
1352 cx->blk_loop.iterix = MARK - stack_base;
1361 register PERL_CONTEXT *cx;
1362 I32 gimme = GIMME_V;
1368 PUSHBLOCK(cx, CXt_LOOP, SP);
1369 PUSHLOOP(cx, 0, SP);
1377 register PERL_CONTEXT *cx;
1378 struct block_loop cxloop;
1386 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1389 if (gimme == G_VOID)
1391 else if (gimme == G_SCALAR) {
1393 *++newsp = sv_mortalcopy(*SP);
1395 *++newsp = &sv_undef;
1399 *++newsp = sv_mortalcopy(*++mark);
1400 TAINT_NOT; /* Each item is independent */
1406 POPLOOP2(); /* Stack values are safe: release loop vars ... */
1407 curpm = newpm; /* ... and pop $1 et al */
1419 register PERL_CONTEXT *cx;
1420 struct block_sub cxsub;
1421 bool popsub2 = FALSE;
1427 if (curstack == sortstack) {
1428 if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
1429 if (cxstack_ix > sortcxix)
1431 AvARRAY(curstack)[1] = *SP;
1432 stack_sp = stack_base + 1;
1437 cxix = dopoptosub(cxstack_ix);
1439 DIE("Can't return outside a subroutine");
1440 if (cxix < cxstack_ix)
1444 switch (cx->cx_type) {
1446 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1451 if (optype == OP_REQUIRE &&
1452 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1454 /* Unassume the success we assumed earlier. */
1455 char *name = cx->blk_eval.old_name;
1456 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
1457 DIE("%s did not return a true value", name);
1461 DIE("panic: return");
1465 if (gimme == G_SCALAR) {
1467 *++newsp = (popsub2 && SvTEMP(*SP))
1468 ? *SP : sv_mortalcopy(*SP);
1470 *++newsp = &sv_undef;
1472 else if (gimme == G_ARRAY) {
1473 while (++MARK <= SP) {
1474 *++newsp = (popsub2 && SvTEMP(*MARK))
1475 ? *MARK : sv_mortalcopy(*MARK);
1476 TAINT_NOT; /* Each item is independent */
1481 /* Stack values are safe: */
1483 POPSUB2(); /* release CV and @_ ... */
1485 curpm = newpm; /* ... and pop $1 et al */
1488 return pop_return();
1495 register PERL_CONTEXT *cx;
1496 struct block_loop cxloop;
1497 struct block_sub cxsub;
1504 SV **mark = stack_base + cxstack[cxstack_ix].blk_oldsp;
1506 if (op->op_flags & OPf_SPECIAL) {
1507 cxix = dopoptoloop(cxstack_ix);
1509 DIE("Can't \"last\" outside a block");
1512 cxix = dopoptolabel(cPVOP->op_pv);
1514 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1516 if (cxix < cxstack_ix)
1520 switch (cx->cx_type) {
1522 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1524 nextop = cxloop.last_op->op_next;
1527 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1529 nextop = pop_return();
1533 nextop = pop_return();
1540 if (gimme == G_SCALAR) {
1542 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1543 ? *SP : sv_mortalcopy(*SP);
1545 *++newsp = &sv_undef;
1547 else if (gimme == G_ARRAY) {
1548 while (++MARK <= SP) {
1549 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1550 ? *MARK : sv_mortalcopy(*MARK);
1551 TAINT_NOT; /* Each item is independent */
1557 /* Stack values are safe: */
1560 POPLOOP2(); /* release loop vars ... */
1564 POPSUB2(); /* release CV and @_ ... */
1567 curpm = newpm; /* ... and pop $1 et al */
1576 register PERL_CONTEXT *cx;
1579 if (op->op_flags & OPf_SPECIAL) {
1580 cxix = dopoptoloop(cxstack_ix);
1582 DIE("Can't \"next\" outside a block");
1585 cxix = dopoptolabel(cPVOP->op_pv);
1587 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1589 if (cxix < cxstack_ix)
1593 oldsave = scopestack[scopestack_ix - 1];
1594 LEAVE_SCOPE(oldsave);
1595 return cx->blk_loop.next_op;
1601 register PERL_CONTEXT *cx;
1604 if (op->op_flags & OPf_SPECIAL) {
1605 cxix = dopoptoloop(cxstack_ix);
1607 DIE("Can't \"redo\" outside a block");
1610 cxix = dopoptolabel(cPVOP->op_pv);
1612 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1614 if (cxix < cxstack_ix)
1618 oldsave = scopestack[scopestack_ix - 1];
1619 LEAVE_SCOPE(oldsave);
1620 return cx->blk_loop.redo_op;
1623 static OP* lastgotoprobe;
1626 dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
1630 static char too_deep[] = "Target of goto is too deeply nested";
1634 if (o->op_type == OP_LEAVE ||
1635 o->op_type == OP_SCOPE ||
1636 o->op_type == OP_LEAVELOOP ||
1637 o->op_type == OP_LEAVETRY)
1639 *ops++ = cUNOPo->op_first;
1644 if (o->op_flags & OPf_KIDS) {
1645 /* First try all the kids at this level, since that's likeliest. */
1646 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1647 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1648 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1651 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1652 if (kid == lastgotoprobe)
1654 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1656 (ops[-1]->op_type != OP_NEXTSTATE &&
1657 ops[-1]->op_type != OP_DBSTATE)))
1659 if (o = dofindlabel(kid, label, ops, oplimit))
1669 return pp_goto(ARGS);
1678 register PERL_CONTEXT *cx;
1679 #define GOTO_DEPTH 64
1680 OP *enterops[GOTO_DEPTH];
1682 int do_dump = (op->op_type == OP_DUMP);
1685 if (op->op_flags & OPf_STACKED) {
1688 /* This egregious kludge implements goto &subroutine */
1689 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1691 register PERL_CONTEXT *cx;
1692 CV* cv = (CV*)SvRV(sv);
1697 if (!CvROOT(cv) && !CvXSUB(cv)) {
1699 SV *tmpstr = sv_newmortal();
1700 gv_efullname3(tmpstr, CvGV(cv), Nullch);
1701 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1703 DIE("Goto undefined subroutine");
1706 /* First do some returnish stuff. */
1707 cxix = dopoptosub(cxstack_ix);
1709 DIE("Can't goto subroutine outside a subroutine");
1710 if (cxix < cxstack_ix)
1714 if (cx->blk_sub.hasargs) { /* put @_ back onto stack */
1715 AV* av = cx->blk_sub.argarray;
1717 items = AvFILL(av) + 1;
1719 EXTEND(stack_sp, items); /* @_ could have been extended. */
1720 Copy(AvARRAY(av), stack_sp, items, SV*);
1723 SvREFCNT_dec(GvAV(defgv));
1724 GvAV(defgv) = cx->blk_sub.savearray;
1725 #endif /* USE_THREADS */
1729 if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
1730 SvREFCNT_dec(cx->blk_sub.cv);
1731 oldsave = scopestack[scopestack_ix - 1];
1732 LEAVE_SCOPE(oldsave);
1734 /* Now do some callish stuff. */
1737 if (CvOLDSTYLE(cv)) {
1738 I32 (*fp3)_((int,int,int));
1743 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1744 items = (*fp3)(CvXSUBANY(cv).any_i32,
1745 mark - stack_base + 1,
1747 sp = stack_base + items;
1750 stack_sp--; /* There is no cv arg. */
1751 (void)(*CvXSUB(cv))(cv);
1754 return pop_return();
1757 AV* padlist = CvPADLIST(cv);
1758 SV** svp = AvARRAY(padlist);
1759 cx->blk_sub.cv = cv;
1760 cx->blk_sub.olddepth = CvDEPTH(cv);
1762 if (CvDEPTH(cv) < 2)
1763 (void)SvREFCNT_inc(cv);
1764 else { /* save temporaries on recursion? */
1765 if (CvDEPTH(cv) == 100 && dowarn)
1766 sub_crush_depth(cv);
1767 if (CvDEPTH(cv) > AvFILL(padlist)) {
1768 AV *newpad = newAV();
1769 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
1770 I32 ix = AvFILL((AV*)svp[1]);
1771 svp = AvARRAY(svp[0]);
1772 for ( ;ix > 0; ix--) {
1773 if (svp[ix] != &sv_undef) {
1774 char *name = SvPVX(svp[ix]);
1775 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1778 /* outer lexical or anon code */
1779 av_store(newpad, ix,
1780 SvREFCNT_inc(oldpad[ix]) );
1782 else { /* our own lexical */
1784 av_store(newpad, ix, sv = (SV*)newAV());
1785 else if (*name == '%')
1786 av_store(newpad, ix, sv = (SV*)newHV());
1788 av_store(newpad, ix, sv = NEWSV(0,0));
1793 av_store(newpad, ix, sv = NEWSV(0,0));
1797 if (cx->blk_sub.hasargs) {
1800 av_store(newpad, 0, (SV*)av);
1801 AvFLAGS(av) = AVf_REIFY;
1803 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
1804 AvFILL(padlist) = CvDEPTH(cv);
1805 svp = AvARRAY(padlist);
1809 if (!cx->blk_sub.hasargs) {
1810 AV* av = (AV*)curpad[0];
1812 items = AvFILL(av) + 1;
1814 /* Mark is at the end of the stack. */
1816 Copy(AvARRAY(av), sp + 1, items, SV*);
1821 #endif /* USE_THREADS */
1823 curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
1825 if (cx->blk_sub.hasargs)
1826 #endif /* USE_THREADS */
1828 AV* av = (AV*)curpad[0];
1832 cx->blk_sub.savearray = GvAV(defgv);
1833 GvAV(defgv) = (AV*)SvREFCNT_inc(av);
1834 #endif /* USE_THREADS */
1835 cx->blk_sub.argarray = av;
1838 if (items >= AvMAX(av) + 1) {
1840 if (AvARRAY(av) != ary) {
1841 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
1842 SvPVX(av) = (char*)ary;
1844 if (items >= AvMAX(av) + 1) {
1845 AvMAX(av) = items - 1;
1846 Renew(ary,items+1,SV*);
1848 SvPVX(av) = (char*)ary;
1851 Copy(mark,AvARRAY(av),items,SV*);
1852 AvFILL(av) = items - 1;
1860 if (PERLDB_SUB && curstash != debstash) {
1862 * We do not care about using sv to call CV;
1863 * it's for informational purposes only.
1865 SV *sv = GvSV(DBsub);
1867 gv_efullname3(sv, CvGV(cv), Nullch);
1869 RETURNOP(CvSTART(cv));
1873 label = SvPV(sv,na);
1875 else if (op->op_flags & OPf_SPECIAL) {
1877 DIE("goto must have label");
1880 label = cPVOP->op_pv;
1882 if (label && *label) {
1889 for (ix = cxstack_ix; ix >= 0; ix--) {
1891 switch (cx->cx_type) {
1893 gotoprobe = eval_root; /* XXX not good for nested eval */
1896 gotoprobe = cx->blk_oldcop->op_sibling;
1902 gotoprobe = cx->blk_oldcop->op_sibling;
1904 gotoprobe = main_root;
1907 if (CvDEPTH(cx->blk_sub.cv)) {
1908 gotoprobe = CvROOT(cx->blk_sub.cv);
1913 DIE("Can't \"goto\" outside a block");
1917 gotoprobe = main_root;
1920 retop = dofindlabel(gotoprobe, label,
1921 enterops, enterops + GOTO_DEPTH);
1924 lastgotoprobe = gotoprobe;
1927 DIE("Can't find label %s", label);
1929 /* pop unwanted frames */
1931 if (ix < cxstack_ix) {
1938 oldsave = scopestack[scopestack_ix];
1939 LEAVE_SCOPE(oldsave);
1942 /* push wanted frames */
1944 if (*enterops && enterops[1]) {
1946 for (ix = 1; enterops[ix]; ix++) {
1948 /* Eventually we may want to stack the needed arguments
1949 * for each op. For now, we punt on the hard ones. */
1950 if (op->op_type == OP_ENTERITER)
1951 DIE("Can't \"goto\" into the middle of a foreach loop",
1953 (*op->op_ppaddr)(ARGS);
1961 if (!retop) retop = main_start;
1968 restartop = 0; /* hmm, must be GNU unexec().. */
1972 if (curstack == signalstack) {
1990 if (anum == 1 && VMSISH_EXIT)
2003 double value = SvNVx(GvSV(cCOP->cop_gv));
2004 register I32 match = I_32(value);
2007 if (((double)match) > value)
2008 --match; /* was fractional--truncate other way */
2010 match -= cCOP->uop.scop.scop_offset;
2013 else if (match > cCOP->uop.scop.scop_max)
2014 match = cCOP->uop.scop.scop_max;
2015 op = cCOP->uop.scop.scop_next[match];
2025 op = op->op_next; /* can't assume anything */
2027 match = *(SvPVx(GvSV(cCOP->cop_gv), na)) & 255;
2028 match -= cCOP->uop.scop.scop_offset;
2031 else if (match > cCOP->uop.scop.scop_max)
2032 match = cCOP->uop.scop.scop_max;
2033 op = cCOP->uop.scop.scop_next[match];
2042 save_lines(AV *array, SV *sv)
2044 register char *s = SvPVX(sv);
2045 register char *send = SvPVX(sv) + SvCUR(sv);
2047 register I32 line = 1;
2049 while (s && s < send) {
2050 SV *tmpstr = NEWSV(85,0);
2052 sv_upgrade(tmpstr, SVt_PVMG);
2053 t = strchr(s, '\n');
2059 sv_setpvn(tmpstr, s, t - s);
2060 av_store(array, line++, tmpstr);
2075 assert(CATCH_GET == TRUE);
2076 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
2080 default: /* topmost level handles it */
2087 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2103 sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2104 /* sv Text to convert to OP tree. */
2105 /* startop op_free() this to undo. */
2106 /* code Short string id of the caller. */
2108 dSP; /* Make POPBLOCK work. */
2111 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
2115 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2121 /* switch to eval mode */
2123 SAVESPTR(compiling.cop_filegv);
2124 SAVEI16(compiling.cop_line);
2125 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq);
2126 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2127 compiling.cop_line = 1;
2128 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2129 deleting the eval's FILEGV from the stash before gv_check() runs
2130 (i.e. before run-time proper). To work around the coredump that
2131 ensues, we always turn GvMULTI_on for any globals that were
2132 introduced within evals. See force_ident(). GSAR 96-10-12 */
2133 safestr = savepv(tmpbuf);
2134 SAVEDELETE(defstash, safestr, strlen(safestr));
2140 op->op_type = 0; /* Avoid uninit warning. */
2141 op->op_flags = 0; /* Avoid uninit warning. */
2142 PUSHBLOCK(cx, CXt_EVAL, SP);
2143 PUSHEVAL(cx, 0, compiling.cop_filegv);
2144 rop = doeval(G_SCALAR, startop);
2148 (*startop)->op_type = OP_NULL;
2149 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2151 *avp = (AV*)SvREFCNT_inc(comppad);
2156 /* With USE_THREADS, eval_owner must be held on entry to doeval */
2158 doeval(int gimme, OP** startop)
2170 /* set up a scratch pad */
2175 SAVESPTR(comppad_name);
2176 SAVEI32(comppad_name_fill);
2177 SAVEI32(min_intro_pending);
2178 SAVEI32(max_intro_pending);
2182 compcv = (CV*)NEWSV(1104,0);
2183 sv_upgrade((SV *)compcv, SVt_PVCV);
2184 CvUNIQUE_on(compcv);
2186 CvOWNER(compcv) = 0;
2187 New(666, CvMUTEXP(compcv), 1, perl_mutex);
2188 MUTEX_INIT(CvMUTEXP(compcv));
2189 #endif /* USE_THREADS */
2192 av_push(comppad, Nullsv);
2193 curpad = AvARRAY(comppad);
2194 comppad_name = newAV();
2195 comppad_name_fill = 0;
2196 min_intro_pending = 0;
2199 av_store(comppad_name, 0, newSVpv("@_", 2));
2200 curpad[0] = (SV*)newAV();
2201 SvPADMY_on(curpad[0]); /* XXX Needed? */
2202 #endif /* USE_THREADS */
2204 comppadlist = newAV();
2205 AvREAL_off(comppadlist);
2206 av_store(comppadlist, 0, (SV*)comppad_name);
2207 av_store(comppadlist, 1, (SV*)comppad);
2208 CvPADLIST(compcv) = comppadlist;
2210 if (!saveop || saveop->op_type != OP_REQUIRE)
2211 CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
2215 /* make sure we compile in the right package */
2217 newstash = curcop->cop_stash;
2218 if (curstash != newstash) {
2220 curstash = newstash;
2224 SAVEFREESV(beginav);
2226 /* try to compile it */
2230 curcop = &compiling;
2231 curcop->cop_arybase = 0;
2233 rs = newSVpv("\n", 1);
2234 if (saveop && saveop->op_flags & OPf_SPECIAL)
2238 if (yyparse() || error_count || !eval_root) {
2242 I32 optype = 0; /* Might be reset by POPEVAL. */
2249 SP = stack_base + POPMARK; /* pop original mark */
2257 if (optype == OP_REQUIRE) {
2258 char* msg = SvPVx(ERRSV, na);
2259 DIE("%s", *msg ? msg : "Compilation failed in require");
2260 } else if (startop) {
2261 char* msg = SvPVx(ERRSV, na);
2265 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
2268 rs = SvREFCNT_inc(nrs);
2270 MUTEX_LOCK(&eval_mutex);
2272 COND_SIGNAL(&eval_cond);
2273 MUTEX_UNLOCK(&eval_mutex);
2274 #endif /* USE_THREADS */
2278 rs = SvREFCNT_inc(nrs);
2279 compiling.cop_line = 0;
2281 *startop = eval_root;
2282 SvREFCNT_dec(CvOUTSIDE(compcv));
2283 CvOUTSIDE(compcv) = Nullcv;
2285 SAVEFREEOP(eval_root);
2287 scalarvoid(eval_root);
2288 else if (gimme & G_ARRAY)
2293 DEBUG_x(dump_eval());
2295 /* Register with debugger: */
2296 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2297 CV *cv = perl_get_cv("DB::postponed", FALSE);
2301 XPUSHs((SV*)compiling.cop_filegv);
2303 perl_call_sv((SV*)cv, G_DISCARD);
2307 /* compiled okay, so do it */
2309 CvDEPTH(compcv) = 1;
2310 SP = stack_base + POPMARK; /* pop original mark */
2311 op = saveop; /* The caller may need it. */
2313 MUTEX_LOCK(&eval_mutex);
2315 COND_SIGNAL(&eval_cond);
2316 MUTEX_UNLOCK(&eval_mutex);
2317 #endif /* USE_THREADS */
2319 RETURNOP(eval_start);
2325 register PERL_CONTEXT *cx;
2329 SV *namesv = Nullsv;
2331 I32 gimme = G_SCALAR;
2332 PerlIO *tryrsfp = 0;
2335 if (SvNIOKp(sv) && !SvPOKp(sv)) {
2336 SET_NUMERIC_STANDARD();
2337 if (atof(patchlevel) + 0.00000999 < SvNV(sv))
2338 DIE("Perl %s required--this is only version %s, stopped",
2339 SvPV(sv,na),patchlevel);
2342 name = SvPV(sv, na);
2344 DIE("Null filename used");
2345 TAINT_PROPER("require");
2346 if (op->op_type == OP_REQUIRE &&
2347 (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) &&
2351 /* prepare to compile file */
2356 (name[1] == '.' && name[2] == '/')))
2358 || (name[0] && name[1] == ':')
2361 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2364 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2365 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
2370 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
2373 AV *ar = GvAVn(incgv);
2377 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2380 namesv = NEWSV(806, 0);
2381 for (i = 0; i <= AvFILL(ar); i++) {
2382 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2385 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2387 sv_setpv(namesv, unixdir);
2388 sv_catpv(namesv, unixname);
2390 sv_setpvf(namesv, "%s/%s", dir, name);
2392 tryname = SvPVX(namesv);
2393 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
2395 if (tryname[0] == '.' && tryname[1] == '/')
2402 SAVESPTR(compiling.cop_filegv);
2403 compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
2404 SvREFCNT_dec(namesv);
2406 if (op->op_type == OP_REQUIRE) {
2407 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2408 SV *dirmsgsv = NEWSV(0, 0);
2409 AV *ar = GvAVn(incgv);
2411 if (instr(SvPVX(msg), ".h "))
2412 sv_catpv(msg, " (change .h to .ph maybe?)");
2413 if (instr(SvPVX(msg), ".ph "))
2414 sv_catpv(msg, " (did you run h2ph?)");
2415 sv_catpv(msg, " (@INC contains:");
2416 for (i = 0; i <= AvFILL(ar); i++) {
2417 char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
2418 sv_setpvf(dirmsgsv, " %s", dir);
2419 sv_catsv(msg, dirmsgsv);
2421 sv_catpvn(msg, ")", 1);
2422 SvREFCNT_dec(dirmsgsv);
2429 /* Assume success here to prevent recursive requirement. */
2430 (void)hv_store(GvHVn(incgv), name, strlen(name),
2431 newSVsv(GvSV(compiling.cop_filegv)), 0 );
2435 lex_start(sv_2mortal(newSVpv("",0)));
2437 save_aptr(&rsfp_filters);
2438 rsfp_filters = NULL;
2442 name = savepv(name);
2447 /* switch to eval mode */
2449 push_return(op->op_next);
2450 PUSHBLOCK(cx, CXt_EVAL, SP);
2451 PUSHEVAL(cx, name, compiling.cop_filegv);
2453 compiling.cop_line = 0;
2457 MUTEX_LOCK(&eval_mutex);
2458 if (eval_owner && eval_owner != thr)
2460 COND_WAIT(&eval_cond, &eval_mutex);
2462 MUTEX_UNLOCK(&eval_mutex);
2463 #endif /* USE_THREADS */
2464 return DOCATCH(doeval(G_SCALAR, NULL));
2469 return pp_require(ARGS);
2475 register PERL_CONTEXT *cx;
2477 I32 gimme = GIMME_V, was = sub_generation;
2478 char tmpbuf[TYPE_DIGITS(long) + 12];
2483 if (!SvPV(sv,len) || !len)
2485 TAINT_PROPER("eval");
2491 /* switch to eval mode */
2493 SAVESPTR(compiling.cop_filegv);
2494 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
2495 compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2496 compiling.cop_line = 1;
2497 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2498 deleting the eval's FILEGV from the stash before gv_check() runs
2499 (i.e. before run-time proper). To work around the coredump that
2500 ensues, we always turn GvMULTI_on for any globals that were
2501 introduced within evals. See force_ident(). GSAR 96-10-12 */
2502 safestr = savepv(tmpbuf);
2503 SAVEDELETE(defstash, safestr, strlen(safestr));
2505 hints = op->op_targ;
2507 push_return(op->op_next);
2508 PUSHBLOCK(cx, CXt_EVAL, SP);
2509 PUSHEVAL(cx, 0, compiling.cop_filegv);
2511 /* prepare to compile string */
2513 if (PERLDB_LINE && curstash != debstash)
2514 save_lines(GvAV(compiling.cop_filegv), linestr);
2517 MUTEX_LOCK(&eval_mutex);
2518 if (eval_owner && eval_owner != thr)
2520 COND_WAIT(&eval_cond, &eval_mutex);
2522 MUTEX_UNLOCK(&eval_mutex);
2523 #endif /* USE_THREADS */
2524 ret = doeval(gimme, NULL);
2525 if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
2526 && ret != op->op_next) { /* Successive compilation. */
2527 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2529 return DOCATCH(ret);
2539 register PERL_CONTEXT *cx;
2541 U8 save_flags = op -> op_flags;
2546 retop = pop_return();
2549 if (gimme == G_VOID)
2551 else if (gimme == G_SCALAR) {
2554 if (SvFLAGS(TOPs) & SVs_TEMP)
2557 *MARK = sv_mortalcopy(TOPs);
2565 /* in case LEAVE wipes old return values */
2566 for (mark = newsp + 1; mark <= SP; mark++) {
2567 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
2568 *mark = sv_mortalcopy(*mark);
2569 TAINT_NOT; /* Each item is independent */
2573 curpm = newpm; /* Don't pop $1 et al till now */
2576 * Closures mentioned at top level of eval cannot be referenced
2577 * again, and their presence indirectly causes a memory leak.
2578 * (Note that the fact that compcv and friends are still set here
2579 * is, AFAIK, an accident.) --Chip
2581 if (AvFILL(comppad_name) >= 0) {
2582 SV **svp = AvARRAY(comppad_name);
2584 for (ix = AvFILL(comppad_name); ix >= 0; ix--) {
2586 if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
2588 svp[ix] = &sv_undef;
2592 SvREFCNT_dec(CvOUTSIDE(sv));
2593 CvOUTSIDE(sv) = Nullcv;
2606 assert(CvDEPTH(compcv) == 1);
2608 CvDEPTH(compcv) = 0;
2610 if (optype == OP_REQUIRE &&
2611 !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp))
2613 /* Unassume the success we assumed earlier. */
2614 char *name = cx->blk_eval.old_name;
2615 (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
2616 retop = die("%s did not return a true value", name);
2622 if (!(save_flags & OPf_SPECIAL))
2631 register PERL_CONTEXT *cx;
2632 I32 gimme = GIMME_V;
2637 push_return(cLOGOP->op_other->op_next);
2638 PUSHBLOCK(cx, CXt_EVAL, SP);
2640 eval_root = op; /* Only needed so that goto works right. */
2645 return DOCATCH(op->op_next);
2655 register PERL_CONTEXT *cx;
2663 if (gimme == G_VOID)
2665 else if (gimme == G_SCALAR) {
2668 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2671 *MARK = sv_mortalcopy(TOPs);
2680 /* in case LEAVE wipes old return values */
2681 for (mark = newsp + 1; mark <= SP; mark++) {
2682 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
2683 *mark = sv_mortalcopy(*mark);
2684 TAINT_NOT; /* Each item is independent */
2688 curpm = newpm; /* Don't pop $1 et al till now */
2699 register char *s = SvPV_force(sv, len);
2700 register char *send = s + len;
2701 register char *base;
2702 register I32 skipspaces = 0;
2705 bool postspace = FALSE;
2713 croak("Null picture in formline");
2715 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
2720 *fpc++ = FF_LINEMARK;
2721 noblank = repeat = FALSE;
2739 case ' ': case '\t':
2750 *fpc++ = FF_LITERAL;
2758 *fpc++ = skipspaces;
2762 *fpc++ = FF_NEWLINE;
2766 arg = fpc - linepc + 1;
2773 *fpc++ = FF_LINEMARK;
2774 noblank = repeat = FALSE;
2783 ischop = s[-1] == '^';
2789 arg = (s - base) - 1;
2791 *fpc++ = FF_LITERAL;
2800 *fpc++ = FF_LINEGLOB;
2802 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
2803 arg = ischop ? 512 : 0;
2813 arg |= 256 + (s - f);
2815 *fpc++ = s - base; /* fieldsize for FETCH */
2816 *fpc++ = FF_DECIMAL;
2821 bool ismore = FALSE;
2824 while (*++s == '>') ;
2825 prespace = FF_SPACE;
2827 else if (*s == '|') {
2828 while (*++s == '|') ;
2829 prespace = FF_HALFSPACE;
2834 while (*++s == '<') ;
2837 if (*s == '.' && s[1] == '.' && s[2] == '.') {
2841 *fpc++ = s - base; /* fieldsize for FETCH */
2843 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
2861 { /* need to jump to the next word */
2863 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
2864 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
2865 s = SvPVX(sv) + SvCUR(sv) + z;
2867 Copy(fops, s, arg, U16);
2869 sv_magic(sv, Nullsv, 'f', Nullch, 0);
2874 * The rest of this file was derived from source code contributed
2877 * NOTE: this code was derived from Tom Horsley's qsort replacement
2878 * and should not be confused with the original code.
2881 /* Copyright (C) Tom Horsley, 1997. All rights reserved.
2883 Permission granted to distribute under the same terms as perl which are
2886 This program is free software; you can redistribute it and/or modify
2887 it under the terms of either:
2889 a) the GNU General Public License as published by the Free
2890 Software Foundation; either version 1, or (at your option) any
2893 b) the "Artistic License" which comes with this Kit.
2895 Details on the perl license can be found in the perl source code which
2896 may be located via the www.perl.com web page.
2898 This is the most wonderfulest possible qsort I can come up with (and
2899 still be mostly portable) My (limited) tests indicate it consistently
2900 does about 20% fewer calls to compare than does the qsort in the Visual
2901 C++ library, other vendors may vary.
2903 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
2904 others I invented myself (or more likely re-invented since they seemed
2905 pretty obvious once I watched the algorithm operate for a while).
2907 Most of this code was written while watching the Marlins sweep the Giants
2908 in the 1997 National League Playoffs - no Braves fans allowed to use this
2909 code (just kidding :-).
2911 I realize that if I wanted to be true to the perl tradition, the only
2912 comment in this file would be something like:
2914 ...they shuffled back towards the rear of the line. 'No, not at the
2915 rear!' the slave-driver shouted. 'Three files up. And stay there...
2917 However, I really needed to violate that tradition just so I could keep
2918 track of what happens myself, not to mention some poor fool trying to
2919 understand this years from now :-).
2922 /* ********************************************************** Configuration */
2924 #ifndef QSORT_ORDER_GUESS
2925 #define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
2928 /* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
2929 future processing - a good max upper bound is log base 2 of memory size
2930 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
2931 safely be smaller than that since the program is taking up some space and
2932 most operating systems only let you grab some subset of contiguous
2933 memory (not to mention that you are normally sorting data larger than
2934 1 byte element size :-).
2936 #ifndef QSORT_MAX_STACK
2937 #define QSORT_MAX_STACK 32
2940 /* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
2941 Anything bigger and we use qsort. If you make this too small, the qsort
2942 will probably break (or become less efficient), because it doesn't expect
2943 the middle element of a partition to be the same as the right or left -
2944 you have been warned).
2946 #ifndef QSORT_BREAK_EVEN
2947 #define QSORT_BREAK_EVEN 6
2950 /* ************************************************************* Data Types */
2952 /* hold left and right index values of a partition waiting to be sorted (the
2953 partition includes both left and right - right is NOT one past the end or
2954 anything like that).
2956 struct partition_stack_entry {
2959 #ifdef QSORT_ORDER_GUESS
2960 int qsort_break_even;
2964 /* ******************************************************* Shorthand Macros */
2966 /* Note that these macros will be used from inside the qsort function where
2967 we happen to know that the variable 'elt_size' contains the size of an
2968 array element and the variable 'temp' points to enough space to hold a
2969 temp element and the variable 'array' points to the array being sorted
2970 and 'compare' is the pointer to the compare routine.
2972 Also note that there are very many highly architecture specific ways
2973 these might be sped up, but this is simply the most generally portable
2974 code I could think of.
2977 /* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
2979 #define qsort_cmp(elt1, elt2) \
2980 ((*compare)(array[elt1], array[elt2]))
2982 #ifdef QSORT_ORDER_GUESS
2983 #define QSORT_NOTICE_SWAP swapped++;
2985 #define QSORT_NOTICE_SWAP
2988 /* swaps contents of array elements elt1, elt2.
2990 #define qsort_swap(elt1, elt2) \
2993 temp = array[elt1]; \
2994 array[elt1] = array[elt2]; \
2995 array[elt2] = temp; \
2998 /* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
2999 elt3 and elt3 gets elt1.
3001 #define qsort_rotate(elt1, elt2, elt3) \
3004 temp = array[elt1]; \
3005 array[elt1] = array[elt2]; \
3006 array[elt2] = array[elt3]; \
3007 array[elt3] = temp; \
3010 /* ************************************************************ Debug stuff */
3017 return; /* good place to set a breakpoint */
3020 #define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3023 doqsort_all_asserts(
3027 int (*compare)(const void * elt1, const void * elt2),
3028 int pc_left, int pc_right, int u_left, int u_right)
3032 qsort_assert(pc_left <= pc_right);
3033 qsort_assert(u_right < pc_left);
3034 qsort_assert(pc_right < u_left);
3035 for (i = u_right + 1; i < pc_left; ++i) {
3036 qsort_assert(qsort_cmp(i, pc_left) < 0);
3038 for (i = pc_left; i < pc_right; ++i) {
3039 qsort_assert(qsort_cmp(i, pc_right) == 0);
3041 for (i = pc_right + 1; i < u_left; ++i) {
3042 qsort_assert(qsort_cmp(pc_right, i) < 0);
3046 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3047 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3048 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3052 #define qsort_assert(t) ((void)0)
3054 #define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3058 /* ****************************************************************** qsort */
3064 I32 (*compare)(SV *a, SV *b))
3068 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3069 int next_stack_entry = 0;
3073 #ifdef QSORT_ORDER_GUESS
3074 int qsort_break_even;
3078 /* Make sure we actually have work to do.
3080 if (num_elts <= 1) {
3084 /* Setup the initial partition definition and fall into the sorting loop
3087 part_right = (int)(num_elts - 1);
3088 #ifdef QSORT_ORDER_GUESS
3089 qsort_break_even = QSORT_BREAK_EVEN;
3091 #define qsort_break_even QSORT_BREAK_EVEN
3094 if ((part_right - part_left) >= qsort_break_even) {
3095 /* OK, this is gonna get hairy, so lets try to document all the
3096 concepts and abbreviations and variables and what they keep
3099 pc: pivot chunk - the set of array elements we accumulate in the
3100 middle of the partition, all equal in value to the original
3101 pivot element selected. The pc is defined by:
3103 pc_left - the leftmost array index of the pc
3104 pc_right - the rightmost array index of the pc
3106 we start with pc_left == pc_right and only one element
3107 in the pivot chunk (but it can grow during the scan).
3109 u: uncompared elements - the set of elements in the partition
3110 we have not yet compared to the pivot value. There are two
3111 uncompared sets during the scan - one to the left of the pc
3112 and one to the right.
3114 u_right - the rightmost index of the left side's uncompared set
3115 u_left - the leftmost index of the right side's uncompared set
3117 The leftmost index of the left sides's uncompared set
3118 doesn't need its own variable because it is always defined
3119 by the leftmost edge of the whole partition (part_left). The
3120 same goes for the rightmost edge of the right partition
3123 We know there are no uncompared elements on the left once we
3124 get u_right < part_left and no uncompared elements on the
3125 right once u_left > part_right. When both these conditions
3126 are met, we have completed the scan of the partition.
3128 Any elements which are between the pivot chunk and the
3129 uncompared elements should be less than the pivot value on
3130 the left side and greater than the pivot value on the right
3131 side (in fact, the goal of the whole algorithm is to arrange
3132 for that to be true and make the groups of less-than and
3133 greater-then elements into new partitions to sort again).
3135 As you marvel at the complexity of the code and wonder why it
3136 has to be so confusing. Consider some of the things this level
3137 of confusion brings:
3139 Once I do a compare, I squeeze every ounce of juice out of it. I
3140 never do compare calls I don't have to do, and I certainly never
3143 I also never swap any elements unless I can prove there is a
3144 good reason. Many sort algorithms will swap a known value with
3145 an uncompared value just to get things in the right place (or
3146 avoid complexity :-), but that uncompared value, once it gets
3147 compared, may then have to be swapped again. A lot of the
3148 complexity of this code is due to the fact that it never swaps
3149 anything except compared values, and it only swaps them when the
3150 compare shows they are out of position.
3152 int pc_left, pc_right;
3153 int u_right, u_left;
3157 pc_left = ((part_left + part_right) / 2);
3159 u_right = pc_left - 1;
3160 u_left = pc_right + 1;
3162 /* Qsort works best when the pivot value is also the median value
3163 in the partition (unfortunately you can't find the median value
3164 without first sorting :-), so to give the algorithm a helping
3165 hand, we pick 3 elements and sort them and use the median value
3166 of that tiny set as the pivot value.
3168 Some versions of qsort like to use the left middle and right as
3169 the 3 elements to sort so they can insure the ends of the
3170 partition will contain values which will stop the scan in the
3171 compare loop, but when you have to call an arbitrarily complex
3172 routine to do a compare, its really better to just keep track of
3173 array index values to know when you hit the edge of the
3174 partition and avoid the extra compare. An even better reason to
3175 avoid using a compare call is the fact that you can drop off the
3176 edge of the array if someone foolishly provides you with an
3177 unstable compare function that doesn't always provide consistent
3180 So, since it is simpler for us to compare the three adjacent
3181 elements in the middle of the partition, those are the ones we
3182 pick here (conveniently pointed at by u_right, pc_left, and
3183 u_left). The values of the left, center, and right elements
3184 are refered to as l c and r in the following comments.
3187 #ifdef QSORT_ORDER_GUESS
3190 s = qsort_cmp(u_right, pc_left);
3193 s = qsort_cmp(pc_left, u_left);
3194 /* if l < c, c < r - already in order - nothing to do */
3196 /* l < c, c == r - already in order, pc grows */
3198 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3200 /* l < c, c > r - need to know more */
3201 s = qsort_cmp(u_right, u_left);
3203 /* l < c, c > r, l < r - swap c & r to get ordered */
3204 qsort_swap(pc_left, u_left);
3205 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3206 } else if (s == 0) {
3207 /* l < c, c > r, l == r - swap c&r, grow pc */
3208 qsort_swap(pc_left, u_left);
3210 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3212 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3213 qsort_rotate(pc_left, u_right, u_left);
3214 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3217 } else if (s == 0) {
3219 s = qsort_cmp(pc_left, u_left);
3221 /* l == c, c < r - already in order, grow pc */
3223 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3224 } else if (s == 0) {
3225 /* l == c, c == r - already in order, grow pc both ways */
3228 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3230 /* l == c, c > r - swap l & r, grow pc */
3231 qsort_swap(u_right, u_left);
3233 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3237 s = qsort_cmp(pc_left, u_left);
3239 /* l > c, c < r - need to know more */
3240 s = qsort_cmp(u_right, u_left);
3242 /* l > c, c < r, l < r - swap l & c to get ordered */
3243 qsort_swap(u_right, pc_left);
3244 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3245 } else if (s == 0) {
3246 /* l > c, c < r, l == r - swap l & c, grow pc */
3247 qsort_swap(u_right, pc_left);
3249 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3251 /* l > c, c < r, l > r - rotate lcr into crl to order */
3252 qsort_rotate(u_right, pc_left, u_left);
3253 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3255 } else if (s == 0) {
3256 /* l > c, c == r - swap ends, grow pc */
3257 qsort_swap(u_right, u_left);
3259 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3261 /* l > c, c > r - swap ends to get in order */
3262 qsort_swap(u_right, u_left);
3263 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3266 /* We now know the 3 middle elements have been compared and
3267 arranged in the desired order, so we can shrink the uncompared
3272 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3274 /* The above massive nested if was the simple part :-). We now have
3275 the middle 3 elements ordered and we need to scan through the
3276 uncompared sets on either side, swapping elements that are on
3277 the wrong side or simply shuffling equal elements around to get
3278 all equal elements into the pivot chunk.
3282 int still_work_on_left;
3283 int still_work_on_right;
3285 /* Scan the uncompared values on the left. If I find a value
3286 equal to the pivot value, move it over so it is adjacent to
3287 the pivot chunk and expand the pivot chunk. If I find a value
3288 less than the pivot value, then just leave it - its already
3289 on the correct side of the partition. If I find a greater
3290 value, then stop the scan.
3292 while (still_work_on_left = (u_right >= part_left)) {
3293 s = qsort_cmp(u_right, pc_left);
3296 } else if (s == 0) {
3298 if (pc_left != u_right) {
3299 qsort_swap(u_right, pc_left);
3305 qsort_assert(u_right < pc_left);
3306 qsort_assert(pc_left <= pc_right);
3307 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3308 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3311 /* Do a mirror image scan of uncompared values on the right
3313 while (still_work_on_right = (u_left <= part_right)) {
3314 s = qsort_cmp(pc_right, u_left);
3317 } else if (s == 0) {
3319 if (pc_right != u_left) {
3320 qsort_swap(pc_right, u_left);
3326 qsort_assert(u_left > pc_right);
3327 qsort_assert(pc_left <= pc_right);
3328 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3329 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3332 if (still_work_on_left) {
3333 /* I know I have a value on the left side which needs to be
3334 on the right side, but I need to know more to decide
3335 exactly the best thing to do with it.
3337 if (still_work_on_right) {
3338 /* I know I have values on both side which are out of
3339 position. This is a big win because I kill two birds
3340 with one swap (so to speak). I can advance the
3341 uncompared pointers on both sides after swapping both
3342 of them into the right place.
3344 qsort_swap(u_right, u_left);
3347 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3349 /* I have an out of position value on the left, but the
3350 right is fully scanned, so I "slide" the pivot chunk
3351 and any less-than values left one to make room for the
3352 greater value over on the right. If the out of position
3353 value is immediately adjacent to the pivot chunk (there
3354 are no less-than values), I can do that with a swap,
3355 otherwise, I have to rotate one of the less than values
3356 into the former position of the out of position value
3357 and the right end of the pivot chunk into the left end
3361 if (pc_left == u_right) {
3362 qsort_swap(u_right, pc_right);
3363 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3365 qsort_rotate(u_right, pc_left, pc_right);
3366 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3371 } else if (still_work_on_right) {
3372 /* Mirror image of complex case above: I have an out of
3373 position value on the right, but the left is fully
3374 scanned, so I need to shuffle things around to make room
3375 for the right value on the left.
3378 if (pc_right == u_left) {
3379 qsort_swap(u_left, pc_left);
3380 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3382 qsort_rotate(pc_right, pc_left, u_left);
3383 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3388 /* No more scanning required on either side of partition,
3389 break out of loop and figure out next set of partitions
3395 /* The elements in the pivot chunk are now in the right place. They
3396 will never move or be compared again. All I have to do is decide
3397 what to do with the stuff to the left and right of the pivot
3400 Notes on the QSORT_ORDER_GUESS ifdef code:
3402 1. If I just built these partitions without swapping any (or
3403 very many) elements, there is a chance that the elements are
3404 already ordered properly (being properly ordered will
3405 certainly result in no swapping, but the converse can't be
3408 2. A (properly written) insertion sort will run faster on
3409 already ordered data than qsort will.
3411 3. Perhaps there is some way to make a good guess about
3412 switching to an insertion sort earlier than partition size 6
3413 (for instance - we could save the partition size on the stack
3414 and increase the size each time we find we didn't swap, thus
3415 switching to insertion sort earlier for partitions with a
3416 history of not swapping).
3418 4. Naturally, if I just switch right away, it will make
3419 artificial benchmarks with pure ascending (or descending)
3420 data look really good, but is that a good reason in general?
3424 #ifdef QSORT_ORDER_GUESS
3426 #if QSORT_ORDER_GUESS == 1
3427 qsort_break_even = (part_right - part_left) + 1;
3429 #if QSORT_ORDER_GUESS == 2
3430 qsort_break_even *= 2;
3432 #if QSORT_ORDER_GUESS == 3
3433 int prev_break = qsort_break_even;
3434 qsort_break_even *= qsort_break_even;
3435 if (qsort_break_even < prev_break) {
3436 qsort_break_even = (part_right - part_left) + 1;
3440 qsort_break_even = QSORT_BREAK_EVEN;
3444 if (part_left < pc_left) {
3445 /* There are elements on the left which need more processing.
3446 Check the right as well before deciding what to do.
3448 if (pc_right < part_right) {
3449 /* We have two partitions to be sorted. Stack the biggest one
3450 and process the smallest one on the next iteration. This
3451 minimizes the stack height by insuring that any additional
3452 stack entries must come from the smallest partition which
3453 (because it is smallest) will have the fewest
3454 opportunities to generate additional stack entries.
3456 if ((part_right - pc_right) > (pc_left - part_left)) {
3457 /* stack the right partition, process the left */
3458 partition_stack[next_stack_entry].left = pc_right + 1;
3459 partition_stack[next_stack_entry].right = part_right;
3460 #ifdef QSORT_ORDER_GUESS
3461 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3463 part_right = pc_left - 1;
3465 /* stack the left partition, process the right */
3466 partition_stack[next_stack_entry].left = part_left;
3467 partition_stack[next_stack_entry].right = pc_left - 1;
3468 #ifdef QSORT_ORDER_GUESS
3469 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3471 part_left = pc_right + 1;
3473 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3476 /* The elements on the left are the only remaining elements
3477 that need sorting, arrange for them to be processed as the
3480 part_right = pc_left - 1;
3482 } else if (pc_right < part_right) {
3483 /* There is only one chunk on the right to be sorted, make it
3484 the new partition and loop back around.
3486 part_left = pc_right + 1;
3488 /* This whole partition wound up in the pivot chunk, so
3489 we need to get a new partition off the stack.
3491 if (next_stack_entry == 0) {
3492 /* the stack is empty - we are done */
3496 part_left = partition_stack[next_stack_entry].left;
3497 part_right = partition_stack[next_stack_entry].right;
3498 #ifdef QSORT_ORDER_GUESS
3499 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3503 /* This partition is too small to fool with qsort complexity, just
3504 do an ordinary insertion sort to minimize overhead.
3507 /* Assume 1st element is in right place already, and start checking
3508 at 2nd element to see where it should be inserted.
3510 for (i = part_left + 1; i <= part_right; ++i) {
3512 /* Scan (backwards - just in case 'i' is already in right place)
3513 through the elements already sorted to see if the ith element
3514 belongs ahead of one of them.
3516 for (j = i - 1; j >= part_left; --j) {
3517 if (qsort_cmp(i, j) >= 0) {
3518 /* i belongs right after j
3525 /* Looks like we really need to move some things
3528 for (--i; i >= j; --i)
3529 array[i + 1] = array[i];
3534 /* That partition is now sorted, grab the next one, or get out
3535 of the loop if there aren't any more.
3538 if (next_stack_entry == 0) {
3539 /* the stack is empty - we are done */
3543 part_left = partition_stack[next_stack_entry].left;
3544 part_right = partition_stack[next_stack_entry].right;
3545 #ifdef QSORT_ORDER_GUESS
3546 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3551 /* Believe it or not, the array is sorted at this point! */