/* pp_ctl.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-1997, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define WORD_ALIGN sizeof(U16)
#endif
-static OP *doeval _((int gimme));
-static OP *dofindlabel _((OP *op, char *label, OP **opstack));
+#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
+static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
static void doparseform _((SV *sv));
static I32 dopoptoeval _((I32 startingblock));
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 sortcmp _((const void *, const void *));
-static int sortcv _((const void *, const void *));
+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));
static I32 sortcxix;
PP(pp_wantarray)
{
- dSP;
+ djSP;
I32 cxix;
EXTEND(SP, 1);
if (cxix < 0)
RETPUSHUNDEF;
- if (cxstack[cxix].blk_gimme == G_ARRAY)
+ switch (cxstack[cxix].blk_gimme) {
+ case G_ARRAY:
RETPUSHYES;
- else
+ case G_SCALAR:
RETPUSHNO;
+ default:
+ RETPUSHUNDEF;
+ }
}
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);
+
+ /* JMR: Check against the last compiled regexp
+ To know for sure, we'd need the length of precomp.
+ But we don't have it, so we must ... take a guess. */
+ if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
+ memNE(pm->op_pmregexp->precomp, t, len + 1))
+ {
+ 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)
pm->op_pmflags |= PMf_WHITE;
if (pm->op_pmflags & PMf_KEEP) {
- pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
- hoistmust(pm);
+ pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
cLOGOP->op_first->op_next = op->op_next;
}
RETURN;
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;
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
+ rxres_restore(&cx->sb_rxres, rx);
+
if (cx->sb_iters++) {
if (cx->sb_iters > cx->sb_maxiters)
DIE("Substitution loop");
+ if (!cx->sb_rxtainted)
+ cx->sb_rxtainted = SvTAINTED(TOPs);
sv_catsv(dstr, POPs);
- if (rx->subbase)
- Safefree(rx->subbase);
- rx->subbase = cx->sb_subbase;
/* 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_MATCH_TAINTED(rx));
+
(void)SvOOK_off(targ);
Safefree(SvPVX(targ));
SvPVX(targ) = SvPVX(dstr);
SvLEN_set(targ, SvLEN(dstr));
SvPVX(dstr) = 0;
sv_free(dstr);
-
(void)SvPOK_only(targ);
SvSETMAGIC(targ);
+ SvTAINT(targ);
+
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
cx->sb_m = m = rx->startp[0];
sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0];
- cx->sb_subbase = rx->subbase;
-
- rx->subbase = Nullch; /* so recursion works */
+ cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+ rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
}
+void
+rxres_save(void **rsp, REGEXP *rx)
+{
+ UV *p = (UV*)*rsp;
+ U32 i;
+
+ if (!p || p[1] < rx->nparens) {
+ i = 6 + rx->nparens * 2;
+ if (!p)
+ New(501, p, i, UV);
+ else
+ Renew(p, i, UV);
+ *rsp = (void*)p;
+ }
+
+ *p++ = (UV)rx->subbase;
+ rx->subbase = Nullch;
+
+ *p++ = rx->nparens;
+
+ *p++ = (UV)rx->subbeg;
+ *p++ = (UV)rx->subend;
+ for (i = 0; i <= rx->nparens; ++i) {
+ *p++ = (UV)rx->startp[i];
+ *p++ = (UV)rx->endp[i];
+ }
+}
+
+void
+rxres_restore(void **rsp, REGEXP *rx)
+{
+ UV *p = (UV*)*rsp;
+ U32 i;
+
+ Safefree(rx->subbase);
+ rx->subbase = (char*)(*p);
+ *p++ = 0;
+
+ rx->nparens = *p++;
+
+ rx->subbeg = (char*)(*p++);
+ rx->subend = (char*)(*p++);
+ for (i = 0; i <= rx->nparens; ++i) {
+ rx->startp[i] = (char*)(*p++);
+ rx->endp[i] = (char*)(*p++);
+ }
+}
+
+void
+rxres_free(void **rsp)
+{
+ UV *p = (UV*)*rsp;
+
+ if (p) {
+ Safefree((char*)(*p));
+ Safefree(p);
+ *rsp = Null(void*);
+ }
+}
+
PP(pp_formline)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register SV *form = *++MARK;
register U16 *fpc;
register char *t;
bool gotsome;
STRLEN len;
- if (!SvCOMPILED(form)) {
+ if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
SvREADONLY_off(form);
doparseform(form);
}
}
gotsome = TRUE;
value = SvNV(sv);
+ /* Formats aren't yet marked for locales, so assume "yes". */
+ SET_NUMERIC_LOCAL();
if (arg & 256) {
sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
} else {
PP(pp_grepstart)
{
- dSP;
+ djSP;
SV *src;
if (stack_base + *markstack_ptr == sp) {
(void)POPMARK;
- if (GIMME != G_ARRAY)
+ if (GIMME_V == G_SCALAR)
XPUSHs(&sv_no);
RETURNOP(op->op_next->op_next);
}
stack_sp = stack_base + *markstack_ptr + 1;
- pp_pushmark(); /* push dst */
- pp_pushmark(); /* push src */
+ pp_pushmark(ARGS); /* push dst */
+ pp_pushmark(ARGS); /* push src */
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)
- pp_pushmark(); /* push top */
+ pp_pushmark(ARGS); /* push top */
return ((LOGOP*)op->op_next)->op_other;
}
PP(pp_mapwhile)
{
- dSP;
+ djSP;
I32 diff = (sp - stack_base) - *markstack_ptr;
I32 count;
I32 shift;
/* All done yet? */
if (markstack_ptr[-1] > *markstack_ptr) {
I32 items;
+ I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
LEAVE; /* exit outer scope */
items = --*markstack_ptr - markstack_ptr[-1];
(void)POPMARK; /* pop dst */
SP = stack_base + POPMARK; /* pop original mark */
- if (GIMME != G_ARRAY) {
+ if (gimme == G_SCALAR) {
dTARGET;
XPUSHi(items);
- RETURN;
}
- SP += items;
+ else if (gimme == G_ARRAY)
+ SP += items;
RETURN;
}
else {
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;
sortcop = CvSTART(cv);
SAVESPTR(CvROOT(cv)->op_ppaddr);
CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
-
+
SAVESPTR(curpad);
curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
}
while (MARK < SP) { /* This may or may not shift down one here. */
/*SUPPRESS 560*/
if (*up = *++MARK) { /* Weed out nulls. */
- if (!SvPOK(*up))
+ SvTEMP_off(*up);
+ if (!sortcop && !SvPOK(*up))
(void)sv_2pv(*up, &na);
- else
- SvTEMP_off(*up);
up++;
}
}
if (sortcop) {
if (max > 1) {
AV *oldstack;
- CONTEXT *cx;
+ PERL_CONTEXT *cx;
SV** newsp;
+ bool oldcatch = CATCH_GET;
SAVETMPS;
- SAVESPTR(op);
+ SAVEOP();
oldstack = curstack;
if (!sortstack) {
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
+ CATCH_SET(TRUE);
SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
SAVESPTR(GvSV(firstgv));
SAVESPTR(GvSV(secondgv));
- PUSHBLOCK(cx, CXt_LOOP, stack_base);
+
+ PUSHBLOCK(cx, CXt_NULL, stack_base);
+ if (!(op->op_flags & OPf_SPECIAL)) {
+ bool hasargs = FALSE;
+ cx->cx_type = CXt_SUB;
+ cx->blk_gimme = G_SCALAR;
+ PUSHSUB(cx);
+ if (!CvDEPTH(cv))
+ (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
+ }
sortcxix = cxstack_ix;
- qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
+ qsortsv(myorigmark+1, max, sortcv);
POPBLOCK(cx,curpm);
SWITCHSTACK(sortstack, oldstack);
+ 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*), sortcmp);
+ qsortsv(ORIGMARK+1, max,
+ (op->op_private & OPpLOCALE) ? sv_cmp_locale : sv_cmp);
}
}
stack_sp = ORIGMARK + max;
PP(pp_flip)
{
- dSP;
+ djSP;
if (GIMME == G_ARRAY) {
RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (op->op_flags & OPf_SPECIAL) {
sv_setiv(targ, 1);
+ SETs(targ);
RETURN;
}
else {
PP(pp_flop)
{
- dSP;
+ djSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
I32 max;
if (SvNIOKp(left) || !SvPOKp(left) ||
- (looks_like_number(left) && *SvPVX(left) != '0') ) {
+ (looks_like_number(left) && *SvPVX(left) != '0') )
+ {
i = SvIV(left);
max = SvIV(right);
- if (max > i)
+ if (max >= i) {
+ EXTEND_MORTAL(max - i + 1);
EXTEND(SP, max - i + 1);
+ }
while (i <= max) {
- sv = sv_mortalcopy(&sv_no);
- sv_setiv(sv,i++);
+ sv = sv_2mortal(newSViv(i++));
PUSHs(sv);
}
}
/* Control. */
static I32
-dopoptolabel(label)
-char *label;
+dopoptolabel(char *label)
{
+ dTHR;
register I32 i;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
for (i = cxstack_ix; i >= 0; i--) {
cx = &cxstack[i];
if (dowarn)
warn("Exiting eval via %s", op_name[op->op_type]);
break;
+ case CXt_NULL:
+ if (dowarn)
+ warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+ return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
strNE(label, cx->blk_loop.label) ) {
- DEBUG_l(deb("(Skipping label #%d %s)\n",
- i, cx->blk_loop.label));
+ DEBUG_l(deb("(Skipping label #%ld %s)\n",
+ (long)i, cx->blk_loop.label));
continue;
}
- DEBUG_l( deb("(Found label #%d %s)\n", i, label));
+ DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
return i;
}
}
}
I32
-dowantarray()
+dowantarray(void)
{
+ I32 gimme = block_gimme();
+ return (gimme == G_VOID) ? G_SCALAR : gimme;
+}
+
+I32
+block_gimme(void)
+{
+ dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
- return G_SCALAR;
+ return G_VOID;
- if (cxstack[cxix].blk_gimme == G_ARRAY)
- return G_ARRAY;
- else
+ switch (cxstack[cxix].blk_gimme) {
+ case G_SCALAR:
return G_SCALAR;
+ case G_ARRAY:
+ return G_ARRAY;
+ default:
+ croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
+ case G_VOID:
+ return G_VOID;
+ }
}
static I32
-dopoptosub(startingblock)
-I32 startingblock;
+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) {
continue;
case CXt_EVAL:
case CXt_SUB:
- DEBUG_l( deb("(Found sub #%d)\n", i));
+ DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
return i;
}
}
}
static I32
-dopoptoeval(startingblock)
-I32 startingblock;
+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) {
default:
continue;
case CXt_EVAL:
- DEBUG_l( deb("(Found eval #%d)\n", i));
+ DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
return i;
}
}
}
static I32
-dopoptoloop(startingblock)
-I32 startingblock;
+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) {
case CXt_SUBST:
if (dowarn)
- warn("Exiting substitition via %s", op_name[op->op_type]);
+ warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
if (dowarn)
if (dowarn)
warn("Exiting eval via %s", op_name[op->op_type]);
break;
+ case CXt_NULL:
+ if (dowarn)
+ warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+ return -1;
case CXt_LOOP:
- DEBUG_l( deb("(Found loop #%d)\n", i));
+ DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
return i;
}
}
}
void
-dounwind(cxix)
-I32 cxix;
+dounwind(I32 cxix)
{
- register CONTEXT *cx;
+ dTHR;
+ 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]));
+ cx = &cxstack[cxstack_ix];
+ DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
+ (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:
+ POPSUBST(cx);
+ continue; /* not break */
case CXt_SUB:
POPSUB(cx);
break;
case CXt_LOOP:
POPLOOP(cx);
break;
- case CXt_SUBST:
+ case CXt_NULL:
break;
}
+ cxstack_ix--;
}
}
-#ifdef I_STDARG
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
OP *
-die(pat, va_alist)
- char *pat;
- va_dcl
-#endif
-{
- va_list args;
- char *message;
- int oldrunlevel = runlevel;
- int was_in_eval = in_eval;
- HV *stash;
- GV *gv;
- CV *cv;
-
- /* We have to switch back to mainstack or die_where may try to pop
- * the eval block from the wrong stack if die is being called from a
- * signal handler. - dkindred@cs.cmu.edu */
- if (curstack != mainstack) {
- dSP;
- SWITCHSTACK(curstack, mainstack);
- }
-#ifdef I_STDARG
- va_start(args, pat);
-#else
- va_start(args);
-#endif
- message = mess(pat, &args);
- va_end(args);
- if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
- }
- restartop = die_where(message);
- if ((!restartop && was_in_eval) || oldrunlevel > 1)
- Siglongjmp(top_env, 3);
- return restartop;
-}
-
-OP *
-die_where(message)
-char *message;
+die_where(char *message)
{
+ dTHR;
if (in_eval) {
I32 cxix;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
SV **svp;
STRLEN klen = strlen(message);
- svp = hv_fetch(GvHV(errgv), message, klen, TRUE);
+ 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);
- SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen);
- sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1);
- sv_catpvn(GvSV(errgv), message, klen);
+ 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);
}
}
else
- sv_setpv(GvSV(errgv), message);
+ sv_setpv(ERRSV, message);
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(errgv), na));
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(ERRSV, na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ }
return pop_return();
}
}
PerlIO_printf(PerlIO_stderr(), "%s",message);
PerlIO_flush(PerlIO_stderr());
- if (e_tmpname) {
- if (e_fp) {
- PerlIO_close(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
-#else
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ my_failure_exit();
+ /* NOTREACHED */
return 0;
}
PP(pp_xor)
{
- dSP; dPOPTOPssrl;
+ djSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
PP(pp_andassign)
{
- dSP;
+ djSP;
if (!SvTRUE(TOPs))
RETURN;
else
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();
-}
-#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;
}
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)
PUSHs(sv_2mortal(newSVpv("(eval)",0)));
PUSHs(sv_2mortal(newSViv(0)));
}
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
+ gimme = (I32)cx->blk_gimme;
+ if (gimme == G_VOID)
+ PUSHs(&sv_undef);
+ else
+ PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
if (cx->cx_type == CXt_EVAL) {
if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
PUSHs(cx->blk_eval.cur_text);
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(a, b)
-const void *a;
-const void *b;
+static I32
+sortcv(SV *a, SV *b)
{
- SV **str1 = (SV **) a;
- SV **str2 = (SV **) b;
+ dTHR;
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();
return result;
}
-static int
-sortcmp(a, b)
-const void *a;
-const void *b;
-{
- register SV *str1 = *(SV **) a;
- register SV *str2 = *(SV **) b;
- I32 retval;
-
- if (!SvPOKp(str1)) {
- if (!SvPOKp(str2))
- return 0;
- else
- return -1;
- }
- if (!SvPOKp(str2))
- return 1;
-
- if (lc_collate_active) { /* NOTE: this is the LC_COLLATE branch */
- register char * pv1, * pv2, * pvx;
- STRLEN cur1, cur2, curx;
-
- pv1 = SvPV(str1, cur1);
- pvx = mem_collxfrm(pv1, cur1, &curx);
- pv1 = pvx;
- cur1 = curx;
-
- pv2 = SvPV(str2, cur2);
- pvx = mem_collxfrm(pv2, cur2, &curx);
- pv2 = pvx;
- cur2 = curx;
-
- retval = memcmp((void *)pv1, (void *)pv2, cur1 < cur2 ? cur1 : cur2);
-
- Safefree(pv1);
- Safefree(pv2);
-
- if (retval)
- return retval < 0 ? -1 : 1;
-
- if (cur1 == cur2)
- return 0;
- else
- return cur1 < cur2 ? -1 : 1;
- }
-
- /* NOTE: this is the non-LC_COLLATE area */
-
- if (SvCUR(str1) < SvCUR(str2)) {
- /*SUPPRESS 560*/
- if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
- return retval;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
- return retval;
- else if (SvCUR(str1) == SvCUR(str2))
- return 0;
- else
- return 1;
-}
-
PP(pp_reset)
{
- dSP;
+ djSP;
char *tmps;
if (MAXARG < 1)
{
SV **sp;
register CV *cv;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme = G_ARRAY;
I32 hasargs;
GV *gv;
SAVETMPS;
SAVEI32(debug);
- SAVESPTR(stack_sp);
+ SAVESTACK_POS();
debug = 0;
hasargs = 0;
sp = stack_sp;
PP(pp_enteriter)
{
- dSP; dMARK;
- register CONTEXT *cx;
- I32 gimme = GIMME;
+ 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;
PUSHBLOCK(cx, CXt_LOOP, SP);
PUSHLOOP(cx, svp, MARK);
- if (op->op_flags & OPf_STACKED) {
- AV* av = (AV*)POPs;
- cx->blk_loop.iterary = av;
- cx->blk_loop.iterix = -1;
- }
+ if (op->op_flags & OPf_STACKED)
+ 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;
}
PP(pp_enterloop)
{
- dSP;
- register CONTEXT *cx;
- I32 gimme = GIMME;
+ djSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
PP(pp_leaveloop)
{
- dSP;
- register CONTEXT *cx;
+ djSP;
+ register PERL_CONTEXT *cx;
+ struct block_loop cxloop;
I32 gimme;
SV **newsp;
PMOP *newpm;
POPBLOCK(cx,newpm);
mark = newsp;
- POPLOOP(cx);
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- ;
- else {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &sv_undef;
- }
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ ; /* do nothing */
+ else if (gimme == G_SCALAR) {
+ if (mark < SP)
+ *++newsp = sv_mortalcopy(*SP);
+ else
+ *++newsp = &sv_undef;
}
else {
- while (mark < SP)
+ while (mark < SP) {
*++newsp = sv_mortalcopy(*++mark);
+ TAINT_NOT; /* Each item is independent */
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ POPLOOP2(); /* Stack values are safe: release loop vars ... */
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
LEAVE;
- RETURN;
+ return NORMAL;
}
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;
SV **newsp;
PMOP *newpm;
I32 optype = 0;
if (curstack == sortstack) {
- if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
+ if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
AvARRAY(curstack)[1] = *SP;
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_SUB:
- POPSUB(cx);
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ popsub2 = TRUE;
break;
case CXt_EVAL:
POPEVAL(cx);
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
{
+ /* Unassume the success we assumed earlier. */
char *name = cx->blk_eval.old_name;
(void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
DIE("%s did not return a true value", name);
break;
default:
DIE("panic: return");
- break;
}
+ TAINT_NOT;
if (gimme == G_SCALAR) {
if (MARK < SP)
- *++newsp = sv_mortalcopy(*SP);
+ *++newsp = (popsub2 && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
- else {
- while (MARK < SP)
- *++newsp = sv_mortalcopy(*++MARK);
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP) {
+ *++newsp = (popsub2 && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
stack_sp = newsp;
+ /* Stack values are safe: */
+ if (popsub2) {
+ POPSUB2(); /* release CV and @_ ... */
+ }
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
return pop_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;
I32 gimme;
I32 optype;
OP *nextop;
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_LOOP:
- POPLOOP(cx);
- nextop = cx->blk_loop.last_op->op_next;
- LEAVE;
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+ pop2 = CXt_LOOP;
+ nextop = cxloop.last_op->op_next;
break;
- case CXt_EVAL:
- POPEVAL(cx);
+ case CXt_SUB:
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ pop2 = CXt_SUB;
nextop = pop_return();
break;
- case CXt_SUB:
- POPSUB(cx);
+ case CXt_EVAL:
+ POPEVAL(cx);
nextop = pop_return();
break;
default:
DIE("panic: last");
- break;
}
+ TAINT_NOT;
if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
+ if (MARK < SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
- else {
- while (mark < SP)
- *++newsp = sv_mortalcopy(*++mark);
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP) {
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ /* Stack values are safe: */
+ switch (pop2) {
+ case CXt_LOOP:
+ POPLOOP2(); /* release loop vars ... */
+ LEAVE;
+ break;
+ case CXt_SUB:
+ POPSUB2(); /* release CV and @_ ... */
+ break;
+ }
+ curpm = newpm; /* ... and pop $1 et al */
LEAVE;
- RETURNOP(nextop);
+ return nextop;
}
PP(pp_next)
{
I32 cxix;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 oldsave;
if (op->op_flags & OPf_SPECIAL) {
PP(pp_redo)
{
I32 cxix;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 oldsave;
if (op->op_flags & OPf_SPECIAL) {
static OP* lastgotoprobe;
static OP *
-dofindlabel(op,label,opstack)
-OP *op;
-char *label;
-OP **opstack;
+dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
{
OP *kid;
OP **ops = opstack;
-
- if (op->op_type == OP_LEAVE ||
- op->op_type == OP_SCOPE ||
- op->op_type == OP_LEAVELOOP ||
- op->op_type == OP_LEAVETRY)
- *ops++ = cUNOP->op_first;
+ static char too_deep[] = "Target of goto is too deeply nested";
+
+ if (ops >= oplimit)
+ croak(too_deep);
+ if (o->op_type == OP_LEAVE ||
+ o->op_type == OP_SCOPE ||
+ o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVETRY)
+ {
+ *ops++ = cUNOPo->op_first;
+ if (ops >= oplimit)
+ croak(too_deep);
+ }
*ops = 0;
- if (op->op_flags & OPf_KIDS) {
+ if (o->op_flags & OPf_KIDS) {
/* First try all the kids at this level, since that's likeliest. */
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
kCOP->cop_label && strEQ(kCOP->cop_label, label))
return kid;
}
- for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if (kid == lastgotoprobe)
continue;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
- if (ops > opstack &&
- (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE))
- *ops = kid;
- else
- *ops++ = kid;
- }
- if (op = dofindlabel(kid,label,ops))
- return op;
+ if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
+ (ops == opstack ||
+ (ops[-1]->op_type != OP_NEXTSTATE &&
+ ops[-1]->op_type != OP_DBSTATE)))
+ *ops++ = kid;
+ if (o = dofindlabel(kid, label, ops, oplimit))
+ return o;
}
}
*ops = 0;
PP(pp_goto)
{
- dSP;
+ djSP;
OP *retop = 0;
I32 ix;
- register CONTEXT *cx;
- OP *enterops[64];
+ register PERL_CONTEXT *cx;
+#define GOTO_DEPTH 64
+ OP *enterops[GOTO_DEPTH];
char *label;
int do_dump = (op->op_type == OP_DUMP);
/* 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;
if (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*);
stack_sp += items;
+#ifndef USE_THREADS
+ SvREFCNT_dec(GvAV(defgv));
GvAV(defgv) = cx->blk_sub.savearray;
+#endif /* USE_THREADS */
AvREAL_off(av);
av_clear(av);
}
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
if (CvDEPTH(cv) == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",
- GvENAME(CvGV(cv)));
- if (CvDEPTH(cv) > AvFILL(padlist)) {
+ sub_crush_depth(cv);
+ 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) {
char *name = SvPVX(svp[ix]);
- if (SvFLAGS(svp[ix]) & SVf_FAKE) {
- /* outer lexical? */
+ if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+ || *name == '&')
+ {
+ /* outer lexical or anon code */
av_store(newpad, ix,
SvREFCNT_inc(oldpad[ix]) );
}
AvFLAGS(av) = AVf_REIFY;
}
av_store(padlist, CvDEPTH(cv), (SV*)newpad);
- AvFILL(padlist) = CvDEPTH(cv);
+ AvFILLp(padlist) = CvDEPTH(cv);
svp = AvARRAY(padlist);
}
}
+#ifdef USE_THREADS
+ if (!cx->blk_sub.hasargs) {
+ AV* av = (AV*)curpad[0];
+
+ 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;
+ PUTBACK ;
+ }
+ }
+#endif /* USE_THREADS */
SAVESPTR(curpad);
curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
- if (cx->blk_sub.hasargs) {
+#ifndef USE_THREADS
+ if (cx->blk_sub.hasargs)
+#endif /* USE_THREADS */
+ {
AV* av = (AV*)curpad[0];
SV** ary;
+#ifndef USE_THREADS
cx->blk_sub.savearray = GvAV(defgv);
+ GvAV(defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
cx->blk_sub.argarray = av;
- GvAV(defgv) = cx->blk_sub.argarray;
++mark;
if (items >= AvMAX(av) + 1) {
}
}
Copy(mark,AvARRAY(av),items,SV*);
- AvFILL(av) = items - 1;
+ AvFILLp(av) = items - 1;
while (items--) {
if (*mark)
mark++;
}
}
- if (perldb && curstash != debstash) {
- /* &xsub is not copying @_ */
+ if (PERLDB_SUB && curstash != debstash) {
+ /*
+ * 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);
- /* We do not care about using sv to call CV,
- * just for info. */
}
RETURNOP(CvSTART(cv));
}
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
switch (cx->cx_type) {
- case CXt_SUB:
- gotoprobe = CvROOT(cx->blk_sub.cv);
- break;
case CXt_EVAL:
gotoprobe = eval_root; /* XXX not good for nested eval */
break;
else
gotoprobe = main_root;
break;
+ case CXt_SUB:
+ if (CvDEPTH(cx->blk_sub.cv)) {
+ gotoprobe = CvROOT(cx->blk_sub.cv);
+ break;
+ }
+ /* FALL THROUGH */
+ case CXt_NULL:
+ DIE("Can't \"goto\" outside a block");
default:
if (ix)
DIE("panic: goto");
- else
- gotoprobe = main_root;
+ gotoprobe = main_root;
break;
}
- retop = dofindlabel(gotoprobe, label, enterops);
+ retop = dofindlabel(gotoprobe, label,
+ enterops, enterops + GOTO_DEPTH);
if (retop)
break;
lastgotoprobe = gotoprobe;
OP *oldop = op;
for (ix = 1; enterops[ix]; ix++) {
op = enterops[ix];
- (*op->op_ppaddr)();
+ /* Eventually we may want to stack the needed arguments
+ * for each op. For now, we punt on the hard ones. */
+ if (op->op_type == OP_ENTERITER)
+ DIE("Can't \"goto\" into the middle of a foreach loop",
+ label);
+ (*op->op_ppaddr)(ARGS);
}
op = oldop;
}
if (curstack == signalstack) {
restartop = retop;
- Siglongjmp(top_env, 3);
+ JMPENV_JUMP(3);
}
RETURNOP(retop);
PP(pp_exit)
{
- dSP;
+ djSP;
I32 anum;
if (MAXARG < 1)
anum = 0;
- else
+ else {
anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+ if (anum == 1 && VMSISH_EXIT)
+ anum = 0;
+#endif
+ }
my_exit(anum);
PUSHs(&sv_undef);
RETURN;
#ifdef NOTYET
PP(pp_nswitch)
{
- dSP;
+ djSP;
double value = SvNVx(GvSV(cCOP->cop_gv));
register I32 match = I_32(value);
PP(pp_cswitch)
{
- dSP;
+ djSP;
register I32 match;
if (multiline)
/* Eval. */
static void
-save_lines(array, sv)
-AV *array;
-SV *sv;
+save_lines(AV *array, SV *sv)
{
register char *s = SvPVX(sv);
register char *send = SvPVX(sv) + SvCUR(sv);
}
static OP *
-doeval(gimme)
-int gimme;
+docatch(OP *o)
+{
+ dTHR;
+ int ret;
+ OP *oldop = op;
+ dJMPENV;
+
+ op = o;
+#ifdef DEBUGGING
+ assert(CATCH_GET == TRUE);
+ 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;
+ op = oldop;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ case 3:
+ if (!restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ break;
+ }
+ op = restartop;
+ restartop = 0;
+ /* FALL THROUGH */
+ case 0:
+ runops();
+ break;
+ }
+ JMPENV_POP;
+ 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 C<eval "...">s 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);
+ SAVEPPTR(op);
+ 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;
+ return rop;
+}
+
+/* With USE_THREADS, eval_owner must be held on entry to doeval */
+static OP *
+doeval(int gimme, OP** startop)
{
dSP;
OP *saveop = op;
HV *newstash;
+ CV *caller;
AV* comppadlist;
+ I32 i;
in_eval = 1;
/* set up a scratch pad */
- SAVEINT(padix);
+ SAVEI32(padix);
SAVESPTR(curpad);
SAVESPTR(comppad);
SAVESPTR(comppad_name);
- SAVEINT(comppad_name_fill);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
+ SAVEI32(comppad_name_fill);
+ SAVEI32(min_intro_pending);
+ 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);
+ CvUNIQUE_on(compcv);
+#ifdef USE_THREADS
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
comppad_name = newAV();
comppad_name_fill = 0;
min_intro_pending = 0;
- av_push(comppad, Nullsv);
- curpad = AvARRAY(comppad);
padix = 0;
+#ifdef USE_THREADS
+ av_store(comppad_name, 0, newSVpv("@_", 2));
+ curpad[0] = (SV*)newAV();
+ SvPADMY_on(curpad[0]); /* XXX Needed? */
+#endif /* USE_THREADS */
comppadlist = newAV();
AvREAL_off(comppadlist);
av_store(comppadlist, 0, (SV*)comppad_name);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
+
+ if (!saveop || saveop->op_type != OP_REQUIRE)
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
SAVEFREESV(compcv);
/* make sure we compile in the right package */
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(GvSV(errgv),"");
+ 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) {
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)
- DIE("%s", SvPVx(GvSV(errgv), na));
+ if (optype == OP_REQUIRE) {
+ 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);
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ eval_owner = 0;
+ COND_SIGNAL(&eval_cond);
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
RETPUSHUNDEF;
}
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
compiling.cop_line = 0;
- SAVEFREEOP(eval_root);
- if (gimme & G_ARRAY)
+ 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)
list(eval_root);
else
scalar(eval_root);
DEBUG_x(dump_eval());
+ /* Register with debugger: */
+ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
+ CV *cv = perl_get_cv("DB::postponed", FALSE);
+ if (cv) {
+ dSP;
+ PUSHMARK(sp);
+ XPUSHs((SV*)compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+
/* compiled okay, so do it */
+ CvDEPTH(compcv) = 1;
SP = stack_base + POPMARK; /* pop original mark */
+ op = saveop; /* The caller may need it. */
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ eval_owner = 0;
+ COND_SIGNAL(&eval_cond);
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
+
RETURNOP(eval_start);
}
PP(pp_require)
{
- dSP;
- register CONTEXT *cx;
+ djSP;
+ register PERL_CONTEXT *cx;
SV *sv;
char *name;
- char *tmpname;
+ char *tryname;
+ SV *namesv = Nullsv;
SV** svp;
I32 gimme = G_SCALAR;
PerlIO *tryrsfp = 0;
sv = POPs;
if (SvNIOKp(sv) && !SvPOKp(sv)) {
+ SET_NUMERIC_STANDARD();
if (atof(patchlevel) + 0.00000999 < SvNV(sv))
DIE("Perl %s required--this is only version %s, stopped",
SvPV(sv,na),patchlevel);
/* prepare to compile file */
- tmpname = savepv(name);
- if (*tmpname == '/' ||
- (*tmpname == '.' &&
- (tmpname[1] == '/' ||
- (tmpname[1] == '.' && tmpname[2] == '/')))
+ if (*name == '/' ||
+ (*name == '.' &&
+ (name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/')))
#ifdef DOSISH
- || (tmpname[0] && tmpname[1] == ':')
+ || (name[0] && name[1] == ':')
+#endif
+#ifdef WIN32
+ || (name[0] == '\\' && name[1] == '\\') /* UNC path */
#endif
#ifdef VMS
- || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
- (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
+ || (strchr(name,':') || ((*name == '[' || *name == '<') &&
+ (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
#endif
)
{
- tryrsfp = PerlIO_open(tmpname,"r");
+ tryname = name;
+ tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
}
else {
AV *ar = GvAVn(incgv);
I32 i;
-
- for (i = 0; i <= AvFILL(ar); i++) {
#ifdef VMS
- if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
- continue;
- strcat(buf,name);
+ char *unixname;
+ if ((unixname = tounixspec(name, Nullch)) != Nullch)
+#endif
+ {
+ namesv = NEWSV(806, 0);
+ for (i = 0; i <= AvFILL(ar); i++) {
+ char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
+#ifdef VMS
+ char *unixdir;
+ if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+ continue;
+ sv_setpv(namesv, unixdir);
+ sv_catpv(namesv, unixname);
#else
- (void)sprintf(buf, "%s/%s",
- SvPVx(*av_fetch(ar, i, TRUE), na), name);
+ sv_setpvf(namesv, "%s/%s", dir, name);
#endif
- tryrsfp = PerlIO_open(buf, "r");
- if (tryrsfp) {
- char *s = buf;
-
- if (*s == '.' && s[1] == '/')
- s += 2;
- Safefree(tmpname);
- tmpname = savepv(s);
- break;
+ tryname = SvPVX(namesv);
+ tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
+ if (tryrsfp) {
+ if (tryname[0] == '.' && tryname[1] == '/')
+ tryname += 2;
+ break;
+ }
}
}
}
SAVESPTR(compiling.cop_filegv);
- compiling.cop_filegv = gv_fetchfile(tmpname);
- Safefree(tmpname);
- tmpname = Nullch;
+ compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
+ SvREFCNT_dec(namesv);
if (!tryrsfp) {
if (op->op_type == OP_REQUIRE) {
- sprintf(tokenbuf,"Can't locate %s in @INC", name);
- if (instr(tokenbuf,".h "))
- strcat(tokenbuf," (change .h to .ph maybe?)");
- if (instr(tokenbuf,".ph "))
- strcat(tokenbuf," (did you run h2ph?)");
- DIE("%s",tokenbuf);
+ SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
+ SV *dirmsgsv = NEWSV(0, 0);
+ AV *ar = GvAVn(incgv);
+ I32 i;
+ if (instr(SvPVX(msg), ".h "))
+ sv_catpv(msg, " (change .h to .ph maybe?)");
+ if (instr(SvPVX(msg), ".ph "))
+ sv_catpv(msg, " (did you run h2ph?)");
+ sv_catpv(msg, " (@INC contains:");
+ for (i = 0; i <= AvFILL(ar); i++) {
+ char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
+ sv_setpvf(dirmsgsv, " %s", dir);
+ sv_catsv(msg, dirmsgsv);
+ }
+ sv_catpvn(msg, ")", 1);
+ SvREFCNT_dec(dirmsgsv);
+ DIE("%_", msg);
}
RETPUSHUNDEF;
compiling.cop_line = 0;
PUTBACK;
- return doeval(G_SCALAR);
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ if (eval_owner && eval_owner != thr)
+ while (eval_owner)
+ COND_WAIT(&eval_cond, &eval_mutex);
+ eval_owner = thr;
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
+ return DOCATCH(doeval(G_SCALAR, NULL));
}
PP(pp_dofile)
PP(pp_entereval)
{
- dSP;
- register CONTEXT *cx;
+ djSP;
+ register PERL_CONTEXT *cx;
dPOPss;
- I32 gimme = GIMME;
- char tmpbuf[32];
+ I32 gimme = GIMME_V, was = sub_generation;
+ char tmpbuf[TYPE_DIGITS(long) + 12];
+ char *safestr;
STRLEN len;
+ OP *ret;
if (!SvPV(sv,len) || !len)
RETPUSHUNDEF;
/* switch to eval mode */
SAVESPTR(compiling.cop_filegv);
- sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+ sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
- SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf));
+ /* XXX For C<eval "...">s 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);
hints = op->op_targ;
/* prepare to compile string */
- if (perldb && curstash != debstash)
+ if (PERLDB_LINE && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
- return doeval(gimme);
+#ifdef USE_THREADS
+ MUTEX_LOCK(&eval_mutex);
+ if (eval_owner && eval_owner != thr)
+ while (eval_owner)
+ COND_WAIT(&eval_cond, &eval_mutex);
+ eval_owner = thr;
+ MUTEX_UNLOCK(&eval_mutex);
+#endif /* USE_THREADS */
+ 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. */
+ }
+ return DOCATCH(ret);
}
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;
POPEVAL(cx);
retop = pop_return();
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- MARK = newsp;
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ MARK = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & SVs_TEMP)
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
else {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
- SP = MARK;
}
else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & SVs_TEMP))
+ /* in case LEAVE wipes old return values */
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & SVs_TEMP)) {
*mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
}
curpm = newpm; /* Don't pop $1 et al till now */
- if (optype == OP_REQUIRE &&
- !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
- char *name = cx->blk_eval.old_name;
+ /*
+ * Closures mentioned at top level of eval cannot be referenced
+ * again, and their presence indirectly causes a memory leak.
+ * (Note that the fact that compcv and friends are still set here
+ * is, AFAIK, an accident.) --Chip
+ */
+ if (AvFILLp(comppad_name) >= 0) {
+ SV **svp = AvARRAY(comppad_name);
+ I32 ix;
+ for (ix = AvFILLp(comppad_name); ix >= 0; ix--) {
+ SV *sv = svp[ix];
+ if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
+ SvREFCNT_dec(sv);
+ svp[ix] = &sv_undef;
+
+ sv = curpad[ix];
+ if (CvCLONE(sv)) {
+ SvREFCNT_dec(CvOUTSIDE(sv));
+ CvOUTSIDE(sv) = Nullcv;
+ }
+ else {
+ SvREFCNT_dec(sv);
+ sv = NEWSV(0,0);
+ SvPADTMP_on(sv);
+ curpad[ix] = sv;
+ }
+ }
+ }
+ }
+
+#ifdef DEBUGGING
+ assert(CvDEPTH(compcv) == 1);
+#endif
+ CvDEPTH(compcv) = 0;
+ if (optype == OP_REQUIRE &&
+ !(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);
}
lex_end();
LEAVE;
+
if (!(save_flags & OPf_SPECIAL))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
RETURNOP(retop);
}
PP(pp_entertry)
{
- dSP;
- register CONTEXT *cx;
- I32 gimme = GIMME;
+ djSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
eval_root = op; /* Only needed so that goto works right. */
in_eval = 1;
- sv_setpv(GvSV(errgv),"");
- RETURN;
+ 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);
POPEVAL(cx);
pop_return();
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- MARK = newsp;
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ SP = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
else {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
SP = MARK;
}
else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
+ /* in case LEAVE wipes old return values */
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
*mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
}
curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
RETURN;
}
static void
-doparseform(sv)
-SV *sv;
+doparseform(SV *sv)
{
STRLEN len;
register char *s = SvPV_force(sv, len);
register I32 arg;
bool ischop;
- New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */
+ if (len == 0)
+ croak("Null picture in formline");
+
+ New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
fpc = fops;
if (s < send) {
skipspaces++;
arg -= skipspaces;
if (arg) {
- if (postspace) {
+ if (postspace)
*fpc++ = FF_SPACE;
- postspace = FALSE;
- }
*fpc++ = FF_LITERAL;
*fpc++ = arg;
}
+ postspace = FALSE;
if (s <= send)
skipspaces--;
if (skipspaces) {
}
Copy(fops, s, arg, U16);
Safefree(fops);
+ 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
+*/
+#define qsort_cmp(elt1, elt2) \
+ ((*compare)(array[elt1], array[elt2]))
+
+#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
+qsortsv(
+ SV ** array,
+ size_t num_elts,
+ I32 (*compare)(SV *a, SV *b))
+{
+ 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
+ */
+ temp = array[i];
+ for (--i; i >= j; --i)
+ array[i + 1] = array[i];
+ 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! */
+}
https://perl5.git.perl.org / perl5.git / blobdiff