X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/af702f0e61214b54e323d12ffeaff4e64bee707c..ef6cdfd2324258dbd7407fe0d1d6f2386b953d5a:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index fbb8ac5..1209f7c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -25,8 +25,11 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#ifdef PERL_OBJECT +#define CALLOP this->*op +#else +#define CALLOP *op static OP *docatch _((OP *o)); -static OP *doeval _((int gimme)); static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); static I32 dopoptoeval _((I32 startingblock)); @@ -34,15 +37,14 @@ static I32 dopoptolabel _((char *label)); static I32 dopoptoloop _((I32 startingblock)); static I32 dopoptosub _((I32 startingblock)); static void save_lines _((AV *array, SV *sv)); -static int sortcv _((const void *, const void *)); -static int sortcmp _((const void *, const void *)); -static int sortcmp_locale _((const void *, const void *)); - -static I32 sortcxix; +static I32 sortcv _((SV *a, SV *b)); +static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); +static OP *doeval _((int gimme, OP** startop)); +#endif PP(pp_wantarray) { - dSP; + djSP; I32 cxix; EXTEND(SP, 1); @@ -66,26 +68,40 @@ PP(pp_regcmaybe) } PP(pp_regcomp) { - dSP; + djSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; register char *t; SV *tmpstr; STRLEN len; + MAGIC *mg = Null(MAGIC*); tmpstr = POPs; - t = SvPV(tmpstr, len); - - /* JMR: Check against the last compiled regexp */ - if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp - || strnNE(pm->op_pmregexp->precomp, t, len) - || pm->op_pmregexp->precomp[len]) { - if (pm->op_pmregexp) { - pregfree(pm->op_pmregexp); - pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ - } + if(SvROK(tmpstr)) { + SV *sv = SvRV(tmpstr); + if(SvMAGICAL(sv)) + mg = mg_find(sv, 'r'); + } + if(mg) { + regexp *re = (regexp *)mg->mg_obj; + ReREFCNT_dec(pm->op_pmregexp); + pm->op_pmregexp = ReREFCNT_inc(re); + } + else { + t = SvPV(tmpstr, len); + + /* Check against the last compiled regexp. */ + if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || + pm->op_pmregexp->prelen != len || + memNE(pm->op_pmregexp->precomp, t, len)) + { + if (pm->op_pmregexp) { + ReREFCNT_dec(pm->op_pmregexp); + pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ + } - pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ - pm->op_pmregexp = pregcomp(t, t + len, pm); + pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ + pm->op_pmregexp = pregcomp(t, t + len, pm); + } } if (!pm->op_pmregexp->prelen && curpm) @@ -95,7 +111,6 @@ PP(pp_regcomp) { if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ - hoistmust(pm); cLOGOP->op_first->op_next = op->op_next; } RETURN; @@ -103,9 +118,9 @@ PP(pp_regcomp) { PP(pp_substcont) { - dSP; + djSP; register PMOP *pm = (PMOP*) cLOGOP->op_other; - register CONTEXT *cx = &cxstack[cxstack_ix]; + register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register SV *dstr = cx->sb_dstr; register char *s = cx->sb_s; register char *m = cx->sb_m; @@ -118,18 +133,20 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); - if (!cx->sb_rxtainted) - cx->sb_rxtainted = SvTAINTED(TOPs); + if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) + cx->sb_rxtainted |= 2; sv_catsv(dstr, POPs); /* Are we done */ - if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig, - s == m, Nullsv, cx->sb_safebase)) + if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig, + s == m, Nullsv, NULL, + cx->sb_safebase ? 0 : REXEC_COPY_STR)) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); - TAINT_IF(cx->sb_rxtainted || rx->exec_tainted); + TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx)); + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); (void)SvOOK_off(targ); Safefree(SvPVX(targ)); @@ -138,11 +155,15 @@ PP(pp_substcont) SvLEN_set(targ, SvLEN(dstr)); SvPVX(dstr) = 0; sv_free(dstr); + + TAINT_IF(cx->sb_rxtainted & 1); + PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + (void)SvPOK_only(targ); + TAINT_IF(cx->sb_rxtainted); SvSETMAGIC(targ); SvTAINT(targ); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); @@ -158,7 +179,7 @@ PP(pp_substcont) cx->sb_m = m = rx->startp[0]; sv_catpvn(dstr, s, m-s); cx->sb_s = rx->endp[0]; - cx->sb_rxtainted |= rx->exec_tainted; + cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); } @@ -225,8 +246,8 @@ rxres_free(void **rsp) PP(pp_formline) { - dSP; dMARK; dORIGMARK; - register SV *form = *++MARK; + djSP; dMARK; dORIGMARK; + register SV *tmpForm = *++MARK; register U16 *fpc; register char *t; register char *f; @@ -245,17 +266,17 @@ PP(pp_formline) bool gotsome; STRLEN len; - if (!SvMAGICAL(form) || !SvCOMPILED(form)) { - SvREADONLY_off(form); - doparseform(form); + if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { + SvREADONLY_off(tmpForm); + doparseform(tmpForm); } SvPV_force(formtarget, len); - t = SvGROW(formtarget, len + SvCUR(form) + 1); /* XXX SvCUR bad */ + t = SvGROW(formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */ t += len; - f = SvPV(form, len); + f = SvPV(tmpForm, len); /* need to jump to the next word */ - s = f + len + WORD_ALIGN - SvCUR(form) % WORD_ALIGN; + s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN; fpc = (U16*)s; @@ -430,7 +451,7 @@ PP(pp_formline) } SvCUR_set(formtarget, t - SvPVX(formtarget)); sv_catpvn(formtarget, item, itemsize); - SvGROW(formtarget, SvCUR(formtarget) + SvCUR(form) + 1); + SvGROW(formtarget, SvCUR(formtarget) + SvCUR(tmpForm) + 1); t = SvPVX(formtarget) + SvCUR(formtarget); } break; @@ -518,10 +539,10 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + djSP; SV *src; - if (stack_base + *markstack_ptr == sp) { + if (stack_base + *markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) XPUSHs(&sv_no); @@ -533,14 +554,18 @@ PP(pp_grepstart) ENTER; /* enter outer scope */ SAVETMPS; +#ifdef USE_THREADS + /* SAVE_DEFSV does *not* suffice here */ + save_sptr(&THREADSV(0)); +#else SAVESPTR(GvSV(defgv)); - +#endif /* USE_THREADS */ ENTER; /* enter inner scope */ SAVESPTR(curpm); src = stack_base[*markstack_ptr]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; PUTBACK; if (op->op_type == OP_MAPSTART) @@ -555,8 +580,8 @@ PP(pp_mapstart) PP(pp_mapwhile) { - dSP; - I32 diff = (sp - stack_base) - *markstack_ptr; + djSP; + I32 diff = (SP - stack_base) - *markstack_ptr; I32 count; I32 shift; SV** src; @@ -566,11 +591,11 @@ PP(pp_mapwhile) if (diff) { if (diff > markstack_ptr[-1] - markstack_ptr[-2]) { shift = diff - (markstack_ptr[-1] - markstack_ptr[-2]); - count = (sp - stack_base) - markstack_ptr[-1] + 2; + count = (SP - stack_base) - markstack_ptr[-1] + 2; - EXTEND(sp,shift); - src = sp; - dst = (sp += shift); + EXTEND(SP,shift); + src = SP; + dst = (SP += shift); markstack_ptr[-1] += shift; *markstack_ptr += shift; while (--count) @@ -610,16 +635,15 @@ PP(pp_mapwhile) src = stack_base[markstack_ptr[-1]]; SvTEMP_off(src); - GvSV(defgv) = src; + DEFSV = src; RETURNOP(cLOGOP->op_other); } } - PP(pp_sort) { - dSP; dMARK; dORIGMARK; + djSP; dMARK; dORIGMARK; register SV **up; SV **myorigmark = ORIGMARK; register I32 max; @@ -634,8 +658,9 @@ PP(pp_sort) RETPUSHUNDEF; } + ENTER; + SAVEPPTR(sortcop); if (op->op_flags & OPf_STACKED) { - ENTER; if (op->op_flags & OPf_SPECIAL) { OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */ kid = kUNOP->op_first; /* pass rv2gv */ @@ -687,22 +712,15 @@ PP(pp_sort) max = --up - myorigmark; if (sortcop) { if (max > 1) { - AV *oldstack; - CONTEXT *cx; + PERL_CONTEXT *cx; SV** newsp; bool oldcatch = CATCH_GET; SAVETMPS; SAVEOP(); - oldstack = curstack; - if (!sortstack) { - sortstack = newAV(); - AvREAL_off(sortstack); - av_extend(sortstack, 32); - } CATCH_SET(TRUE); - SWITCHSTACK(curstack, sortstack); + PUSHSTACK(SI_SORT); if (sortstash != stash) { firstgv = gv_fetchpv("a", TRUE, SVt_PV); secondgv = gv_fetchpv("b", TRUE, SVt_PV); @@ -722,22 +740,23 @@ PP(pp_sort) (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */ } sortcxix = cxstack_ix; - - qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv); + qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv)); POPBLOCK(cx,curpm); - SWITCHSTACK(sortstack, oldstack); + POPSTACK(); CATCH_SET(oldcatch); } - LEAVE; } else { if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), - (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp); + qsortsv(ORIGMARK+1, max, + (op->op_private & OPpLOCALE) + ? FUNC_NAME_TO_PTR(sv_cmp_locale) + : FUNC_NAME_TO_PTR(sv_cmp)); } } + LEAVE; stack_sp = ORIGMARK + max; return nextop; } @@ -753,7 +772,7 @@ PP(pp_range) PP(pp_flip) { - dSP; + djSP; if (GIMME == G_ARRAY) { RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); @@ -773,7 +792,7 @@ PP(pp_flip) } else { sv_setiv(targ, 0); - sp--; + SP--; RETURNOP(((CONDOP*)cUNOP->op_first)->op_false); } } @@ -785,7 +804,7 @@ PP(pp_flip) PP(pp_flop) { - dSP; + djSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; @@ -841,12 +860,12 @@ PP(pp_flop) /* Control. */ -static I32 +STATIC I32 dopoptolabel(char *label) { dTHR; register I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = cxstack_ix; i >= 0; i--) { cx = &cxstack[i]; @@ -907,15 +926,17 @@ block_gimme(void) return G_ARRAY; default: croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme); + /* NOTREACHED */ + return 0; } } -static I32 +STATIC I32 dopoptosub(I32 startingblock) { dTHR; I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; switch (cx->cx_type) { @@ -930,12 +951,12 @@ dopoptosub(I32 startingblock) return i; } -static I32 +STATIC I32 dopoptoeval(I32 startingblock) { dTHR; I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; switch (cx->cx_type) { @@ -949,12 +970,12 @@ dopoptoeval(I32 startingblock) return i; } -static I32 +STATIC I32 dopoptoloop(I32 startingblock) { dTHR; I32 i; - register CONTEXT *cx; + register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { cx = &cxstack[i]; switch (cx->cx_type) { @@ -986,14 +1007,14 @@ void dounwind(I32 cxix) { dTHR; - register CONTEXT *cx; + register PERL_CONTEXT *cx; SV **newsp; I32 optype; while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix]; DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", - (long) cxstack_ix+1, block_type[cx->cx_type])); + (long) cxstack_ix, block_type[cx->cx_type])); /* Note: we don't need to restore the base context info till the end. */ switch (cx->cx_type) { case CXt_SUBST: @@ -1018,34 +1039,45 @@ dounwind(I32 cxix) OP * die_where(char *message) { - dTHR; + dSP; if (in_eval) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme; SV **newsp; - if (in_eval & 4) { - SV **svp; - STRLEN klen = strlen(message); - - svp = hv_fetch(errhv, message, klen, TRUE); - if (svp) { - if (!SvIOK(*svp)) { - static char prefix[] = "\t(in cleanup) "; - sv_upgrade(*svp, SVt_IV); - (void)SvIOK_only(*svp); - SvGROW(errsv, SvCUR(errsv)+sizeof(prefix)+klen); - sv_catpvn(errsv, prefix, sizeof(prefix)-1); - sv_catpvn(errsv, message, klen); + if (message) { + if (in_eval & 4) { + SV **svp; + STRLEN klen = strlen(message); + + svp = hv_fetch(ERRHV, message, klen, TRUE); + if (svp) { + if (!SvIOK(*svp)) { + static char prefix[] = "\t(in cleanup) "; + SV *err = ERRSV; + sv_upgrade(*svp, SVt_IV); + (void)SvIOK_only(*svp); + if (!SvPOK(err)) + sv_setpv(err,""); + SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); + sv_catpvn(err, prefix, sizeof(prefix)-1); + sv_catpvn(err, message, klen); + } + sv_inc(*svp); } - sv_inc(*svp); } + else + sv_setpv(ERRSV, message); } else - sv_setpv(errsv, message); - - cxix = dopoptoeval(cxstack_ix); + message = SvPVx(ERRSV, na); + + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && curstackinfo->si_prev) { + dounwind(-1); + POPSTACK(); + } + if (cxix >= 0) { I32 optype; @@ -1066,7 +1098,7 @@ die_where(char *message) LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPV(errsv, na); + char* msg = SvPVx(ERRSV, na); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); @@ -1081,7 +1113,7 @@ die_where(char *message) PP(pp_xor) { - dSP; dPOPTOPssrl; + djSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else @@ -1090,7 +1122,7 @@ PP(pp_xor) PP(pp_andassign) { - dSP; + djSP; if (!SvTRUE(TOPs)) RETURN; else @@ -1099,35 +1131,21 @@ PP(pp_andassign) PP(pp_orassign) { - dSP; + djSP; if (SvTRUE(TOPs)) RETURN; else RETURNOP(cLOGOP->op_other); } -#ifdef DEPRECATED -PP(pp_entersubr) -{ - dSP; - SV** mark = (stack_base + *markstack_ptr + 1); - SV* cv = *mark; - while (mark < sp) { /* emulate old interface */ - *mark = mark[1]; - mark++; - } - *sp = cv; - return pp_entersub(ARGS); -} -#endif - PP(pp_caller) { - dSP; + djSP; register I32 cxix = dopoptosub(cxstack_ix); - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 dbcxix; I32 gimme; + HV *hv; SV *sv; I32 count = 0; @@ -1157,14 +1175,22 @@ PP(pp_caller) } if (GIMME != G_ARRAY) { - dTARGET; - - sv_setpv(TARG, HvNAME(cx->blk_oldcop->cop_stash)); - PUSHs(TARG); + hv = cx->blk_oldcop->cop_stash; + if (!hv) + PUSHs(&sv_undef); + else { + dTARGET; + sv_setpv(TARG, HvNAME(hv)); + PUSHs(TARG); + } RETURN; } - PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0))); + hv = cx->blk_oldcop->cop_stash; + if (!hv) + PUSHs(&sv_undef); + else + PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0))); PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) @@ -1210,28 +1236,26 @@ PP(pp_caller) AvREAL_off(dbargs); /* XXX Should be REIFY */ } - if (AvMAX(dbargs) < AvFILL(ary) + off) - av_extend(dbargs, AvFILL(ary) + off); - Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILL(ary) + 1 + off, SV*); - AvFILL(dbargs) = AvFILL(ary) + off; + if (AvMAX(dbargs) < AvFILLp(ary) + off) + av_extend(dbargs, AvFILLp(ary) + off); + Copy(AvALLOC(ary), AvARRAY(dbargs), AvFILLp(ary) + 1 + off, SV*); + AvFILLp(dbargs) = AvFILLp(ary) + off; } RETURN; } -static int -sortcv(const void *a, const void *b) +STATIC I32 +sortcv(SV *a, SV *b) { dTHR; - SV * const *str1 = (SV * const *)a; - SV * const *str2 = (SV * const *)b; I32 oldsaveix = savestack_ix; I32 oldscopeix = scopestack_ix; I32 result; - GvSV(firstgv) = *str1; - GvSV(secondgv) = *str2; + GvSV(firstgv) = a; + GvSV(secondgv) = b; stack_sp = stack_base; op = sortcop; - runops(); + CALLRUNOPS(); if (stack_sp != stack_base + 1) croak("Sort subroutine didn't return single value"); if (!SvNIOKp(*stack_sp)) @@ -1244,21 +1268,9 @@ sortcv(const void *a, const void *b) return result; } -static int -sortcmp(const void *a, const void *b) -{ - return sv_cmp(*(SV * const *)a, *(SV * const *)b); -} - -static int -sortcmp_locale(const void *a, const void *b) -{ - return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b); -} - PP(pp_reset) { - dSP; + djSP; char *tmps; if (MAXARG < 1) @@ -1284,9 +1296,9 @@ PP(pp_dbstate) if (op->op_private || SvIV(DBsingle) || SvIV(DBsignal) || SvIV(DBtrace)) { - SV **sp; + djSP; register CV *cv; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme = G_ARRAY; I32 hasargs; GV *gv; @@ -1306,10 +1318,10 @@ PP(pp_dbstate) SAVESTACK_POS(); debug = 0; hasargs = 0; - sp = stack_sp; + SPAGAIN; push_return(op->op_next); - PUSHBLOCK(cx, CXt_SUB, sp); + PUSHBLOCK(cx, CXt_SUB, SP); PUSHSUB(cx); CvDEPTH(cv)++; (void)SvREFCNT_inc(cv); @@ -1328,20 +1340,28 @@ PP(pp_scope) PP(pp_enteriter) { - dSP; dMARK; - register CONTEXT *cx; + djSP; dMARK; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; ENTER; SAVETMPS; - if (op->op_targ) - svp = &curpad[op->op_targ]; /* "my" variable */ +#ifdef USE_THREADS + if (op->op_flags & OPf_SPECIAL) + svp = save_threadsv(op->op_targ); /* per-thread variable */ else - svp = &GvSV((GV*)POPs); /* symbol table variable */ - - SAVESPTR(*svp); +#endif /* USE_THREADS */ + if (op->op_targ) { + svp = &curpad[op->op_targ]; /* "my" variable */ + SAVESPTR(*svp); + } + else { + GV *gv = (GV*)POPs; + (void)save_scalar(gv); + svp = &GvSV(gv); /* symbol table variable */ + } ENTER; @@ -1351,7 +1371,7 @@ PP(pp_enteriter) cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); else { cx->blk_loop.iterary = curstack; - AvFILL(curstack) = sp - stack_base; + AvFILLp(curstack) = SP - stack_base; cx->blk_loop.iterix = MARK - stack_base; } @@ -1360,8 +1380,8 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER; @@ -1376,8 +1396,8 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; struct block_loop cxloop; I32 gimme; SV **newsp; @@ -1417,9 +1437,9 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; + djSP; dMARK; I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; struct block_sub cxsub; bool popsub2 = FALSE; I32 gimme; @@ -1427,7 +1447,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; - if (curstack == sortstack) { + if (curstackinfo->si_type == SI_SORT) { if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) { if (cxstack_ix > sortcxix) dounwind(sortcxix); @@ -1466,10 +1486,22 @@ PP(pp_return) TAINT_NOT; if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = (popsub2 && SvTEMP(*SP)) - ? *SP : sv_mortalcopy(*SP); - else + if (MARK < SP) { + if (popsub2) { + if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) { + if (SvTEMP(TOPs)) { + *++newsp = SvREFCNT_inc(*SP); + FREETMPS; + sv_2mortal(*newsp); + } else { + FREETMPS; + *++newsp = sv_mortalcopy(*SP); + } + } else + *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); + } else + *++newsp = sv_mortalcopy(*SP); + } else *++newsp = &sv_undef; } else if (gimme == G_ARRAY) { @@ -1493,9 +1525,9 @@ PP(pp_return) PP(pp_last) { - dSP; + djSP; I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; struct block_loop cxloop; struct block_sub cxsub; I32 pop2 = 0; @@ -1576,7 +1608,7 @@ PP(pp_last) PP(pp_next) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 oldsave; if (op->op_flags & OPf_SPECIAL) { @@ -1601,7 +1633,7 @@ PP(pp_next) PP(pp_redo) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 oldsave; if (op->op_flags & OPf_SPECIAL) { @@ -1623,9 +1655,7 @@ PP(pp_redo) return cx->blk_loop.redo_op; } -static OP* lastgotoprobe; - -static OP * +STATIC OP * dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit) { OP *kid; @@ -1675,10 +1705,10 @@ PP(pp_dump) PP(pp_goto) { - dSP; + djSP; OP *retop = 0; I32 ix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; char *label; @@ -1691,7 +1721,7 @@ PP(pp_goto) /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; - register CONTEXT *cx; + register PERL_CONTEXT *cx; CV* cv = (CV*)SvRV(sv); SV** mark; I32 items = 0; @@ -1713,11 +1743,14 @@ PP(pp_goto) if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); + if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) + DIE("Can't goto subroutine from an eval-string"); mark = stack_sp; - if (cx->blk_sub.hasargs) { /* put @_ back onto stack */ + if (cx->cx_type == CXt_SUB && + cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; stack_sp++; EXTEND(stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), stack_sp, items, SV*); @@ -1729,7 +1762,8 @@ PP(pp_goto) AvREAL_off(av); av_clear(av); } - if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) + if (cx->cx_type == CXt_SUB && + !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); oldsave = scopestack[scopestack_ix - 1]; LEAVE_SCOPE(oldsave); @@ -1739,19 +1773,19 @@ PP(pp_goto) if (CvXSUB(cv)) { if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); - while (sp > mark) { - sp[1] = sp[0]; - sp--; + while (SP > mark) { + SP[1] = SP[0]; + SP--; } fp3 = (I32(*)_((int,int,int)))CvXSUB(cv); items = (*fp3)(CvXSUBANY(cv).any_i32, mark - stack_base + 1, items); - sp = stack_base + items; + SP = stack_base + items; } else { stack_sp--; /* There is no cv arg. */ - (void)(*CvXSUB(cv))(cv); + (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS); } LEAVE; return pop_return(); @@ -1759,6 +1793,12 @@ PP(pp_goto) else { AV* padlist = CvPADLIST(cv); SV** svp = AvARRAY(padlist); + if (cx->cx_type == CXt_EVAL) { + in_eval = cx->blk_eval.old_in_eval; + eval_root = cx->blk_eval.old_eval_root; + cx->cx_type = CXt_SUB; + cx->blk_sub.hasargs = 0; + } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); CvDEPTH(cv)++; @@ -1767,10 +1807,10 @@ PP(pp_goto) else { /* save temporaries on recursion? */ if (CvDEPTH(cv) == 100 && dowarn) sub_crush_depth(cv); - if (CvDEPTH(cv) > AvFILL(padlist)) { + if (CvDEPTH(cv) > AvFILLp(padlist)) { AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); - I32 ix = AvFILL((AV*)svp[1]); + I32 ix = AvFILLp((AV*)svp[1]); svp = AvARRAY(svp[0]); for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { @@ -1804,7 +1844,7 @@ PP(pp_goto) AvFLAGS(av) = AVf_REIFY; } av_store(padlist, CvDEPTH(cv), (SV*)newpad); - AvFILL(padlist) = CvDEPTH(cv); + AvFILLp(padlist) = CvDEPTH(cv); svp = AvARRAY(padlist); } } @@ -1812,12 +1852,12 @@ PP(pp_goto) if (!cx->blk_sub.hasargs) { AV* av = (AV*)curpad[0]; - items = AvFILL(av) + 1; + items = AvFILLp(av) + 1; if (items) { /* Mark is at the end of the stack. */ - EXTEND(sp, items); - Copy(AvARRAY(av), sp + 1, items, SV*); - sp += items; + EXTEND(SP, items); + Copy(AvARRAY(av), SP + 1, items, SV*); + SP += items; PUTBACK ; } } @@ -1852,7 +1892,7 @@ PP(pp_goto) } } Copy(mark,AvARRAY(av),items,SV*); - AvFILL(av) = items - 1; + AvFILLp(av) = items - 1; while (items--) { if (*mark) @@ -1860,14 +1900,26 @@ PP(pp_goto) mark++; } } - if (PERLDB_SUB && curstash != debstash) { + if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ /* * We do not care about using sv to call CV; * it's for informational purposes only. */ SV *sv = GvSV(DBsub); - save_item(sv); - gv_efullname3(sv, CvGV(cv), Nullch); + CV *gotocv; + + if (PERLDB_SUB_NN) { + SvIVX(sv) = (IV)cv; /* Already upgraded, saved */ + } else { + save_item(sv); + gv_efullname3(sv, CvGV(cv), Nullch); + } + if ( PERLDB_GOTO + && (gotocv = perl_get_cv("DB::goto", FALSE)) ) { + PUSHMARK( stack_sp ); + perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); + stack_sp--; + } } RETURNOP(CvSTART(cv)); } @@ -1953,7 +2005,7 @@ PP(pp_goto) if (op->op_type == OP_ENTERITER) DIE("Can't \"goto\" into the middle of a foreach loop", label); - (*op->op_ppaddr)(ARGS); + (CALLOP->op_ppaddr)(ARGS); } op = oldop; } @@ -1972,7 +2024,7 @@ PP(pp_goto) do_undump = FALSE; } - if (curstack == signalstack) { + if (top_env->je_prev) { restartop = retop; JMPENV_JUMP(3); } @@ -1982,7 +2034,7 @@ PP(pp_goto) PP(pp_exit) { - dSP; + djSP; I32 anum; if (MAXARG < 1) @@ -2002,7 +2054,7 @@ PP(pp_exit) #ifdef NOTYET PP(pp_nswitch) { - dSP; + djSP; double value = SvNVx(GvSV(cCOP->cop_gv)); register I32 match = I_32(value); @@ -2021,7 +2073,7 @@ PP(pp_nswitch) PP(pp_cswitch) { - dSP; + djSP; register I32 match; if (multiline) @@ -2041,7 +2093,7 @@ PP(pp_cswitch) /* Eval. */ -static void +STATIC void save_lines(AV *array, SV *sv) { register char *s = SvPVX(sv); @@ -2065,25 +2117,23 @@ save_lines(AV *array, SV *sv) } } -static OP * +STATIC OP * docatch(OP *o) { dTHR; int ret; - I32 oldrunlevel = runlevel; OP *oldop = op; dJMPENV; op = o; #ifdef DEBUGGING assert(CATCH_GET == TRUE); - DEBUG_l(deb("(Setting up local jumplevel, runlevel = %ld)\n", (long)runlevel+1)); + DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env)); #endif JMPENV_PUSH(ret); switch (ret) { default: /* topmost level handles it */ JMPENV_POP; - runlevel = oldrunlevel; op = oldop; JMPENV_JUMP(ret); /* NOTREACHED */ @@ -2096,25 +2146,85 @@ docatch(OP *o) restartop = 0; /* FALL THROUGH */ case 0: - runops(); + CALLRUNOPS(); break; } JMPENV_POP; - runlevel = oldrunlevel; op = oldop; return Nullop; } +OP * +sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp) +/* sv Text to convert to OP tree. */ +/* startop op_free() this to undo. */ +/* code Short string id of the caller. */ +{ + dSP; /* Make POPBLOCK work. */ + PERL_CONTEXT *cx; + SV **newsp; + I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */ + I32 optype; + OP dummy; + OP *oop = op, *rop; + char tmpbuf[TYPE_DIGITS(long) + 12 + 10]; + char *safestr; + + ENTER; + lex_start(sv); + SAVETMPS; + /* switch to eval mode */ + + SAVESPTR(compiling.cop_filegv); + SAVEI16(compiling.cop_line); + sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++evalseq); + compiling.cop_filegv = gv_fetchfile(tmpbuf+2); + compiling.cop_line = 1; + /* XXX For Cs within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ + safestr = savepv(tmpbuf); + SAVEDELETE(defstash, safestr, strlen(safestr)); + SAVEI32(hints); +#ifdef OP_IN_REGISTER + opsave = op; +#else + SAVEPPTR(op); +#endif + hints = 0; + + op = &dummy; + op->op_type = 0; /* Avoid uninit warning. */ + op->op_flags = 0; /* Avoid uninit warning. */ + PUSHBLOCK(cx, CXt_EVAL, SP); + PUSHEVAL(cx, 0, compiling.cop_filegv); + rop = doeval(G_SCALAR, startop); + POPBLOCK(cx,curpm); + POPEVAL(cx); + + (*startop)->op_type = OP_NULL; + (*startop)->op_ppaddr = ppaddr[OP_NULL]; + lex_end(); + *avp = (AV*)SvREFCNT_inc(comppad); + LEAVE; +#ifdef OP_IN_REGISTER + op = opsave; +#endif + return rop; +} + /* With USE_THREADS, eval_owner must be held on entry to doeval */ -static OP * -doeval(int gimme) +STATIC OP * +doeval(int gimme, OP** startop) { - dTHR; dSP; OP *saveop = op; HV *newstash; CV *caller; AV* comppadlist; + I32 i; in_eval = 1; @@ -2131,6 +2241,16 @@ doeval(int gimme) SAVEI32(max_intro_pending); caller = compcv; + for (i = cxstack_ix - 1; i >= 0; i--) { + PERL_CONTEXT *cx = &cxstack[i]; + if (cx->cx_type == CXt_EVAL) + break; + else if (cx->cx_type == CXt_SUB) { + caller = cx->blk_sub.cv; + break; + } + } + SAVESPTR(compcv); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); @@ -2160,8 +2280,8 @@ doeval(int gimme) av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(compcv) = comppadlist; - if (saveop->op_type != OP_REQUIRE) - CvOUTSIDE(compcv) = caller ? (CV*)SvREFCNT_inc(caller) : 0; + if (!saveop || saveop->op_type != OP_REQUIRE) + CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller); SAVEFREESV(compcv); @@ -2184,15 +2304,15 @@ doeval(int gimme) curcop->cop_arybase = 0; SvREFCNT_dec(rs); rs = newSVpv("\n", 1); - if (saveop->op_flags & OPf_SPECIAL) + if (saveop && saveop->op_flags & OPf_SPECIAL) in_eval |= 4; else - sv_setpv(errsv,""); + sv_setpv(ERRSV,""); if (yyparse() || error_count || !eval_root) { SV **newsp; I32 gimme; - CONTEXT *cx; - I32 optype; + PERL_CONTEXT *cx; + I32 optype = 0; /* Might be reset by POPEVAL. */ op = saveop; if (eval_root) { @@ -2200,14 +2320,22 @@ doeval(int gimme) eval_root = Nullop; } SP = stack_base + POPMARK; /* pop original mark */ - POPBLOCK(cx,curpm); - POPEVAL(cx); - pop_return(); + if (!startop) { + POPBLOCK(cx,curpm); + POPEVAL(cx); + pop_return(); + } lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPV(errsv, na); + char* msg = SvPVx(ERRSV, na); DIE("%s", *msg ? msg : "Compilation failed in require"); + } else if (startop) { + char* msg = SvPVx(ERRSV, na); + + POPBLOCK(cx,curpm); + POPEVAL(cx); + croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n")); } SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); @@ -2222,7 +2350,12 @@ doeval(int gimme) SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); compiling.cop_line = 0; - SAVEFREEOP(eval_root); + if (startop) { + *startop = eval_root; + SvREFCNT_dec(CvOUTSIDE(compcv)); + CvOUTSIDE(compcv) = Nullcv; + } else + SAVEFREEOP(eval_root); if (gimme & G_VOID) scalarvoid(eval_root); else if (gimme & G_ARRAY) @@ -2237,7 +2370,7 @@ doeval(int gimme) CV *cv = perl_get_cv("DB::postponed", FALSE); if (cv) { dSP; - PUSHMARK(sp); + PUSHMARK(SP); XPUSHs((SV*)compiling.cop_filegv); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); @@ -2248,7 +2381,7 @@ doeval(int gimme) CvDEPTH(compcv) = 1; SP = stack_base + POPMARK; /* pop original mark */ - op = saveop; /* The caller may need it. */ + op = saveop; /* The caller may need it. */ #ifdef USE_THREADS MUTEX_LOCK(&eval_mutex); eval_owner = 0; @@ -2261,10 +2394,11 @@ doeval(int gimme) PP(pp_require) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; SV *sv; char *name; + STRLEN len; char *tryname; SV *namesv = Nullsv; SV** svp; @@ -2279,12 +2413,12 @@ PP(pp_require) SvPV(sv,na),patchlevel); RETPUSHYES; } - name = SvPV(sv, na); - if (!*name) + name = SvPV(sv, len); + if (!(name && len > 0 && *name)) DIE("Null filename used"); TAINT_PROPER("require"); if (op->op_type == OP_REQUIRE && - (svp = hv_fetch(GvHVn(incgv), name, SvCUR(sv), 0)) && + (svp = hv_fetch(GvHVn(incgv), name, len, 0)) && *svp != &sv_undef) RETPUSHYES; @@ -2307,7 +2441,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,"r"); + tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(incgv); @@ -2330,7 +2464,7 @@ PP(pp_require) sv_setpvf(namesv, "%s/%s", dir, name); #endif tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, "r"); + tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -2401,7 +2535,7 @@ PP(pp_require) eval_owner = thr; MUTEX_UNLOCK(&eval_mutex); #endif /* USE_THREADS */ - return DOCATCH(doeval(G_SCALAR)); + return DOCATCH(doeval(G_SCALAR, NULL)); } PP(pp_dofile) @@ -2411,8 +2545,8 @@ PP(pp_dofile) PP(pp_entereval) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = sub_generation; char tmpbuf[TYPE_DIGITS(long) + 12]; @@ -2461,7 +2595,7 @@ PP(pp_entereval) eval_owner = thr; MUTEX_UNLOCK(&eval_mutex); #endif /* USE_THREADS */ - ret = doeval(gimme); + ret = doeval(gimme, NULL); if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */ && ret != op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ @@ -2471,12 +2605,12 @@ PP(pp_entereval) PP(pp_leaveeval) { - dSP; + djSP; register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; OP *retop; U8 save_flags = op -> op_flags; I32 optype; @@ -2518,10 +2652,10 @@ PP(pp_leaveeval) * (Note that the fact that compcv and friends are still set here * is, AFAIK, an accident.) --Chip */ - if (AvFILL(comppad_name) >= 0) { + if (AvFILLp(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); I32 ix; - for (ix = AvFILL(comppad_name); ix >= 0; ix--) { + for (ix = AvFILLp(comppad_name); ix >= 0; ix--) { SV *sv = svp[ix]; if (sv && sv != &sv_undef && *SvPVX(sv) == '&') { SvREFCNT_dec(sv); @@ -2546,29 +2680,30 @@ PP(pp_leaveeval) assert(CvDEPTH(compcv) == 1); #endif CvDEPTH(compcv) = 0; + lex_end(); if (optype == OP_REQUIRE && - !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) + !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp)) { /* Unassume the success we assumed earlier. */ char *name = cx->blk_eval.old_name; (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD); retop = die("%s did not return a true value", name); + /* die_where() did LEAVE, or we won't be here */ + } + else { + LEAVE; + if (!(save_flags & OPf_SPECIAL)) + sv_setpv(ERRSV,""); } - - lex_end(); - LEAVE; - - if (!(save_flags & OPf_SPECIAL)) - sv_setpv(errsv,""); RETURNOP(retop); } PP(pp_entertry) { - dSP; - register CONTEXT *cx; + djSP; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER; @@ -2580,19 +2715,19 @@ PP(pp_entertry) eval_root = op; /* Only needed so that goto works right. */ in_eval = 1; - sv_setpv(errsv,""); + sv_setpv(ERRSV,""); PUTBACK; return DOCATCH(op->op_next); } PP(pp_leavetry) { - dSP; + djSP; register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); @@ -2628,11 +2763,11 @@ PP(pp_leavetry) curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(errsv,""); + sv_setpv(ERRSV,""); RETURN; } -static void +STATIC void doparseform(SV *sv) { STRLEN len; @@ -2809,3 +2944,694 @@ doparseform(SV *sv) sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); } + +/* + * The rest of this file was derived from source code contributed + * by Tom Horsley. + * + * NOTE: this code was derived from Tom Horsley's qsort replacement + * and should not be confused with the original code. + */ + +/* Copyright (C) Tom Horsley, 1997. All rights reserved. + + Permission granted to distribute under the same terms as perl which are + (briefly): + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + Details on the perl license can be found in the perl source code which + may be located via the www.perl.com web page. + + This is the most wonderfulest possible qsort I can come up with (and + still be mostly portable) My (limited) tests indicate it consistently + does about 20% fewer calls to compare than does the qsort in the Visual + C++ library, other vendors may vary. + + Some of the ideas in here can be found in "Algorithms" by Sedgewick, + others I invented myself (or more likely re-invented since they seemed + pretty obvious once I watched the algorithm operate for a while). + + Most of this code was written while watching the Marlins sweep the Giants + in the 1997 National League Playoffs - no Braves fans allowed to use this + code (just kidding :-). + + I realize that if I wanted to be true to the perl tradition, the only + comment in this file would be something like: + + ...they shuffled back towards the rear of the line. 'No, not at the + rear!' the slave-driver shouted. 'Three files up. And stay there... + + However, I really needed to violate that tradition just so I could keep + track of what happens myself, not to mention some poor fool trying to + understand this years from now :-). +*/ + +/* ********************************************************** Configuration */ + +#ifndef QSORT_ORDER_GUESS +#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */ +#endif + +/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for + future processing - a good max upper bound is log base 2 of memory size + (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can + safely be smaller than that since the program is taking up some space and + most operating systems only let you grab some subset of contiguous + memory (not to mention that you are normally sorting data larger than + 1 byte element size :-). +*/ +#ifndef QSORT_MAX_STACK +#define QSORT_MAX_STACK 32 +#endif + +/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort. + Anything bigger and we use qsort. If you make this too small, the qsort + will probably break (or become less efficient), because it doesn't expect + the middle element of a partition to be the same as the right or left - + you have been warned). +*/ +#ifndef QSORT_BREAK_EVEN +#define QSORT_BREAK_EVEN 6 +#endif + +/* ************************************************************* Data Types */ + +/* hold left and right index values of a partition waiting to be sorted (the + partition includes both left and right - right is NOT one past the end or + anything like that). +*/ +struct partition_stack_entry { + int left; + int right; +#ifdef QSORT_ORDER_GUESS + int qsort_break_even; +#endif +}; + +/* ******************************************************* Shorthand Macros */ + +/* Note that these macros will be used from inside the qsort function where + we happen to know that the variable 'elt_size' contains the size of an + array element and the variable 'temp' points to enough space to hold a + temp element and the variable 'array' points to the array being sorted + and 'compare' is the pointer to the compare routine. + + Also note that there are very many highly architecture specific ways + these might be sped up, but this is simply the most generally portable + code I could think of. +*/ + +/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2 +*/ +#ifdef PERL_OBJECT +#define qsort_cmp(elt1, elt2) \ + ((this->*compare)(array[elt1], array[elt2])) +#else +#define qsort_cmp(elt1, elt2) \ + ((*compare)(array[elt1], array[elt2])) +#endif + +#ifdef QSORT_ORDER_GUESS +#define QSORT_NOTICE_SWAP swapped++; +#else +#define QSORT_NOTICE_SWAP +#endif + +/* swaps contents of array elements elt1, elt2. +*/ +#define qsort_swap(elt1, elt2) \ + STMT_START { \ + QSORT_NOTICE_SWAP \ + temp = array[elt1]; \ + array[elt1] = array[elt2]; \ + array[elt2] = temp; \ + } STMT_END + +/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets + elt3 and elt3 gets elt1. +*/ +#define qsort_rotate(elt1, elt2, elt3) \ + STMT_START { \ + QSORT_NOTICE_SWAP \ + temp = array[elt1]; \ + array[elt1] = array[elt2]; \ + array[elt2] = array[elt3]; \ + array[elt3] = temp; \ + } STMT_END + +/* ************************************************************ Debug stuff */ + +#ifdef QSORT_DEBUG + +static void +break_here() +{ + return; /* good place to set a breakpoint */ +} + +#define qsort_assert(t) (void)( (t) || (break_here(), 0) ) + +static void +doqsort_all_asserts( + void * array, + size_t num_elts, + size_t elt_size, + int (*compare)(const void * elt1, const void * elt2), + int pc_left, int pc_right, int u_left, int u_right) +{ + int i; + + qsort_assert(pc_left <= pc_right); + qsort_assert(u_right < pc_left); + qsort_assert(pc_right < u_left); + for (i = u_right + 1; i < pc_left; ++i) { + qsort_assert(qsort_cmp(i, pc_left) < 0); + } + for (i = pc_left; i < pc_right; ++i) { + qsort_assert(qsort_cmp(i, pc_right) == 0); + } + for (i = pc_right + 1; i < u_left; ++i) { + qsort_assert(qsort_cmp(pc_right, i) < 0); + } +} + +#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \ + doqsort_all_asserts(array, num_elts, elt_size, compare, \ + PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) + +#else + +#define qsort_assert(t) ((void)0) + +#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0) + +#endif + +/* ****************************************************************** qsort */ + +void +#ifdef PERL_OBJECT +qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare) +#else +qsortsv( + SV ** array, + size_t num_elts, + I32 (*compare)(SV *a, SV *b)) +#endif +{ + register SV * temp; + + struct partition_stack_entry partition_stack[QSORT_MAX_STACK]; + int next_stack_entry = 0; + + int part_left; + int part_right; +#ifdef QSORT_ORDER_GUESS + int qsort_break_even; + int swapped; +#endif + + /* Make sure we actually have work to do. + */ + if (num_elts <= 1) { + return; + } + + /* Setup the initial partition definition and fall into the sorting loop + */ + part_left = 0; + part_right = (int)(num_elts - 1); +#ifdef QSORT_ORDER_GUESS + qsort_break_even = QSORT_BREAK_EVEN; +#else +#define qsort_break_even QSORT_BREAK_EVEN +#endif + for ( ; ; ) { + if ((part_right - part_left) >= qsort_break_even) { + /* OK, this is gonna get hairy, so lets try to document all the + concepts and abbreviations and variables and what they keep + track of: + + pc: pivot chunk - the set of array elements we accumulate in the + middle of the partition, all equal in value to the original + pivot element selected. The pc is defined by: + + pc_left - the leftmost array index of the pc + pc_right - the rightmost array index of the pc + + we start with pc_left == pc_right and only one element + in the pivot chunk (but it can grow during the scan). + + u: uncompared elements - the set of elements in the partition + we have not yet compared to the pivot value. There are two + uncompared sets during the scan - one to the left of the pc + and one to the right. + + u_right - the rightmost index of the left side's uncompared set + u_left - the leftmost index of the right side's uncompared set + + The leftmost index of the left sides's uncompared set + doesn't need its own variable because it is always defined + by the leftmost edge of the whole partition (part_left). The + same goes for the rightmost edge of the right partition + (part_right). + + We know there are no uncompared elements on the left once we + get u_right < part_left and no uncompared elements on the + right once u_left > part_right. When both these conditions + are met, we have completed the scan of the partition. + + Any elements which are between the pivot chunk and the + uncompared elements should be less than the pivot value on + the left side and greater than the pivot value on the right + side (in fact, the goal of the whole algorithm is to arrange + for that to be true and make the groups of less-than and + greater-then elements into new partitions to sort again). + + As you marvel at the complexity of the code and wonder why it + has to be so confusing. Consider some of the things this level + of confusion brings: + + Once I do a compare, I squeeze every ounce of juice out of it. I + never do compare calls I don't have to do, and I certainly never + do redundant calls. + + I also never swap any elements unless I can prove there is a + good reason. Many sort algorithms will swap a known value with + an uncompared value just to get things in the right place (or + avoid complexity :-), but that uncompared value, once it gets + compared, may then have to be swapped again. A lot of the + complexity of this code is due to the fact that it never swaps + anything except compared values, and it only swaps them when the + compare shows they are out of position. + */ + int pc_left, pc_right; + int u_right, u_left; + + int s; + + pc_left = ((part_left + part_right) / 2); + pc_right = pc_left; + u_right = pc_left - 1; + u_left = pc_right + 1; + + /* Qsort works best when the pivot value is also the median value + in the partition (unfortunately you can't find the median value + without first sorting :-), so to give the algorithm a helping + hand, we pick 3 elements and sort them and use the median value + of that tiny set as the pivot value. + + Some versions of qsort like to use the left middle and right as + the 3 elements to sort so they can insure the ends of the + partition will contain values which will stop the scan in the + compare loop, but when you have to call an arbitrarily complex + routine to do a compare, its really better to just keep track of + array index values to know when you hit the edge of the + partition and avoid the extra compare. An even better reason to + avoid using a compare call is the fact that you can drop off the + edge of the array if someone foolishly provides you with an + unstable compare function that doesn't always provide consistent + results. + + So, since it is simpler for us to compare the three adjacent + elements in the middle of the partition, those are the ones we + pick here (conveniently pointed at by u_right, pc_left, and + u_left). The values of the left, center, and right elements + are refered to as l c and r in the following comments. + */ + +#ifdef QSORT_ORDER_GUESS + swapped = 0; +#endif + s = qsort_cmp(u_right, pc_left); + if (s < 0) { + /* l < c */ + s = qsort_cmp(pc_left, u_left); + /* if l < c, c < r - already in order - nothing to do */ + if (s == 0) { + /* l < c, c == r - already in order, pc grows */ + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s > 0) { + /* l < c, c > r - need to know more */ + s = qsort_cmp(u_right, u_left); + if (s < 0) { + /* l < c, c > r, l < r - swap c & r to get ordered */ + qsort_swap(pc_left, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l < c, c > r, l == r - swap c&r, grow pc */ + qsort_swap(pc_left, u_left); + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l < c, c > r, l > r - make lcr into rlc to get ordered */ + qsort_rotate(pc_left, u_right, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } + } else if (s == 0) { + /* l == c */ + s = qsort_cmp(pc_left, u_left); + if (s < 0) { + /* l == c, c < r - already in order, grow pc */ + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l == c, c == r - already in order, grow pc both ways */ + --pc_left; + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l == c, c > r - swap l & r, grow pc */ + qsort_swap(u_right, u_left); + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } else { + /* l > c */ + s = qsort_cmp(pc_left, u_left); + if (s < 0) { + /* l > c, c < r - need to know more */ + s = qsort_cmp(u_right, u_left); + if (s < 0) { + /* l > c, c < r, l < r - swap l & c to get ordered */ + qsort_swap(u_right, pc_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else if (s == 0) { + /* l > c, c < r, l == r - swap l & c, grow pc */ + qsort_swap(u_right, pc_left); + ++pc_right; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l > c, c < r, l > r - rotate lcr into crl to order */ + qsort_rotate(u_right, pc_left, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } else if (s == 0) { + /* l > c, c == r - swap ends, grow pc */ + qsort_swap(u_right, u_left); + --pc_left; + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } else { + /* l > c, c > r - swap ends to get in order */ + qsort_swap(u_right, u_left); + qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1); + } + } + /* We now know the 3 middle elements have been compared and + arranged in the desired order, so we can shrink the uncompared + sets on both sides + */ + --u_right; + ++u_left; + qsort_all_asserts(pc_left, pc_right, u_left, u_right); + + /* The above massive nested if was the simple part :-). We now have + the middle 3 elements ordered and we need to scan through the + uncompared sets on either side, swapping elements that are on + the wrong side or simply shuffling equal elements around to get + all equal elements into the pivot chunk. + */ + + for ( ; ; ) { + int still_work_on_left; + int still_work_on_right; + + /* Scan the uncompared values on the left. If I find a value + equal to the pivot value, move it over so it is adjacent to + the pivot chunk and expand the pivot chunk. If I find a value + less than the pivot value, then just leave it - its already + on the correct side of the partition. If I find a greater + value, then stop the scan. + */ + while (still_work_on_left = (u_right >= part_left)) { + s = qsort_cmp(u_right, pc_left); + if (s < 0) { + --u_right; + } else if (s == 0) { + --pc_left; + if (pc_left != u_right) { + qsort_swap(u_right, pc_left); + } + --u_right; + } else { + break; + } + qsort_assert(u_right < pc_left); + qsort_assert(pc_left <= pc_right); + qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0); + qsort_assert(qsort_cmp(pc_left, pc_right) == 0); + } + + /* Do a mirror image scan of uncompared values on the right + */ + while (still_work_on_right = (u_left <= part_right)) { + s = qsort_cmp(pc_right, u_left); + if (s < 0) { + ++u_left; + } else if (s == 0) { + ++pc_right; + if (pc_right != u_left) { + qsort_swap(pc_right, u_left); + } + ++u_left; + } else { + break; + } + qsort_assert(u_left > pc_right); + qsort_assert(pc_left <= pc_right); + qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0); + qsort_assert(qsort_cmp(pc_left, pc_right) == 0); + } + + if (still_work_on_left) { + /* I know I have a value on the left side which needs to be + on the right side, but I need to know more to decide + exactly the best thing to do with it. + */ + if (still_work_on_right) { + /* I know I have values on both side which are out of + position. This is a big win because I kill two birds + with one swap (so to speak). I can advance the + uncompared pointers on both sides after swapping both + of them into the right place. + */ + qsort_swap(u_right, u_left); + --u_right; + ++u_left; + qsort_all_asserts(pc_left, pc_right, u_left, u_right); + } else { + /* I have an out of position value on the left, but the + right is fully scanned, so I "slide" the pivot chunk + and any less-than values left one to make room for the + greater value over on the right. If the out of position + value is immediately adjacent to the pivot chunk (there + are no less-than values), I can do that with a swap, + otherwise, I have to rotate one of the less than values + into the former position of the out of position value + and the right end of the pivot chunk into the left end + (got all that?). + */ + --pc_left; + if (pc_left == u_right) { + qsort_swap(u_right, pc_right); + qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); + } else { + qsort_rotate(u_right, pc_left, pc_right); + qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1); + } + --pc_right; + --u_right; + } + } else if (still_work_on_right) { + /* Mirror image of complex case above: I have an out of + position value on the right, but the left is fully + scanned, so I need to shuffle things around to make room + for the right value on the left. + */ + ++pc_right; + if (pc_right == u_left) { + qsort_swap(u_left, pc_left); + qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); + } else { + qsort_rotate(pc_right, pc_left, u_left); + qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right); + } + ++pc_left; + ++u_left; + } else { + /* No more scanning required on either side of partition, + break out of loop and figure out next set of partitions + */ + break; + } + } + + /* The elements in the pivot chunk are now in the right place. They + will never move or be compared again. All I have to do is decide + what to do with the stuff to the left and right of the pivot + chunk. + + Notes on the QSORT_ORDER_GUESS ifdef code: + + 1. If I just built these partitions without swapping any (or + very many) elements, there is a chance that the elements are + already ordered properly (being properly ordered will + certainly result in no swapping, but the converse can't be + proved :-). + + 2. A (properly written) insertion sort will run faster on + already ordered data than qsort will. + + 3. Perhaps there is some way to make a good guess about + switching to an insertion sort earlier than partition size 6 + (for instance - we could save the partition size on the stack + and increase the size each time we find we didn't swap, thus + switching to insertion sort earlier for partitions with a + history of not swapping). + + 4. Naturally, if I just switch right away, it will make + artificial benchmarks with pure ascending (or descending) + data look really good, but is that a good reason in general? + Hard to say... + */ + +#ifdef QSORT_ORDER_GUESS + if (swapped < 3) { +#if QSORT_ORDER_GUESS == 1 + qsort_break_even = (part_right - part_left) + 1; +#endif +#if QSORT_ORDER_GUESS == 2 + qsort_break_even *= 2; +#endif +#if QSORT_ORDER_GUESS == 3 + int prev_break = qsort_break_even; + qsort_break_even *= qsort_break_even; + if (qsort_break_even < prev_break) { + qsort_break_even = (part_right - part_left) + 1; + } +#endif + } else { + qsort_break_even = QSORT_BREAK_EVEN; + } +#endif + + if (part_left < pc_left) { + /* There are elements on the left which need more processing. + Check the right as well before deciding what to do. + */ + if (pc_right < part_right) { + /* We have two partitions to be sorted. Stack the biggest one + and process the smallest one on the next iteration. This + minimizes the stack height by insuring that any additional + stack entries must come from the smallest partition which + (because it is smallest) will have the fewest + opportunities to generate additional stack entries. + */ + if ((part_right - pc_right) > (pc_left - part_left)) { + /* stack the right partition, process the left */ + partition_stack[next_stack_entry].left = pc_right + 1; + partition_stack[next_stack_entry].right = part_right; +#ifdef QSORT_ORDER_GUESS + partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; +#endif + part_right = pc_left - 1; + } else { + /* stack the left partition, process the right */ + partition_stack[next_stack_entry].left = part_left; + partition_stack[next_stack_entry].right = pc_left - 1; +#ifdef QSORT_ORDER_GUESS + partition_stack[next_stack_entry].qsort_break_even = qsort_break_even; +#endif + part_left = pc_right + 1; + } + qsort_assert(next_stack_entry < QSORT_MAX_STACK); + ++next_stack_entry; + } else { + /* The elements on the left are the only remaining elements + that need sorting, arrange for them to be processed as the + next partition. + */ + part_right = pc_left - 1; + } + } else if (pc_right < part_right) { + /* There is only one chunk on the right to be sorted, make it + the new partition and loop back around. + */ + part_left = pc_right + 1; + } else { + /* This whole partition wound up in the pivot chunk, so + we need to get a new partition off the stack. + */ + if (next_stack_entry == 0) { + /* the stack is empty - we are done */ + break; + } + --next_stack_entry; + part_left = partition_stack[next_stack_entry].left; + part_right = partition_stack[next_stack_entry].right; +#ifdef QSORT_ORDER_GUESS + qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; +#endif + } + } else { + /* This partition is too small to fool with qsort complexity, just + do an ordinary insertion sort to minimize overhead. + */ + int i; + /* Assume 1st element is in right place already, and start checking + at 2nd element to see where it should be inserted. + */ + for (i = part_left + 1; i <= part_right; ++i) { + int j; + /* Scan (backwards - just in case 'i' is already in right place) + through the elements already sorted to see if the ith element + belongs ahead of one of them. + */ + for (j = i - 1; j >= part_left; --j) { + if (qsort_cmp(i, j) >= 0) { + /* i belongs right after j + */ + break; + } + } + ++j; + if (j != i) { + /* Looks like we really need to move some things + */ + int k; + temp = array[i]; + for (k = i - 1; k >= j; --k) + array[k + 1] = array[k]; + array[j] = temp; + } + } + + /* That partition is now sorted, grab the next one, or get out + of the loop if there aren't any more. + */ + + if (next_stack_entry == 0) { + /* the stack is empty - we are done */ + break; + } + --next_stack_entry; + part_left = partition_stack[next_stack_entry].left; + part_right = partition_stack[next_stack_entry].right; +#ifdef QSORT_ORDER_GUESS + qsort_break_even = partition_stack[next_stack_entry].qsort_break_even; +#endif + } + } + + /* Believe it or not, the array is sorted at this point! */ +}