/*
 * Implementation of most standard Tcl list processing commands
 * suitable for operation on thread shared (list) variables.
 *
 * Copyright (c) 2002 by Zoran Vasiljevic.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ----------------------------------------------------------------------------
 */

#include "threadSvCmd.h"

/*
 * Implementation of list commands for shared variables.
 * Most of the standard Tcl list commands are implemented.
 * There are also two new commands: "lpop" and "lpush".
 * Those are very convenient for simple stack operations.
 *
 * Main difference to standard Tcl commands is that our commands
 * operate on list variable per-reference instead per-value.
 * This way we avoid frequent object shuffling between shared 
 * containers and current interpreter, thus increasing speed.
 */

static Tcl_ObjCmdProc SvLpopObjCmd;      /* lpop        */
static Tcl_ObjCmdProc SvLpushObjCmd;     /* lpush       */
static Tcl_ObjCmdProc SvLappendObjCmd;   /* lappend     */
static Tcl_ObjCmdProc SvLreplaceObjCmd;  /* lreplace    */
static Tcl_ObjCmdProc SvLlengthObjCmd;   /* llength     */
static Tcl_ObjCmdProc SvLindexObjCmd;    /* lindex      */
static Tcl_ObjCmdProc SvLinsertObjCmd;   /* linsert     */
static Tcl_ObjCmdProc SvLrangeObjCmd;    /* lrange      */
static Tcl_ObjCmdProc SvLsearchObjCmd;   /* lsearch     */
static Tcl_ObjCmdProc SvLsetObjCmd;      /* lset        */

/*
 * These two are copied verbatim from the tclUtil.c
 * since not found in the public stubs table.
 * I was just too lazy to rewrite them from scratch.
 */

static int SvCheckBadOctal(Tcl_Interp*, const char *);
static int SvGetIntForIndex(Tcl_Interp*,  Tcl_Obj *, int, int*);

/*
 * Inefficient list duplicator function which,
 * however, produces deep list copies, unlike
 * the original, which just makes shallow copies.
 */

static void DupListObjShared(Tcl_Obj*, Tcl_Obj*);

/*
 * This mutex protects a static variable which tracks
 * registration of commands and object types.
 */

static Tcl_Mutex initMutex;

/*
 * Functions for implementing the "lset" list command
 */

static Tcl_Obj*
SvLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount,
           Tcl_Obj **indexArray, Tcl_Obj *valuePtr);


/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterListCommands --
 *
 *      Register list commands with shared variable module.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      Memory gets allocated
 *
 *-----------------------------------------------------------------------------
 */

void
Sv_RegisterListCommands(void)
{
    static int initialized = 0;

    if (initialized == 0) {
        Tcl_MutexLock(&initMutex);
        if (initialized == 0) {
            Sv_RegisterCommand("lpop",     SvLpopObjCmd,     NULL, NULL);
            Sv_RegisterCommand("lpush",    SvLpushObjCmd,    NULL, NULL);
            Sv_RegisterCommand("lappend",  SvLappendObjCmd,  NULL, NULL);
            Sv_RegisterCommand("lreplace", SvLreplaceObjCmd, NULL, NULL);
            Sv_RegisterCommand("linsert",  SvLinsertObjCmd,  NULL, NULL);
            Sv_RegisterCommand("llength",  SvLlengthObjCmd,  NULL, NULL);
            Sv_RegisterCommand("lindex",   SvLindexObjCmd,   NULL, NULL);
            Sv_RegisterCommand("lrange",   SvLrangeObjCmd,   NULL, NULL);
            Sv_RegisterCommand("lsearch",  SvLsearchObjCmd,  NULL, NULL);
            Sv_RegisterCommand("lset",     SvLsetObjCmd,     NULL, NULL);
            Sv_RegisterObjType(Tcl_GetObjType("list"), DupListObjShared);
            initialized = 1;
        }
        Tcl_MutexUnlock(&initMutex);
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLpopObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lpop" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpopObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, llen, index = 0, iarg = 0;
    Tcl_Obj *elPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpop array key ?index?
     *          $list lpop ?index?
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) > 1) {
        Tcl_WrongNumArgs(interp, off, objv, "?index?");
        goto cmd_err;
    }
    if ((objc - off) == 1) {
        iarg = off;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (iarg) {
        ret = SvGetIntForIndex(interp, objv[iarg], llen-1, &index);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
    }
    if (index < 0 || index >= llen) {
        goto cmd_ok; /* Ignore out-of bounds, like Tcl does */
    }
    ret = Tcl_ListObjIndex(interp, svObj->tclObj, index, &elPtr);
    if (ret != TCL_OK) {
        goto cmd_err;
    }

    Tcl_IncrRefCount(elPtr);
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 1, 0, NULL);
    if (ret != TCL_OK) {
        Tcl_DecrRefCount(elPtr);
        goto cmd_err;
    }
    Tcl_SetObjResult(interp, elPtr);
    Tcl_DecrRefCount(elPtr);

 cmd_ok:
    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLpushObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lpush" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLpushObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, llen, index = 0;
    Tcl_Obj *args[1];
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lpush array key element ?index?
     *          $list lpush element ?index?
     */

    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) < 1) {
        Tcl_WrongNumArgs(interp, off, objv, "element ?index?");
        goto cmd_err;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if ((objc - off) == 2) {
        ret = SvGetIntForIndex(interp, objv[off+1], llen, &index);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
        if (index < 0) {
            index = 0;
        } else if (index > llen) {
            index = llen;
        }
    }

    args[0] = Sv_DuplicateObj(objv[off]);
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, 1, args);
    if (ret != TCL_OK) {
        Tcl_DecrRefCount(args[0]);
        goto cmd_err;
    }

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLappendObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lappend" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLappendObjCmd(arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int i, ret, flg, off;
    Tcl_Obj *dup;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lappend array key value ?value ...?
     *          $list lappend value ?value ...?
     */

    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) < 1) {
        Tcl_WrongNumArgs(interp, off, objv, "value ?value ...?");
        goto cmd_err;
    }
    for (i = off; i < objc; i++) {
        dup = Sv_DuplicateObj(objv[i]);
        ret = Tcl_ListObjAppendElement(interp, svObj->tclObj, dup);
        if (ret != TCL_OK) {
            Tcl_DecrRefCount(dup);
            goto cmd_err;
        }
    }

    Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj));

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLreplaceObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lreplace" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLreplaceObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    const char *firstArg;
    int argLen, ret, off, llen, first, last, ndel, nargs, i, j;
    Tcl_Obj **args = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lreplace array key first last ?element ...?
     *          $list lreplace first last ?element ...?
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) < 2) {
        Tcl_WrongNumArgs(interp, off, objv, "first last ?element ...?");
        goto cmd_err;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen-1, &first);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off+1], llen-1, &last);
    if (ret != TCL_OK) {
        goto cmd_err;
    }

    firstArg = Tcl_GetStringFromObj(objv[off], &argLen);
    if (first < 0)  {
        first = 0;
    }
    if (llen && first >= llen && strncmp(firstArg, "end", argLen)) {
        Tcl_AppendResult(interp, "list doesn't have element ", firstArg, NULL);
        goto cmd_err;
    }
    if (last >= llen) {
        last = llen - 1;
    }
    if (first <= last) {
        ndel = last - first + 1;
    } else {
        ndel = 0;
    }

    nargs = objc - (off + 2);
    if (nargs) {
        args = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
        for(i = off + 2, j = 0; i < objc; i++, j++) {
            args[j] = Sv_DuplicateObj(objv[i]);
        }
    }

    ret = Tcl_ListObjReplace(interp, svObj->tclObj, first, ndel, nargs, args);
    if (args) {
        if (ret != TCL_OK) {
            for(i = off + 2, j = 0; i < objc; i++, j++) {
                Tcl_DecrRefCount(args[j]);
            }
        }
        Tcl_Free((char*)args);
    }

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLrangeObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lrange" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLrangeObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, llen, first, last, nargs, i, j;
    Tcl_Obj **elPtrs, **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lrange array key first last
     *          $list lrange first last
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) != 2) {
        Tcl_WrongNumArgs(interp, off, objv, "first last");
        goto cmd_err;
    }
    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen-1, &first);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off+1], llen-1, &last);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (first < 0)  {
        first = 0;
    }
    if (last >= llen) {
        last = llen - 1;
    }
    if (first > last) {
        goto cmd_ok;
    }

    nargs = last - first + 1;
    args  = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
    for (i = first, j = 0; i <= last; i++, j++) {
        args[j] = Sv_DuplicateObj(elPtrs[i]);
    }

    Tcl_ResetResult(interp);
    Tcl_SetListObj(Tcl_GetObjResult(interp), nargs, args);
    Tcl_Free((char*)args);

 cmd_ok:
    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLinsertObjCmd --
 *
 *      This procedure is invoked to process the "tsv::linsert" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLinsertObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int off, ret, flg, llen, nargs, index = 0, i, j;
    Tcl_Obj **args;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::linsert array key index element ?element ...?
     *          $list linsert element ?element ...?
     */

    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) < 2) {
        Tcl_WrongNumArgs(interp, off, objv, "index element ?element ...?");
        goto cmd_err;
    }
    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen, &index);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (index < 0) {
        index = 0;
    } else if (index > llen) {
        index = llen;
    }

    nargs = objc - (off + 1);
    args  = (Tcl_Obj**)Tcl_Alloc(nargs * sizeof(Tcl_Obj*));
    for (i = off + 1, j = 0; i < objc; i++, j++) {
         args[j] = Sv_DuplicateObj(objv[i]);
    }
    ret = Tcl_ListObjReplace(interp, svObj->tclObj, index, 0, nargs, args);
    if (ret != TCL_OK) {
        for (i = off + 1, j = 0; i < objc; i++, j++) {
            Tcl_DecrRefCount(args[j]);
        }
        Tcl_Free((char*)args);
        goto cmd_err;
    }

    Tcl_Free((char*)args);

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLlengthObjCmd --
 *
 *      This procedure is invoked to process the "tsv::llength" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLlengthObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int llen, off, ret;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::llength array key
     *          $list llength
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }

    ret = Tcl_ListObjLength(interp, svObj->tclObj, &llen);
    if (ret == TCL_OK) {
        Tcl_ResetResult(interp);
        Tcl_SetIntObj(Tcl_GetObjResult(interp), llen);
    }
    if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) {
        return TCL_ERROR;
    }
    
    return ret;
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLsearchObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lsearch" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsearchObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    int ret, off, listc, mode, imode, ipatt, length, index, match, i;
    const char *patBytes;
    Tcl_Obj **listv;
    Container *svObj = (Container*)arg;

    static const char *modes[] = {"-exact", "-glob", "-regexp", NULL};
    enum {LS_EXACT, LS_GLOB, LS_REGEXP};

    mode = LS_GLOB;

    /*
     * Syntax:
     *          tsv::lsearch array key ?mode? pattern
     *          $list lsearch ?mode? pattern
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) == 2) {
        imode = off;
        ipatt = off + 1;
    } else if ((objc - off) == 1) {
        imode = 0;
        ipatt = off;
    } else {
        Tcl_WrongNumArgs(interp, off, objv, "?mode? pattern");
        goto cmd_err;
    }
    if (imode) {
        ret = Tcl_GetIndexFromObj(interp, objv[imode], modes, "search mode",
                0, &mode);
        if (ret != TCL_OK) {
            goto cmd_err;
        }
    }
    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &listc, &listv);
    if (ret != TCL_OK) {
        goto cmd_err;
    }

    index = -1;
    patBytes = Tcl_GetStringFromObj(objv[ipatt], &length);

    for (i = 0; i < listc; i++) {
        match = 0;
        switch (mode) {
        case LS_GLOB:
            match = Tcl_StringMatch(Tcl_GetString(listv[i]), patBytes);
            break;

        case LS_EXACT: {
            int elemLen;
            const char *bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
            if (length == elemLen) {
                match = (memcmp(bytes, patBytes, (size_t)length) == 0);
            }
            break;
        }
        case LS_REGEXP:
            match = Tcl_RegExpMatchObj(interp, listv[i], objv[ipatt]);
            if (match < 0) {
                goto cmd_err;
            }
            break;
        }
        if (match) {
            index = i;
            break;
        }
    }

    Tcl_ResetResult(interp);
    Tcl_SetIntObj(Tcl_GetObjResult(interp), index);

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLindexObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lindex" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLindexObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj **elPtrs;
    int ret, off, llen, index;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lindex array key index
     *          $list lindex index
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) != 1) {
        Tcl_WrongNumArgs(interp, off, objv, "index");
        goto cmd_err;
    }
    ret = Tcl_ListObjGetElements(interp, svObj->tclObj, &llen, &elPtrs);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    ret = SvGetIntForIndex(interp, objv[off], llen-1, &index);
    if (ret != TCL_OK) {
        goto cmd_err;
    }
    if (index >= 0 && index < llen) {
        Tcl_SetObjResult(interp, Sv_DuplicateObj(elPtrs[index]));
    }

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvLsetObjCmd --
 *
 *      This procedure is invoked to process the "tsv::lset" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvLsetObjCmd (arg, interp, objc, objv)
    ClientData arg;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj *const objv[];
{
    Tcl_Obj *lPtr;
    int ret, argc, off;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          tsv::lset array key index ?index ...? value
     *          $list lset index ?index ...? value
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
        return TCL_ERROR;
    }
    if ((objc - off) < 2) {
        Tcl_WrongNumArgs(interp, off, objv, "index ?index...? value");
        goto cmd_err;
    }

    lPtr = svObj->tclObj;
    argc = objc - off - 1;

    if (!SvLsetFlat(interp, lPtr, argc, (Tcl_Obj**)(objv+off),objv[objc-1])) {
        return TCL_ERROR;
    }

    Tcl_SetObjResult(interp, Sv_DuplicateObj(lPtr));

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

/*
 *-----------------------------------------------------------------------------
 *
 * DupListObjShared --
 *
 *      Help function to make a proper deep copy of the list object.
 *      This is used as the replacement-hook for list object native
 *      DupInternalRep function. We need it since the native function
 *      does a shallow list copy, i.e. retains references to list
 *      element objects from the original list. This gives us trouble
 *      when making the list object shared between threads.
 *
 * Results:
 *      None.
 *
 * Side effects;
 *      This is not a very efficient implementation, but that's all what's
 *      available to Tcl API programmer. We could include the tclInt.h and
 *      get the copy more efficient using list internals, but ...
 *
 *-----------------------------------------------------------------------------
 */

static void
DupListObjShared(srcPtr, copyPtr)
    Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
    Tcl_Obj *copyPtr;           /* Object with internal rep to set. */
{
    int i, llen;
    Tcl_Obj *elObj, **newObjList;

    Tcl_ListObjLength(NULL, srcPtr, &llen);
    if (llen == 0) { 
        (*srcPtr->typePtr->dupIntRepProc)(srcPtr, copyPtr);
        copyPtr->refCount = 0;
        return;
    }

    newObjList = (Tcl_Obj**)Tcl_Alloc(llen*sizeof(Tcl_Obj*));

    for (i = 0; i < llen; i++) {
        Tcl_ListObjIndex(NULL, srcPtr, i, &elObj);
        newObjList[i] = Sv_DuplicateObj(elObj);
    }

    Tcl_SetListObj(copyPtr, llen, newObjList);

    Tcl_Free((char*)newObjList);
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvCheckBadOctal --
 *
 *  Exact copy from the TclCheckBadOctal found in tclUtil.c
 *  since this is not in the stubs table.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvCheckBadOctal(interp, value)
    Tcl_Interp *interp;     /* Interpreter to use for error reporting.
                             * If NULL, then no error message is left
                             * after errors. */
    const char *value;      /* String to check. */
{
    register const char *p = value;

    /*
     * A frequent mistake is invalid octal values due to an unwanted
     * leading zero. Try to generate a meaningful error message.
     */

    while (isspace((unsigned char)(*p))) { /* INTL: ISO space. */
        p++;
    }
    if (*p == '+' || *p == '-') {
        p++;
    }
    if (*p == '0') {
        while (isdigit((unsigned char)(*p))) { /* INTL: digit. */
            p++;
        }
        while (isspace((unsigned char)(*p))) { /* INTL: ISO space. */
            p++;
        }
        if (*p == '\0') {
            /* Reached end of string */
            if (interp != NULL) {
                Tcl_AppendResult(interp, " (looks like invalid octal number)",
                        (char *) NULL);
            }
            return 1;
        }
    }
    return 0;
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvGetIntForIndex --
 *
 *  Exact copy from the TclGetIntForIndex found in tclUtil.c
 *  since this is not in the stubs table.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvGetIntForIndex(interp, objPtr, endValue, indexPtr)
    Tcl_Interp *interp;     /* Interpreter to use for error reporting.
                             * If NULL, then no error message is left
                             * after errors. */
    Tcl_Obj *objPtr;        /* Points to an object containing either
                             * "end" or an integer. */
    int endValue;           /* The value to be stored at "indexPtr" if
                             * "objPtr" holds "end". */
    int *indexPtr;          /* Location filled in with an integer
                             * representing an index. */
{
    const char *bytes;
    int length, offset;

    bytes = Tcl_GetStringFromObj(objPtr, &length);

    if ((*bytes != 'e')
        || (strncmp(bytes, "end",(size_t)((length > 3) ? 3 : length)) != 0)) {
        if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) {
            goto intforindex_error;
        }
        *indexPtr = offset;
        return TCL_OK;
    }
    if (length <= 3) {
        *indexPtr = endValue;
    } else if (bytes[3] == '-') {
        /*
         * This is our limited string expression evaluator
         */
        if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) {
            return TCL_ERROR;
        }
        *indexPtr = endValue + offset;
    } else {
  intforindex_error:
        if (interp != NULL) {
            Tcl_ResetResult(interp);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad index \"",
                    bytes, "\": must be integer or end?-integer?",(char*)NULL);
            SvCheckBadOctal(interp, bytes);
        }
        return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * SvLsetFlat --
 *
 *  Almost exact copy from the TclLsetFlat found in tclListObj.c.
 *  Simplified in a sense that thread shared objects are guaranteed
 *  to be non-shared.
 *
 *  Actual return value of this procedure is irrelevant to the caller,
 *  and it should be either NULL or non-NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SvLsetFlat(interp, listPtr, indexCount, indexArray, valuePtr)
     Tcl_Interp *interp;     /* Tcl interpreter */
     Tcl_Obj *listPtr;       /* Pointer to the list being modified */
     int indexCount;         /* Number of index args */
     Tcl_Obj **indexArray;
     Tcl_Obj *valuePtr;      /* Value arg to 'lset' */
{
    int elemCount, index, result, i;
    Tcl_Obj **elemPtrs, *chainPtr, *subListPtr;

    /*
     * Determine whether the index arg designates a list
     * or a single index.
     */

    if (indexCount == 1 &&
        Tcl_ListObjGetElements(interp, indexArray[0], &indexCount, 
                               &indexArray) != TCL_OK) {
        /*
         * Index arg designates something that is neither an index
         * nor a well formed list.
         */

        return NULL;
    }

    /*
     * If there are no indices, then simply return the new value,
     * counting the returned pointer as a reference
     */

    if (indexCount == 0) {
        return valuePtr;
    }

    /*
     * Anchor the linked list of Tcl_Obj's whose string reps must be
     * invalidated if the operation succeeds.
     */

    chainPtr = NULL;

    /*
     * Handle each index arg by diving into the appropriate sublist
     */

    for (i = 0; ; ++i) {

        /*
         * Take the sublist apart.
         */

        result = Tcl_ListObjGetElements(interp,listPtr,&elemCount,&elemPtrs);
        if (result != TCL_OK) {
            break;
        }

        listPtr->internalRep.twoPtrValue.ptr2 = (VOID*)chainPtr;

        /*
         * Determine the index of the requested element.
         */

        result = SvGetIntForIndex(interp, indexArray[i], elemCount-1, &index);
        if (result != TCL_OK) {
            break;
        }
        
        /*
         * Check that the index is in range.
         */
        
        if (index < 0 || index >= elemCount) {
            Tcl_SetObjResult(interp,
                             Tcl_NewStringObj("list index out of range", -1));
            result = TCL_ERROR;
            break;
        }

        /*
         * Break the loop after extracting the innermost sublist
         */

        if (i >= (indexCount - 1)) {
            result = TCL_OK;
            break;
        }
    
        /*
         * Extract the appropriate sublist and chain it onto the linked
         * list of Tcl_Obj's whose string reps must be spoilt.
         */

        subListPtr = elemPtrs[index];
        chainPtr = listPtr;
        listPtr = subListPtr;
    }

    /* Store the result in the list element */

    if (result == TCL_OK) {
        result = Tcl_ListObjGetElements(interp,listPtr,&elemCount,&elemPtrs);
        if (result == TCL_OK) {
            Tcl_DecrRefCount(elemPtrs[index]);
            elemPtrs[index] = Sv_DuplicateObj(valuePtr);
            Tcl_IncrRefCount(elemPtrs[index]);
        }
    }

    if (result == TCL_OK) {
        listPtr->internalRep.twoPtrValue.ptr2 = (VOID*)chainPtr;
        /* Spoil all the string reps */
        while (listPtr != NULL) {
            subListPtr = (Tcl_Obj*)listPtr->internalRep.twoPtrValue.ptr2;
            Tcl_InvalidateStringRep(listPtr);
            listPtr->internalRep.twoPtrValue.ptr2 = NULL;
            listPtr = subListPtr;
        }
        
        return valuePtr;
    }
    
    return NULL;
}

/* EOF $RCSfile: threadSvListCmd.c,v $ */

/* Emacs Setup Variables */
/* Local Variables:      */
/* mode: C               */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4     */
/* End:                  */