/*
* This file implements a family of commands for sharing variables
* between threads.
*
* Initial code is taken from nsd/tclvar.c found in AOLserver 3.+
* distribution and modified to support Tcl 8.0+ command object interface
* and internal storage in private shared Tcl objects.
*
* 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.
*
* RCS: @(#) $Id: threadSvCmd.c,v 1.42 2006/08/06 10:01:13 vasiljevic Exp $
* ----------------------------------------------------------------------------
*/
#include "threadSvCmd.h"
#include "threadSvListCmd.h" /* Shared variants of list commands */
#include "threadSvKeylistCmd.h" /* Shared variants of list commands */
#include "psGdbm.h" /* The gdbm persistent store implementation */
#ifdef NS_AOLSERVER
# define HIDE_DOTNAMES /* tsv::names cmd does not list .<name> arrays */
#endif
/*
* Number of buckets to spread shared arrays into. Each bucket is
* associated with one mutex so locking a bucket locks all arrays
* in that bucket as well. The number of buckets should be a prime.
*/
#define NUMBUCKETS 31
/*
* Number of object containers
* to allocate in one shot.
*/
#define OBJS_TO_ALLOC_EACH_TIME 100
/*
* Reference to Tcl object types used in object-copy code.
* Those are referenced read-only, thus no mutex protection.
*/
static Tcl_ObjType* booleanObjTypePtr;
static Tcl_ObjType* byteArrayObjTypePtr;
static Tcl_ObjType* doubleObjTypePtr;
static Tcl_ObjType* intObjTypePtr;
static Tcl_ObjType* stringObjTypePtr;
/*
* In order to be fully stub enabled, a small
* hack is needed to query the tclEmptyStringRep
* global symbol defined by Tcl. See Sv_Init.
*/
char *Sv_tclEmptyStringRep = NULL;
/*
* Global variables used within this file.
*/
static Bucket* buckets; /* Array of buckets. */
static Tcl_Mutex bucketsMutex; /* Protects the array of buckets */
static SvCmdInfo* svCmdInfo; /* Linked list of registered commands */
static RegType* regType; /* Linked list of registered obj types */
static PsStore* psStore; /* Linked list of registered pers. stores */
static Tcl_Mutex svMutex; /* Protects inserts into above lists */
static Tcl_Mutex initMutex; /* Serializes initialization issues */
/*
* The standard commands found in AOLserver nsv_* interface.
* For sharp-eye readers: the implementaion of the "lappend" command
* is moved to new list-command package, since it realy belongs there.
*/
static Tcl_ObjCmdProc SvObjObjCmd;
static Tcl_ObjCmdProc SvAppendObjCmd;
static Tcl_ObjCmdProc SvIncrObjCmd;
static Tcl_ObjCmdProc SvSetObjCmd;
static Tcl_ObjCmdProc SvExistsObjCmd;
static Tcl_ObjCmdProc SvGetObjCmd;
static Tcl_ObjCmdProc SvArrayObjCmd;
static Tcl_ObjCmdProc SvUnsetObjCmd;
static Tcl_ObjCmdProc SvNamesObjCmd;
/*
* New commands added to
* standard set of nsv_*
*/
static Tcl_ObjCmdProc SvPopObjCmd;
static Tcl_ObjCmdProc SvMoveObjCmd;
static Tcl_ObjCmdProc SvLockObjCmd;
/*
* Forward declarations for functions to
* manage buckets, arrays and shared objects.
*/
static Container* CreateContainer(Array*, Tcl_HashEntry*, Tcl_Obj*);
static Container* AcquireContainer(Array*, char*, int);
static Array* CreateArray(Bucket*, char*);
static Array* LockArray(Tcl_Interp*, char*, int);
static int ReleaseContainer(Tcl_Interp*, Container*, int);
static int DeleteContainer(Container*);
static int FlushArray(Array*);
static int DeleteArray(Array*);
static void SvAllocateContainers(Bucket*);
static void SvFinalizeContainers(Bucket*);
static void SvRegisterStdCommands(void);
static void SvFinalize(ClientData);
static PsStore* GetPsStore(char *handle);
static int SvObjDispatchObjCmd _ANSI_ARGS_ ((ClientData arg,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterCommand --
*
* Utility to register commands to be loaded at module start.
*
* Results:
* None.
*
* Side effects;
* New command will be added to a linked list of registered commands.
*
*-----------------------------------------------------------------------------
*/
void
Sv_RegisterCommand(cmdName, objProc, delProc, clientData)
char *cmdName; /* Name of command to register */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure */
Tcl_CmdDeleteProc *delProc; /* Command delete procedure */
ClientData clientData; /* Private data ptr to pass to cmd */
{
int len = strlen(cmdName) + strlen(N);
SvCmdInfo *newCmd = (SvCmdInfo*)Tcl_Alloc(sizeof(SvCmdInfo) + len + 1);
/*
* Setup new command structure
*/
newCmd->cmdName = (char*)((char*)newCmd + sizeof(SvCmdInfo));
newCmd->objProcPtr = objProc;
newCmd->delProcPtr = delProc;
newCmd->clientData = clientData;
/*
* Rewrite command name. This is needed so we can
* easily turn-on the compatiblity with AOLserver
* command names.
*/
strcpy(newCmd->cmdName, N);
strcat(newCmd->cmdName, cmdName);
newCmd->name = newCmd->cmdName + strlen(N);
/*
* Plug-in in shared list of commands.
*/
Tcl_MutexLock(&svMutex);
if (svCmdInfo == NULL) {
svCmdInfo = newCmd;
newCmd->nextPtr = NULL;
} else {
newCmd->nextPtr = svCmdInfo;
svCmdInfo = newCmd;
}
Tcl_MutexUnlock(&svMutex);
return;
}
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterObjType --
*
* Registers custom object duplicator function for a specific
* object type. Registered function will be called by the
* private object creation routine every time an object is
* plugged out or in the shared array. This way we assure that
* Tcl objects do not get shared per-reference between threads.
*
* Results:
* None.
*
* Side effects;
* Memory gets allocated.
*
*-----------------------------------------------------------------------------
*/
void
Sv_RegisterObjType(typePtr, dupProc)
Tcl_ObjType *typePtr; /* Type of object to register */
Tcl_DupInternalRepProc *dupProc; /* Custom object duplicator */
{
RegType *newType = (RegType*)Tcl_Alloc(sizeof(RegType));
/*
* Setup new type structure
*/
newType->typePtr = typePtr;
newType->dupIntRepProc = dupProc;
/*
* Plug-in in shared list
*/
Tcl_MutexLock(&svMutex);
if (regType == NULL) {
regType = newType;
regType->nextPtr = NULL;
} else {
newType->nextPtr = regType;
regType = newType;
}
Tcl_MutexUnlock(&svMutex);
}
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterPsStore --
*
* Registers a handler to the persistent storage.
*
* Results:
* None.
*
* Side effects;
* Memory gets allocated.
*
*-----------------------------------------------------------------------------
*/
void
Sv_RegisterPsStore(psStorePtr)
PsStore *psStorePtr;
{
PsStore *psPtr = (PsStore*)Tcl_Alloc(sizeof(PsStore));
*psPtr = *psStorePtr;
/*
* Plug-in in shared list
*/
Tcl_MutexLock(&svMutex);
if (psStore == NULL) {
psStore = psPtr;
psStore->nextPtr = NULL;
} else {
psPtr->nextPtr = psStore;
psStore = psPtr;
}
Tcl_MutexUnlock(&svMutex);
}
/*
*-----------------------------------------------------------------------------
*
* Sv_GetContainer --
*
* This is the workhorse of the module. It returns the container
* with the shared Tcl object. It also locks the container, so
* when finished with operation on the Tcl object, one has to
* unlock the container by calling the Sv_PutContainer().
* If instructed, this command might also create new container
* with empty Tcl object.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* New container might be created.
*
*-----------------------------------------------------------------------------
*/
int
Sv_GetContainer(interp, objc, objv, retObj, offset, flags)
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments */
Tcl_Obj *CONST objv[]; /* Argument objects. */
Container **retObj; /* OUT: shared object container */
int *offset; /* Shift in argument list */
int flags; /* Options for locking shared array */
{
char *array, *key;
if (*retObj == NULL) {
Array *arrayPtr = NULL;
/*
* Parse mandatory arguments: <cmd> array key
*/
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "array key ?args?");
return TCL_ERROR;
}
array = Tcl_GetString(objv[1]);
key = Tcl_GetString(objv[2]);
*offset = 3; /* Consumed three arguments: cmd, array, key */
/*
* Lock the shared array and locate the shared object
*/
arrayPtr = LockArray(interp, array, flags);
if (arrayPtr == NULL) {
return TCL_BREAK;
}
*retObj = AcquireContainer(arrayPtr, Tcl_GetString(objv[2]), flags);
if (*retObj == NULL) {
UnlockArray(arrayPtr);
Tcl_AppendResult(interp, "no key ", array, "(", key, ")", NULL);
return TCL_BREAK;
}
} else {
Tcl_HashTable *handles = &((*retObj)->bucketPtr->handles);
LOCK_CONTAINER(*retObj);
if (Tcl_FindHashEntry(handles, (char*)(*retObj)) == NULL) {
UNLOCK_CONTAINER(*retObj);
Tcl_SetResult(interp, "key has been deleted", TCL_STATIC);
return TCL_BREAK;
}
*offset = 2; /* Consumed two arguments: object, cmd */
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* Sv_PutContainer --
*
* Releases the container obtained by the Sv_GetContainer.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* For bound arrays, update the underlying persistent storage.
*
*-----------------------------------------------------------------------------
*/
int
Sv_PutContainer(interp, svObj, mode)
Tcl_Interp *interp; /* For error reporting; might be NULL */
Container *svObj; /* Shared object container */
int mode; /* One of SV_XXX modes */
{
int ret;
ret = ReleaseContainer(interp, svObj, mode);
UnlockArray(svObj->arrayPtr);
return ret;
}
/*
*-----------------------------------------------------------------------------
*
* GetPsStore --
*
* Performs a lookup in the list of registered persistent storage
* handlers. If the match is found, duplicates the persistent
* storage record and passes the copy to the caller.
*
* Results:
* Pointer to the newly allocated persistent storage handler. Caller
* must free this block when done with it. If none found, returns NULL,
*
* Side effects;
* Memory gets allocated. Caller should free the return value of this
* function using Tcl_Free().
*
*-----------------------------------------------------------------------------
*/
static PsStore*
GetPsStore(char *handle)
{
int i;
char *type = handle, *addr, *delimiter = strchr(handle, ':');
PsStore *tmpPtr, *psPtr = NULL;
/*
* Expect the handle in the following format: <type>:<address>
* where "type" must match one of the registered presistent store
* types (gdbm, tcl, whatever) and <address> is what is passed to
* the open procedure of the registered store.
*
* Example: gdbm:/path/to/gdbm/file
*/
/*
* Try to see wether some array is already bound to the
* same persistent storage address.
*/
for (i = 0; i < NUMBUCKETS; i++) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
Bucket *bucketPtr = &buckets[i];
LOCK_BUCKET(bucketPtr);
hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
while (hPtr) {
Array *arrayPtr = (Array*)Tcl_GetHashValue(hPtr);
if (arrayPtr->bindAddr && arrayPtr->psPtr) {
if (strcmp(arrayPtr->bindAddr, handle) == 0) {
UNLOCK_BUCKET(bucketPtr);
return NULL; /* Array already bound */
}
}
hPtr = Tcl_NextHashEntry(&search);
}
UNLOCK_BUCKET(bucketPtr);
}
/*
* Split the address and storage handler
*/
if (delimiter == NULL) {
addr = NULL;
} else {
*delimiter = 0;
addr = delimiter + 1;
}
/*
* No array was bound to the same persistent storage.
* Lookup the persistent storage to bind to.
*/
Tcl_MutexLock(&svMutex);
for (tmpPtr = psStore; tmpPtr; tmpPtr = tmpPtr->nextPtr) {
if (strcmp(tmpPtr->type, type) == 0) {
tmpPtr->psHandle = (*tmpPtr->psOpen)(addr);
if (tmpPtr->psHandle) {
psPtr = (PsStore*)Tcl_Alloc(sizeof(PsStore));
*psPtr = *tmpPtr;
psPtr->nextPtr = NULL;
}
break;
}
}
Tcl_MutexUnlock(&svMutex);
if (delimiter) {
*delimiter = ':';
}
return psPtr;
}
/*
*-----------------------------------------------------------------------------
*
* AcquireContainer --
*
* Finds a variable within an array and returns it's container.
*
* Results:
* Pointer to variable object.
*
* Side effects;
* New variable may be created. For bound arrays, try to locate
* the key in the persistent storage as well.
*
*-----------------------------------------------------------------------------
*/
static Container *
AcquireContainer(arrayPtr, key, flags)
Array *arrayPtr;
char *key;
int flags;
{
int new;
Tcl_Obj *tclObj = NULL;
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);
if (hPtr == NULL) {
PsStore *psPtr = arrayPtr->psPtr;
if (psPtr) {
char *val = NULL;
int len = 0;
if ((*psPtr->psGet)(psPtr->psHandle, key, &val, &len) == 0) {
tclObj = Tcl_NewStringObj(val, len);
(*psPtr->psFree)(val);
}
}
if (!(flags & FLAGS_CREATEVAR) && tclObj == NULL) {
return NULL;
}
if (tclObj == NULL) {
tclObj = Tcl_NewObj();
}
hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
}
return (Container*)Tcl_GetHashValue(hPtr);
}
/*
*-----------------------------------------------------------------------------
*
* ReleaseContainer --
*
* Does some post-processing on the used container. This is mostly
* needed when the container has been modified and needs to be
* saved in the bound persistent storage.
*
* Results:
* A standard Tcl result
*
* Side effects:
* Persistent storage, if bound, might be modified.
*
*-----------------------------------------------------------------------------
*/
static int
ReleaseContainer(interp, svObj, mode)
Tcl_Interp *interp;
Container *svObj;
int mode;
{
PsStore *psPtr = svObj->arrayPtr->psPtr;
int len;
char *key, *val;
switch (mode) {
case SV_UNCHANGED: return TCL_OK;
case SV_ERROR: return TCL_ERROR;
case SV_CHANGED:
if (psPtr) {
key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
val = Tcl_GetStringFromObj(svObj->tclObj, &len);
if ((*psPtr->psPut)(psPtr->psHandle, key, val, len) == -1) {
char *err = (*psPtr->psError)(psPtr->psHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
return TCL_ERROR;
}
}
return TCL_OK;
}
return TCL_ERROR; /* Should never be reached */
}
/*
*-----------------------------------------------------------------------------
*
* CreateContainer --
*
* Creates new shared container holding Tcl object to be stored
* in the shared array
*
* Results:
* The container pointer.
*
* Side effects:
* Memory gets allocated.
*
*-----------------------------------------------------------------------------
*/
static Container *
CreateContainer(arrayPtr, entryPtr, tclObj)
Array *arrayPtr;
Tcl_HashEntry *entryPtr;
Tcl_Obj *tclObj;
{
Container *svObj;
if (arrayPtr->bucketPtr->freeCt == NULL) {
SvAllocateContainers(arrayPtr->bucketPtr);
}
svObj = arrayPtr->bucketPtr->freeCt;
arrayPtr->bucketPtr->freeCt = svObj->nextPtr;
svObj->arrayPtr = arrayPtr;
svObj->bucketPtr = arrayPtr->bucketPtr;
svObj->tclObj = tclObj;
svObj->entryPtr = entryPtr;
svObj->handlePtr = NULL;
if (svObj->tclObj) {
Tcl_IncrRefCount(svObj->tclObj);
}
return svObj;
}
/*
*-----------------------------------------------------------------------------
*
* DeleteContainer --
*
* Destroys the container and the Tcl object within it. For bound
* shared arrays, the underlying persistent store is updated as well.
*
* Results:
* None.
*
* Side effects:
* Memory gets reclaimed. If the shared array was bound to persistent
* storage, it removes the corresponding record.
*
*-----------------------------------------------------------------------------
*/
static int
DeleteContainer(svObj)
Container *svObj;
{
if (svObj->tclObj) {
Tcl_DecrRefCount(svObj->tclObj);
}
if (svObj->handlePtr) {
Tcl_DeleteHashEntry(svObj->handlePtr);
}
if (svObj->entryPtr) {
PsStore *psPtr = svObj->arrayPtr->psPtr;
if (psPtr) {
char *key = Tcl_GetHashKey(&svObj->arrayPtr->vars,svObj->entryPtr);
if ((*psPtr->psDelete)(psPtr->psHandle, key) == -1) {
return TCL_ERROR;
}
}
Tcl_DeleteHashEntry(svObj->entryPtr);
}
svObj->arrayPtr = NULL;
svObj->entryPtr = NULL;
svObj->handlePtr = NULL;
svObj->tclObj = NULL;
svObj->nextPtr = svObj->bucketPtr->freeCt;
svObj->bucketPtr->freeCt = svObj;
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* LockArray --
*
* Find (or create) the array structure for shared array and lock it.
* Array structure must be later unlocked with UnlockArray.
*
* Results:
* TCL_OK or TCL_ERROR if no such array.
*
* Side effects:
* Sets *arrayPtrPtr with Array pointer or leave error in given interp.
*
*-----------------------------------------------------------------------------
*/
static Array *
LockArray(interp, array, flags)
Tcl_Interp *interp; /* Interpreter to leave result. */
char *array; /* Name of array to lock */
int flags; /* FLAGS_CREATEARRAY/FLAGS_NOERRMSG*/
{
register char *p;
register unsigned int result;
register int i;
Bucket *bucketPtr;
Array *arrayPtr;
/*
* Compute a hash to map an array to a bucket.
*/
p = array;
result = 0;
while (*p++) {
i = *p;
result += (result << 3) + i;
}
i = result % NUMBUCKETS;
bucketPtr = &buckets[i];
/*
* Lock the bucket and find the array, or create a new one.
* The bucket will be left locked on success.
*/
LOCK_BUCKET(bucketPtr); /* Note: no matching unlock below ! */
if (flags & FLAGS_CREATEARRAY) {
arrayPtr = CreateArray(bucketPtr, array);
} else {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&bucketPtr->arrays, array);
if (hPtr == NULL) {
UNLOCK_BUCKET(bucketPtr);
if (!(flags & FLAGS_NOERRMSG)) {
Tcl_AppendResult(interp, "\"", array,
"\" is not a thread shared array", NULL);
}
return NULL;
}
arrayPtr = (Array*)Tcl_GetHashValue(hPtr);
}
return arrayPtr;
}
/*
*-----------------------------------------------------------------------------
*
* FlushArray --
*
* Unset all keys in an array.
*
* Results:
* None.
*
* Side effects:
* Array is cleaned but it's variable hash-hable still lives.
* For bound arrays, the persistent store is updated accordingly.
*
*-----------------------------------------------------------------------------
*/
static int
FlushArray(arrayPtr)
Array *arrayPtr; /* Name of array to flush */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
for (hPtr = Tcl_FirstHashEntry(&arrayPtr->vars, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr)) != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CreateArray --
*
* Creates new shared array instance.
*
* Results:
* Pointer to the newly created array
*
* Side effects:
* Memory gets allocated
*
*-----------------------------------------------------------------------------
*/
static Array *
CreateArray(bucketPtr, arrayName)
Bucket *bucketPtr;
char *arrayName;
{
int new;
Array *arrayPtr;
Tcl_HashEntry *hPtr;
hPtr = Tcl_CreateHashEntry(&bucketPtr->arrays, arrayName, &new);
if (!new) {
return (Array*)Tcl_GetHashValue(hPtr);
}
arrayPtr = (Array*)Tcl_Alloc(sizeof(Array));
arrayPtr->bucketPtr = bucketPtr;
arrayPtr->entryPtr = hPtr;
arrayPtr->psPtr = NULL;
arrayPtr->bindAddr = NULL;
Tcl_InitHashTable(&arrayPtr->vars, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, arrayPtr);
return arrayPtr;
}
/*
*-----------------------------------------------------------------------------
*
* DeleteArray --
*
* Deletes the shared array.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Memory gets reclaimed.
*
*-----------------------------------------------------------------------------
*/
static int
DeleteArray(arrayPtr)
Array *arrayPtr;
{
if (FlushArray(arrayPtr) == -1) {
return TCL_ERROR;
}
if (arrayPtr->psPtr) {
PsStore *psPtr = arrayPtr->psPtr;
if ((*psPtr->psClose)(psPtr->psHandle) == -1) {
return TCL_ERROR;
}
Tcl_Free((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
}
if (arrayPtr->bindAddr) {
Tcl_Free(arrayPtr->bindAddr);
}
if (arrayPtr->entryPtr) {
Tcl_DeleteHashEntry(arrayPtr->entryPtr);
}
Tcl_DeleteHashTable(&arrayPtr->vars);
Tcl_Free((char*)arrayPtr);
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* SvAllocateContainers --
*
* Any similarity with the Tcl AllocateFreeObj function is purely
* coincidental... Just joking; this is (almost) 100% copy of it! :-)
*
* Results:
* None.
*
* Side effects:
* Allocates memory for many containers at the same time
*
*-----------------------------------------------------------------------------
*/
static void
SvAllocateContainers(bucketPtr)
Bucket *bucketPtr;
{
Container tmp[2];
size_t objSizePlusPadding = (size_t)(((char*)(tmp+1))-(char*)tmp);
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
char *basePtr;
register Container *prevPtr = NULL, *objPtr = NULL;
register int i;
basePtr = (char*)Tcl_Alloc(bytesToAlloc);
memset(basePtr, 0, bytesToAlloc);
objPtr = (Container*)basePtr;
objPtr->chunkAddr = basePtr; /* Mark chunk address for reclaim */
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->nextPtr = prevPtr;
prevPtr = objPtr;
objPtr = (Container*)(((char*)objPtr) + objSizePlusPadding);
}
bucketPtr->freeCt = prevPtr;
}
/*
*-----------------------------------------------------------------------------
*
* SvFinalizeContainers --
*
* Reclaim memory for free object containers per bucket.
*
* Results:
* None.
*
* Side effects:
* Memory gets reclaimed
*
*-----------------------------------------------------------------------------
*/
static void
SvFinalizeContainers(bucketPtr)
Bucket *bucketPtr;
{
Container *tmpPtr, *objPtr = bucketPtr->freeCt;
while (objPtr) {
if (objPtr->chunkAddr == (char*)objPtr) {
tmpPtr = objPtr->nextPtr;
Tcl_Free((char*)objPtr);
objPtr = tmpPtr;
} else {
objPtr = objPtr->nextPtr;
}
}
}
/*
*-----------------------------------------------------------------------------
*
* Sv_DuplicateObj --
*
* Create and return a new object that is (mostly) a duplicate of the
* argument object. We take care that the duplicate object is either
* a proper object copy, i.e. w/o hidden references to original object
* elements or a plain string object, i.e one w/o internal representation.
*
* Decision about wether to produce a real duplicate or a string object
* is done as follows:
*
* 1) Scalar Tcl object types are properly copied by default;
* these include: boolean, int double, string and byteArray types.
* 2) Object registered with Sv_RegisterObjType are duplicated
* using custom duplicator function which is guaranteed to
* produce a proper deep copy of the object in question.
* 3) All other object types are stringified; these include
* miscelaneous Tcl objects (cmdName, nsName, bytecode, etc, etc)
* and all user-defined objects.
*
* Results:
* The return value is a pointer to a newly created Tcl_Obj. This
* object has reference count 0 and the same type, if any, as the
* source object objPtr. Also:
*
* 1) If the source object has a valid string rep, we copy it;
* otherwise, the new string rep is marked invalid.
* 2) If the source object has an internal representation (i.e. its
* typePtr is non-NULL), the new object's internal rep is set to
* a copy; otherwise the new internal rep is marked invalid.
*
* Side effects:
* Some object may, when copied, loose their type, i.e. will become
* just plain string objects.
*
*-----------------------------------------------------------------------------
*/
Tcl_Obj *
Sv_DuplicateObj(objPtr)
register Tcl_Obj *objPtr; /* The object to duplicate. */
{
register Tcl_Obj *dupPtr = Tcl_NewObj();
/*
* Handle the internal rep
*/
if (objPtr->typePtr != NULL) {
if (objPtr->typePtr->dupIntRepProc == NULL) {
dupPtr->internalRep = objPtr->internalRep;
dupPtr->typePtr = objPtr->typePtr;
Tcl_InvalidateStringRep(dupPtr);
} else {
if ( objPtr->typePtr == booleanObjTypePtr \
|| objPtr->typePtr == byteArrayObjTypePtr \
|| objPtr->typePtr == doubleObjTypePtr \
|| objPtr->typePtr == intObjTypePtr \
|| objPtr->typePtr == stringObjTypePtr) {
/*
* Cover all "safe" obj types (see header comment)
*/
(*objPtr->typePtr->dupIntRepProc)(objPtr, dupPtr);
Tcl_InvalidateStringRep(dupPtr);
} else {
int found = 0;
register RegType *regPtr;
/*
* Cover special registered types. Assume not
* very many of those, so this sequential walk
* should be fast enough.
*/
for (regPtr = regType; regPtr; regPtr = regPtr->nextPtr) {
if (objPtr->typePtr == regPtr->typePtr) {
(*regPtr->dupIntRepProc)(objPtr, dupPtr);
Tcl_InvalidateStringRep(dupPtr);
found = 1;
break;
}
}
/*
* Assure at least string rep of the source
* is present, which will be copied below.
*/
if (found == 0 && objPtr->bytes == NULL
&& objPtr->typePtr->updateStringProc != NULL) {
(*objPtr->typePtr->updateStringProc)(objPtr);
}
}
}
}
/*
* Handle the string rep
*/
if (objPtr->bytes == NULL) {
dupPtr->bytes = NULL;
} else if (objPtr->bytes != Sv_tclEmptyStringRep) {
/* A copy of TclInitStringRep macro */
dupPtr->bytes = (char*)Tcl_Alloc((unsigned)objPtr->length + 1);
if (objPtr->length > 0) {
memcpy((void*)dupPtr->bytes,(void*)objPtr->bytes,
(unsigned)objPtr->length);
}
dupPtr->length = objPtr->length;
dupPtr->bytes[objPtr->length] = '\0';
}
return dupPtr;
}
/*
*-----------------------------------------------------------------------------
*
* SvObjDispatchObjCmd --
*
* The method command for dispatching sub-commands of the shared
* object.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Depends on the dispatched command
*
*-----------------------------------------------------------------------------
*/
static int
SvObjDispatchObjCmd(arg, interp, objc, objv)
ClientData arg; /* Just passed to the command. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *cmdName;
SvCmdInfo *cmdPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "args");
return TCL_ERROR;
}
cmdName = Tcl_GetString(objv[1]);
/*
* Do simple linear search. We may later replace this list
* with the hash table to gain speed. Currently, the list
* of registered commands is so small, so this will work
* fast enough.
*/
for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
if (!strcmp(cmdPtr->name, cmdName)) {
return (*cmdPtr->objProcPtr)(arg, interp, objc, objv);
}
}
Tcl_AppendResult(interp, "invalid command name \"", cmdName, "\"", NULL);
return TCL_ERROR;
}
/*
*-----------------------------------------------------------------------------
*
* SvObjObjCmd --
*
* Creates the object command for a shared array.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* New Tcl command gets created.
*
*-----------------------------------------------------------------------------
*/
static int
SvObjObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int new, off, ret, flg;
char buf[128];
Tcl_Obj *val = NULL;
Container *svObj = NULL;
/*
* Syntax: sv::object array key ?var?
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
switch (ret) {
case TCL_BREAK: /* Shared array was not found */
if ((objc - off)) {
val = objv[off];
}
Tcl_ResetResult(interp);
flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
if (ret != TCL_OK) {
return TCL_ERROR;
}
Tcl_DecrRefCount(svObj->tclObj);
svObj->tclObj = Sv_DuplicateObj(val ? val : Tcl_NewObj());
Tcl_IncrRefCount(svObj->tclObj);
break;
case TCL_ERROR:
return TCL_ERROR;
}
if (svObj->handlePtr == NULL) {
Tcl_HashTable *handles = &svObj->arrayPtr->bucketPtr->handles;
svObj->handlePtr = Tcl_CreateHashEntry(handles, (char*)svObj, &new);
}
/*
* Format the command name
*/
sprintf(buf, "::%p", (int*)svObj);
Tcl_CreateObjCommand(interp, buf, SvObjDispatchObjCmd, (int*)svObj, NULL);
Tcl_ResetResult(interp);
Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1);
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
}
/*
*-----------------------------------------------------------------------------
*
* SvArrayObjCmd --
*
* This procedure is invoked to process the "tsv::array" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvArrayObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, argx = 0, lobjc = 0, index, ret = TCL_OK;
char *arrayName = NULL;
Array *arrayPtr = NULL;
Tcl_Obj **lobjv = NULL;
Container *svObj, *elObj = NULL;
static const char *opts[] = {
"set", "reset", "get", "names", "size", "exists", "isbound",
"bind", "unbind", NULL
};
enum options {
ASET, ARESET, AGET, ANAMES, ASIZE, AEXISTS, AISBOUND,
ABIND, AUNBIND
};
svObj = (Container*)arg;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option array");
return TCL_ERROR;
}
arrayName = Tcl_GetString(objv[2]);
arrayPtr = LockArray(interp, arrayName, FLAGS_NOERRMSG);
if (objc > 3) {
argx = 3;
}
Tcl_ResetResult(interp);
if (Tcl_GetIndexFromObj(interp,objv[1],opts,"option",0,&index) != TCL_OK) {
ret = TCL_ERROR;
} else if (index == AEXISTS) {
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), arrayPtr ? 1 : 0);
} else if (index == AISBOUND) {
if (arrayPtr == NULL) {
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0);
} else {
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), arrayPtr->psPtr ? 1:0);
}
} else if (index == ASIZE) {
if (arrayPtr == NULL) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
} else {
Tcl_SetLongObj(Tcl_GetObjResult(interp),arrayPtr->vars.numEntries);
}
} else if (index == ASET || index == ARESET) {
if (argx == (objc - 1)) {
if (argx && Tcl_ListObjGetElements(interp, objv[argx], &lobjc,
&lobjv) != TCL_OK) {
ret = TCL_ERROR;
goto cmdExit;
}
} else {
lobjc = objc - 3;
lobjv = (Tcl_Obj**)objv + 3;
}
if (lobjc & 1) {
Tcl_AppendResult(interp, "list must have an even number"
" of elements", NULL);
ret = TCL_ERROR;
goto cmdExit;
}
if (arrayPtr == NULL) {
arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
}
if (index == ARESET) {
ret = FlushArray(arrayPtr);
if (ret != TCL_OK) {
if (arrayPtr->psPtr) {
PsStore *psPtr = arrayPtr->psPtr;
char *err = (*psPtr->psError)(psPtr->psHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
}
goto cmdExit;
}
}
for (i = 0; i < lobjc; i += 2) {
char *key = Tcl_GetString(lobjv[i]);
elObj = AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR);
Tcl_DecrRefCount(elObj->tclObj);
elObj->tclObj = Sv_DuplicateObj(lobjv[i+1]);
Tcl_IncrRefCount(elObj->tclObj);
if (ReleaseContainer(interp, elObj, SV_CHANGED) != TCL_OK) {
ret = TCL_ERROR;
goto cmdExit;
}
}
} else if (index == AGET || index == ANAMES) {
if (arrayPtr) {
Tcl_HashSearch search;
Tcl_Obj *resObj = Tcl_NewListObj(0, NULL);
char *pattern = (argx == 0) ? NULL : Tcl_GetString(objv[argx]);
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
while (hPtr) {
char *key = Tcl_GetHashKey(&arrayPtr->vars, hPtr);
if (pattern == NULL || Tcl_StringMatch(key, pattern)) {
Tcl_ListObjAppendElement(interp, resObj,
Tcl_NewStringObj(key, -1));
if (index == AGET) {
elObj = (Container*)Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(interp, resObj,
Sv_DuplicateObj(elObj->tclObj));
}
}
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_SetObjResult(interp, resObj);
}
} else if (index == ABIND) {
/*
* This is more complex operation, requiring some clarification.
*
* When binding an already existing array, we walk the array
* first and store all key/value pairs found there in the
* persistent storage. Then we proceed with the below.
*
* When binding an non-existent array, we open the persistent
* storage and cache all key/value pairs found there into tne
* newly created shared array.
*/
PsStore *psPtr;
int len;
char *psurl, *key = NULL, *val = NULL;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "array handle");
ret = TCL_ERROR;
goto cmdExit;
}
if (arrayPtr && arrayPtr->psPtr) {
Tcl_AppendResult(interp, "array is already bound", NULL);
ret = TCL_ERROR;
goto cmdExit;
}
psurl = Tcl_GetStringFromObj(objv[3], &len);
psPtr = GetPsStore(psurl);
if (psPtr == NULL) {
Tcl_AppendResult(interp, "can't open persistent storage on \"",
psurl, "\"", NULL);
ret = TCL_ERROR;
goto cmdExit;
}
if (arrayPtr) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(&arrayPtr->vars,&search);
arrayPtr->psPtr = psPtr;
arrayPtr->bindAddr = strcpy(Tcl_Alloc(len+1), psurl);
while (hPtr) {
svObj = Tcl_GetHashValue(hPtr);
if (ReleaseContainer(interp, svObj, SV_CHANGED) != TCL_OK) {
ret = TCL_ERROR;
goto cmdExit;
}
hPtr = Tcl_NextHashEntry(&search);
}
} else {
arrayPtr = LockArray(interp, arrayName, FLAGS_CREATEARRAY);
arrayPtr->psPtr = psPtr;
arrayPtr->bindAddr = strcpy(Tcl_Alloc(len+1), psurl);
}
if (!(*psPtr->psFirst)(psPtr->psHandle, &key, &val, &len)) {
do {
(*psPtr->psFree)(val); /* What a waste! */
AcquireContainer(arrayPtr, key, FLAGS_CREATEVAR);
} while (!(*psPtr->psNext)(psPtr->psHandle, &key, &val, &len));
}
} else if (index == AUNBIND) {
if (arrayPtr && arrayPtr->psPtr) {
PsStore *psPtr = arrayPtr->psPtr;
if ((*psPtr->psClose)(psPtr->psHandle) == -1) {
char *err = (*psPtr->psError)(psPtr->psHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
ret = TCL_ERROR;
goto cmdExit;
}
Tcl_Free((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
} else {
Tcl_AppendResult(interp, "shared variable is not bound", NULL);
ret = TCL_ERROR;
goto cmdExit;
}
}
cmdExit:
if (arrayPtr) {
UnlockArray(arrayPtr);
}
return ret;
}
/*
*-----------------------------------------------------------------------------
*
* SvUnsetObjCmd --
*
* This procedure is invoked to process the "tsv::unset" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvUnsetObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ii;
char *arrayName;
Array *arrayPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "array ?key ...?");
return TCL_ERROR;
}
arrayName = Tcl_GetString(objv[1]);
arrayPtr = LockArray(interp, arrayName, 0);
if (arrayPtr == NULL) {
return TCL_ERROR;
}
if (objc == 2) {
UnlockArray(arrayPtr);
if (DeleteArray(arrayPtr) != TCL_OK) {
return TCL_ERROR;
}
} else {
for (ii = 2; ii < objc; ii++) {
char *key = Tcl_GetString(objv[ii]);
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);
if (hPtr) {
if (DeleteContainer((Container*)Tcl_GetHashValue(hPtr))
!= TCL_OK) {
UnlockArray(arrayPtr);
return TCL_ERROR;
}
} else {
UnlockArray(arrayPtr);
Tcl_AppendResult(interp,"no key ",arrayName,"(",key,")",NULL);
return TCL_ERROR;
}
}
UnlockArray(arrayPtr);
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* SvNamesObjCmd --
*
* This procedure is invoked to process the "tsv::names" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvNamesObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, len;
char *pattern = NULL;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_Obj *resObj;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
return TCL_ERROR;
}
if (objc == 2) {
pattern = Tcl_GetStringFromObj(objv[1], &len);
}
resObj = Tcl_NewListObj(0, NULL);
for (i = 0; i < NUMBUCKETS; i++) {
Bucket *bucketPtr = &buckets[i];
LOCK_BUCKET(bucketPtr);
hPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
while (hPtr) {
char *key = Tcl_GetHashKey(&bucketPtr->arrays, hPtr);
#ifdef HIDE_DOTNAMES
if (*key != '.' /* Hide .<name> arrays */ &&
#else
if (1 &&
#endif
(pattern == NULL || Tcl_StringMatch(key, pattern))) {
Tcl_ListObjAppendElement(interp, resObj,
Tcl_NewStringObj(key, -1));
}
hPtr = Tcl_NextHashEntry(&search);
}
UNLOCK_BUCKET(bucketPtr);
}
Tcl_SetObjResult(interp, resObj);
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* SvGetObjCmd --
*
* This procedure is invoked to process "tsv::get" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvGetObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int off, ret;
Tcl_Obj *res;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::get array key ?var?
* $object get ?var?
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
switch (ret) {
case TCL_BREAK:
if ((objc - off) == 0) {
return TCL_ERROR;
} else {
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
return TCL_OK;
}
case TCL_ERROR:
return TCL_ERROR;
}
res = Sv_DuplicateObj(svObj->tclObj);
if ((objc - off) == 0) {
Tcl_SetObjResult(interp, res);
} else {
if (Tcl_ObjSetVar2(interp, objv[off], NULL, res, 0) == NULL) {
Tcl_DecrRefCount(res);
goto cmd_err;
}
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
}
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*-----------------------------------------------------------------------------
*
* SvExistsObjCmd --
*
* This procedure is invoked to process "tsv::exists" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvExistsObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int off, ret;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::exists array key
* $object exists
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
switch (ret) {
case TCL_BREAK: /* Array/key not found */
Tcl_ResetResult(interp);
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 0);
return TCL_OK;
case TCL_ERROR:
return TCL_ERROR;
}
Tcl_ResetResult(interp);
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), 1);
return Sv_PutContainer(interp, svObj, SV_UNCHANGED);
}
/*
*-----------------------------------------------------------------------------
*
* SvSetObjCmd --
*
* This procedure is invoked to process the "tsv::set" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvSetObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ret, off, flg, mode;
Tcl_Obj *val;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::set array key ?value?
* $object set ?value?
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
switch (ret) {
case TCL_BREAK:
if ((objc - off) == 0) {
return TCL_ERROR;
} else {
Tcl_ResetResult(interp);
flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
if (ret != TCL_OK) {
return TCL_ERROR;
}
}
break;
case TCL_ERROR:
return TCL_ERROR;
}
if ((objc - off)) {
val = objv[off];
Tcl_DecrRefCount(svObj->tclObj);
svObj->tclObj = Sv_DuplicateObj(val);
Tcl_IncrRefCount(svObj->tclObj);
mode = SV_CHANGED;
} else {
val = Sv_DuplicateObj(svObj->tclObj);
mode = SV_UNCHANGED;
}
Tcl_SetObjResult(interp, val);
return Sv_PutContainer(interp, svObj, mode);
}
/*
*-----------------------------------------------------------------------------
*
* SvIncrObjCmd --
*
* This procedure is invoked to process the "tsv::incr" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvIncrObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int off, ret, flg, new = 0;
long incrValue = 1, currValue = 0;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::incr array key ?increment?
* $object incr ?increment?
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
if (ret != TCL_OK) {
if (ret != TCL_BREAK) {
return TCL_ERROR;
}
flg = FLAGS_CREATEARRAY | FLAGS_CREATEVAR;
Tcl_ResetResult(interp);
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, flg);
if (ret != TCL_OK) {
return TCL_ERROR;
}
new = 1;
}
if ((objc - off)) {
ret = Tcl_GetLongFromObj(interp, objv[off], &incrValue);
if (ret != TCL_OK) {
goto cmd_err;
}
}
if (new) {
currValue = 0;
} else {
ret = Tcl_GetLongFromObj(interp, svObj->tclObj, &currValue);
if (ret != TCL_OK) {
goto cmd_err;
}
}
incrValue += currValue;
Tcl_SetLongObj(svObj->tclObj, incrValue);
Tcl_ResetResult(interp);
Tcl_SetLongObj(Tcl_GetObjResult(interp), incrValue);
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*-----------------------------------------------------------------------------
*
* SvAppendObjCmd --
*
* This procedure is invoked to process the "tsv::append" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvAppendObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, off, flg, ret;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::append array key value ?value ...?
* $object append 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) {
Tcl_AppendObjToObj(svObj->tclObj, Sv_DuplicateObj(objv[i]));
}
Tcl_SetObjResult(interp, Sv_DuplicateObj(svObj->tclObj));
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*-----------------------------------------------------------------------------
*
* SvPopObjCmd --
*
* This procedure is invoked to process "tsv::pop" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvPopObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ret, off;
Tcl_Obj *retObj;
Array *arrayPtr = NULL;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::pop array key ?var?
* $object pop ?var?
*
* Note: the object command will run into error next time !
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
switch (ret) {
case TCL_BREAK:
if ((objc - off) == 0) {
return TCL_ERROR;
} else {
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
return TCL_OK;
}
case TCL_ERROR:
return TCL_ERROR;
}
arrayPtr = svObj->arrayPtr;
retObj = svObj->tclObj;
svObj->tclObj = NULL;
if (DeleteContainer(svObj) != TCL_OK) {
if (svObj->arrayPtr->psPtr) {
PsStore *psPtr = svObj->arrayPtr->psPtr;
char *err = (*psPtr->psError)(psPtr->psHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(err,-1));
}
ret = TCL_ERROR;
goto cmd_exit;
}
if ((objc - off) == 0) {
Tcl_SetObjResult(interp, retObj);
} else {
if (Tcl_ObjSetVar2(interp, objv[off], NULL, retObj, 0) == NULL) {
ret = TCL_ERROR;
goto cmd_exit;
}
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
}
cmd_exit:
Tcl_DecrRefCount(retObj);
UnlockArray(arrayPtr);
return ret;
}
/*
*-----------------------------------------------------------------------------
*
* SvMoveObjCmd --
*
* This procedure is invoked to process the "tsv::move" command.
* See the user documentation for details on what it does.
*
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*-----------------------------------------------------------------------------
*/
static int
SvMoveObjCmd(arg, interp, objc, objv)
ClientData arg; /* Pointer to object container. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ret, off, new;
char *toKey;
Tcl_HashEntry *hPtr;
Container *svObj = (Container*)arg;
/*
* Syntax:
* tsv::move array key to
* $object move to
*/
ret = Sv_GetContainer(interp, objc, objv, &svObj, &off, 0);
if (ret != TCL_OK) {
return TCL_ERROR;
}
toKey = Tcl_GetString(objv[off]);
hPtr = Tcl_CreateHashEntry(&svObj->arrayPtr->vars, toKey, &new);
if (!new) {
Tcl_AppendResult(interp, "key \"", toKey, "\" exists", NULL);
goto cmd_err;
}
if (svObj->entryPtr) {
char *key = Tcl_GetHashKey(&svObj->arrayPtr->vars, svObj->entryPtr);
if (svObj->arrayPtr->psPtr) {
PsStore *psPtr = svObj->arrayPtr->psPtr;
if ((*psPtr->psDelete)(psPtr->psHandle, key) == -1) {
char *err = (*psPtr->psError)(psPtr->psHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
return TCL_ERROR;
}
}
Tcl_DeleteHashEntry(svObj->entryPtr);
}
svObj->entryPtr = hPtr;
Tcl_SetHashValue(hPtr, svObj);
return Sv_PutContainer(interp, svObj, SV_CHANGED);
cmd_err:
return Sv_PutContainer(interp, svObj, SV_ERROR);
}
/*
*----------------------------------------------------------------------
*
* SvLockObjCmd --
*
* This procedure is invoked to process "tsv::lock" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
SvLockObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ret;
Tcl_Obj *scriptObj;
Bucket *bucketPtr;
Array *arrayPtr = NULL;
/*
* Syntax:
*
* tsv::lock array arg ?arg ...?
*/
if (objc < 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
Tcl_GetString(objv[0]), "array arg ?arg...?\"", NULL);
return TCL_ERROR;
}
arrayPtr = LockArray(interp, Tcl_GetString(objv[1]), FLAGS_CREATEARRAY);
bucketPtr = arrayPtr->bucketPtr;
/*
* Evaluate passed arguments as Tcl script. Note that
* Tcl_EvalObjEx throws away the passed object by
* doing an decrement reference count on it. This also
* means we need not build object bytecode rep.
*/
if (objc == 3) {
scriptObj = Tcl_DuplicateObj(objv[2]);
} else {
scriptObj = Tcl_ConcatObj(objc-2, objv + 2);
}
Tcl_AllowExceptions(interp);
ret = Tcl_EvalObjEx(interp, scriptObj, TCL_EVAL_DIRECT);
if (ret == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
/*
* We unlock the bucket directly, w/o going to Sv_Unlock()
* since it needs the array which may be unset by the script.
*/
UNLOCK_BUCKET(bucketPtr);
return ret;
}
/*
*-----------------------------------------------------------------------------
*
* Sv_RegisterStdCommands --
*
* Register standard shared variable commands
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Memory gets allocated
*
*-----------------------------------------------------------------------------
*/
static void
SvRegisterStdCommands(void)
{
static int initialized = 0;
if (initialized == 0) {
Tcl_MutexLock(&initMutex);
if (initialized == 0) {
Sv_RegisterCommand("var", SvObjObjCmd, NULL, NULL);
Sv_RegisterCommand("object", SvObjObjCmd, NULL, NULL);
Sv_RegisterCommand("set", SvSetObjCmd, NULL, NULL);
Sv_RegisterCommand("unset", SvUnsetObjCmd, NULL, NULL);
Sv_RegisterCommand("get", SvGetObjCmd, NULL, NULL);
Sv_RegisterCommand("incr", SvIncrObjCmd, NULL, NULL);
Sv_RegisterCommand("exists", SvExistsObjCmd, NULL, NULL);
Sv_RegisterCommand("append", SvAppendObjCmd, NULL, NULL);
Sv_RegisterCommand("array", SvArrayObjCmd, NULL, NULL);
Sv_RegisterCommand("names", SvNamesObjCmd, NULL, NULL);
Sv_RegisterCommand("pop", SvPopObjCmd, NULL, NULL);
Sv_RegisterCommand("move", SvMoveObjCmd, NULL, NULL);
Sv_RegisterCommand("lock", SvLockObjCmd, NULL, NULL);
initialized = 1;
}
Tcl_MutexUnlock(&initMutex);
}
}
/*
*-----------------------------------------------------------------------------
*
* Sv_Init --
*
* Creates commands in current interpreter.
*
* Results:
* None.
*
* Side effects
* Many new command created in current interpreter. Global data
* structures used by them initialized as well.
*
*-----------------------------------------------------------------------------
*/
int
Sv_Init (interp)
Tcl_Interp *interp;
{
register int i;
Bucket *bucketPtr;
SvCmdInfo *cmdPtr;
/*
* Add keyed-list datatype
*/
TclX_KeyedListInit(interp);
Sv_RegisterKeylistCommands();
/*
* Register standard (nsv_* compatible) and our
* own extensive set of list manipulating commands
*/
SvRegisterStdCommands();
Sv_RegisterListCommands();
/*
* Get Tcl object types. These are used
* in custom object duplicator function.
*/
booleanObjTypePtr = Tcl_GetObjType("boolean");
byteArrayObjTypePtr = Tcl_GetObjType("bytearray");
doubleObjTypePtr = Tcl_GetObjType("double");
intObjTypePtr = Tcl_GetObjType("int");
stringObjTypePtr = Tcl_GetObjType("string");
#ifdef HAVE_GDBM
/*
* Register persistent store handlers
*/
Sv_RegisterGdbmStore();
#endif
/*
* Plug-in registered commands in current interpreter
*/
for (cmdPtr = svCmdInfo; cmdPtr; cmdPtr = cmdPtr->nextPtr) {
Tcl_CreateObjCommand(interp, cmdPtr->cmdName, cmdPtr->objProcPtr,
(ClientData)cmdPtr->clientData, (Tcl_CmdDeleteProc*)0);
}
/*
* Create array of buckets and initialize each bucket
*/
if (buckets == NULL) {
Tcl_MutexLock(&bucketsMutex);
if (buckets == NULL) {
buckets = (Bucket *)Tcl_Alloc(sizeof(Bucket) * NUMBUCKETS);
for (i = 0; i < NUMBUCKETS; ++i) {
bucketPtr = &buckets[i];
memset(bucketPtr, 0, sizeof(Bucket));
Tcl_InitHashTable(&bucketPtr->arrays, TCL_STRING_KEYS);
Tcl_InitHashTable(&bucketPtr->handles, TCL_ONE_WORD_KEYS);
}
/*
* There is no other way to get Sv_tclEmptyStringRep
* pointer value w/o this trick.
*/
{
Tcl_Obj *dummy = Tcl_NewObj();
Sv_tclEmptyStringRep = dummy->bytes;
Tcl_DecrRefCount(dummy);
}
}
Tcl_MutexUnlock(&bucketsMutex);
}
return TCL_OK;
}
int Sv_SafeInit (interp)
Tcl_Interp *interp;
{
return (Sv_Init(interp));
}
/*
*-----------------------------------------------------------------------------
*
* SvFinalize --
*
* Unset all arrays and reclaim all buckets.
*
* Results:
* None.
*
* Side effects
* Memory gets reclaimed.
*
*-----------------------------------------------------------------------------
*/
static void
SvFinalize (clientData)
ClientData clientData;
{
register int i;
SvCmdInfo *cmdPtr;
RegType *regPtr;
Tcl_HashEntry *hashPtr;
Tcl_HashSearch search;
/*
* Reclaim memory for shared arrays
*/
if (buckets != NULL) {
Tcl_MutexLock(&bucketsMutex);
if (buckets != NULL) {
for (i = 0; i < NUMBUCKETS; ++i) {
Bucket *bucketPtr = &buckets[i];
hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
while (hashPtr != NULL) {
Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr);
UnlockArray(arrayPtr);
DeleteArray(arrayPtr);
hashPtr = Tcl_NextHashEntry(&search);
}
if (bucketPtr->lock) {
Sp_RecursiveMutexFinalize(&bucketPtr->lock);
}
SvFinalizeContainers(bucketPtr);
Tcl_DeleteHashTable(&bucketPtr->handles);
Tcl_DeleteHashTable(&bucketPtr->arrays);
}
Tcl_Free((char *)buckets), buckets = NULL;
}
buckets = NULL;
Tcl_MutexUnlock(&bucketsMutex);
}
Tcl_MutexLock(&svMutex);
/*
* Reclaim memory for registered commands
*/
if (svCmdInfo != NULL) {
cmdPtr = svCmdInfo;
while (cmdPtr) {
SvCmdInfo *tmpPtr = cmdPtr->nextPtr;
Tcl_Free((char*)cmdPtr);
cmdPtr = tmpPtr;
}
svCmdInfo = NULL;
}
/*
* Reclaim memory for registered object types
*/
if (regType != NULL) {
regPtr = regType;
while (regPtr) {
RegType *tmpPtr = regPtr->nextPtr;
Tcl_Free((char*)regPtr);
regPtr = tmpPtr;
}
regType = NULL;
}
Tcl_MutexUnlock(&svMutex);
}
/* EOF $RCSfile: threadSvCmd.c,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */
syntax highlighted by Code2HTML, v. 0.9.1