/*
 * threadSvKeylist.c --
 *
 * This file implements keyed-list commands as part of the thread
 * shared variable implementation.
 *
 * Keyed list implementation is borrowed from Mark Diekhans and
 * Karl Lehenbauer "TclX" (extended Tcl) extension. Please look
 * into the keylist.c file for more information.
 *
 * See the file "license.txt" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 * ---------------------------------------------------------------------------
 */

#include "threadSvCmd.h"
#include "threadSvKeylistCmd.h"
#include "tclXkeylist.h"

/*
 * Wrapped keyed-list commands
 */

static Tcl_ObjCmdProc2 SvKeylsetObjCmd;
static Tcl_ObjCmdProc2 SvKeylgetObjCmd;
static Tcl_ObjCmdProc2 SvKeyldelObjCmd;
static Tcl_ObjCmdProc2 SvKeylkeysObjCmd;

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

static Tcl_Mutex initMutex;


/*
 *-----------------------------------------------------------------------------
 *
 * Sv_RegisterKeylistCommands --
 *
 *      Register shared variable commands for TclX keyed lists.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      Memory gets allocated
 *
 *-----------------------------------------------------------------------------
 */
void
Sv_RegisterKeylistCommands(void)
{
    static int initialized;

    if (initialized == 0) {
	Tcl_MutexLock(&initMutex);
	if (initialized == 0) {
	    Sv_RegisterCommand("keylset",  SvKeylsetObjCmd,  NULL, 0);
	    Sv_RegisterCommand("keylget",  SvKeylgetObjCmd,  NULL, 0);
	    Sv_RegisterCommand("keyldel",  SvKeyldelObjCmd,  NULL, 0);
	    Sv_RegisterCommand("keylkeys", SvKeylkeysObjCmd, NULL, 0);
	    Sv_RegisterObjType(&keyedListType, DupKeyedListInternalRepShared);
	    initialized = 1;
	}
	Tcl_MutexUnlock(&initMutex);
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * SvKeylsetObjCmd --
 *
 *      This procedure is invoked to process the "tsv::keylset" command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-----------------------------------------------------------------------------
 */

static int
SvKeylsetObjCmd(
    void *arg,                         /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret, flg;
    Tcl_Size i, off;
    char *key;
    Tcl_Obj *val;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          sv::keylset array lkey key value ?key value ...?
     *          $keylist keylset key value ?key value ...?
     */

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

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

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

static int
SvKeylgetObjCmd(
    void *arg,                         /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret, flg;
    Tcl_Size off;
    char *key;
    Tcl_Obj *varObjPtr = NULL, *valObjPtr = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          sv::keylget array lkey ?key? ?var?
     *          $keylist keylget ?key? ?var?
     */

    flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
    if (ret != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc > 2 + off) {
	Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?");
	goto cmd_err;
    }
    if (objc == off) {
	if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) {
	    return TCL_ERROR;
	}
	return SvKeylkeysObjCmd(arg, interp, objc, objv);
    }
    if (objc == 2 + off) {
	varObjPtr = objv[off+1];
    } else {
	varObjPtr = NULL;
    }

    key = Tcl_GetString(objv[off]);
    ret = TclX_KeyedListGet(interp, svObj->tclObj, key, &valObjPtr);
    if (ret == TCL_ERROR) {
	goto cmd_err;
    }

    if (ret == TCL_BREAK) {
	if (varObjPtr) {
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
	} else {
	    Tcl_AppendResult (interp, "key \"", key, "\" not found", (void *)NULL);
	    goto cmd_err;
	}
    } else {
	Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr);
	if (varObjPtr) {
	    Tcl_Size len;
	    Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
	    Tcl_GetStringFromObj(varObjPtr, &len);
	    if (len) {
		Tcl_ObjSetVar2(interp, varObjPtr, NULL, resObjPtr, 0);
	    }
	} else {
	    Tcl_SetObjResult(interp, resObjPtr);
	}
    }

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

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

static int
SvKeyldelObjCmd(
    void *arg,                         /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    Tcl_Size i, off;
    int ret;
    char *key;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          sv::keyldel array lkey key ?key ...?
     *          $keylist keyldel ?key ...?
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc < 1 + off) {
	Tcl_WrongNumArgs(interp, off, objv, "key ?key ...?");
	goto cmd_err;
    }
    for (i = off; i < objc; i++) {
	key = Tcl_GetString(objv[i]);
	ret = TclX_KeyedListDelete(interp, svObj->tclObj, key);
	if (ret == TCL_BREAK) {
	    Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL);
	}
	if (ret == TCL_BREAK || ret == TCL_ERROR) {
	    goto cmd_err;
	}
    }

    return Sv_PutContainer(interp, svObj, SV_CHANGED);

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

static int
SvKeylkeysObjCmd(
    void *arg,                         /* Not used. */
    Tcl_Interp *interp,                /* Current interpreter. */
    Tcl_Size objc,                          /* Number of arguments. */
    Tcl_Obj *const objv[]              /* Argument objects. */
) {
    int ret;
    Tcl_Size off;
    char *key = NULL;
    Tcl_Obj *listObj = NULL;
    Container *svObj = (Container*)arg;

    /*
     * Syntax:
     *          sv::keylkeys array lkey ?key?
     *          $keylist keylkeys ?key?
     */

    ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
    if (ret != TCL_OK) {
	return TCL_ERROR;
    }
    if (objc > 1 + off) {
	 Tcl_WrongNumArgs(interp, 1, objv, "?lkey?");
	 goto cmd_err;
    }
    if (objc == 1 + off) {
	key = Tcl_GetString(objv[off]);
    }

    ret = TclX_KeyedListGetKeys(interp, svObj->tclObj, key, &listObj);

    if (key && ret == TCL_BREAK) {
	Tcl_AppendResult(interp, "key \"", key, "\" not found", (void *)NULL);
    }
    if (ret == TCL_BREAK || ret == TCL_ERROR) {
	goto cmd_err;
    }

    Tcl_SetObjResult (interp, listObj); /* listObj allocated by API !*/

    return Sv_PutContainer(interp, svObj, SV_UNCHANGED);

 cmd_err:
    return Sv_PutContainer(interp, svObj, SV_ERROR);
}

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

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