350 lines
9.4 KiB
C
350 lines
9.4 KiB
C
/*
|
||
* 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_ObjCmdProc SvKeylsetObjCmd;
|
||
static Tcl_ObjCmdProc SvKeylgetObjCmd;
|
||
static Tcl_ObjCmdProc SvKeyldelObjCmd;
|
||
static Tcl_ObjCmdProc 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. */
|
||
int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[] /* Argument objects. */
|
||
) {
|
||
int i, off, ret, flg;
|
||
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 - off) < 2 || ((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. */
|
||
int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[] /* Argument objects. */
|
||
) {
|
||
int ret, flg, 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 - off) > 2) {
|
||
Tcl_WrongNumArgs(interp, off, objv, "?key? ?var?");
|
||
goto cmd_err;
|
||
}
|
||
if ((objc - off) == 0) {
|
||
if (Sv_PutContainer(interp, svObj, SV_UNCHANGED) != TCL_OK) {
|
||
return TCL_ERROR;
|
||
}
|
||
return SvKeylkeysObjCmd(arg, interp, objc, objv);
|
||
}
|
||
if ((objc - off) == 2) {
|
||
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", NULL);
|
||
goto cmd_err;
|
||
}
|
||
} else {
|
||
Tcl_Obj *resObjPtr = Sv_DuplicateObj(valObjPtr);
|
||
if (varObjPtr) {
|
||
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
|
||
Tcl_GetString(varObjPtr);
|
||
if (varObjPtr->length) {
|
||
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. */
|
||
int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[] /* Argument objects. */
|
||
) {
|
||
int i, off, 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 - off) < 1) {
|
||
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", 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. */
|
||
int objc, /* Number of arguments. */
|
||
Tcl_Obj *const objv[] /* Argument objects. */
|
||
) {
|
||
int ret, 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 - off) > 1) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "?lkey?");
|
||
goto cmd_err;
|
||
}
|
||
if ((objc - off) == 1) {
|
||
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", 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: */
|
||
|