#include "tclInt.h"
typedef struct Link {
Tcl_Interp *interp;
Tcl_Obj *varName;
char *addr;
int type;
union {
int i;
double d;
Tcl_WideInt w;
} lastValue;
int flags;
} Link;
#define LINK_READ_ONLY 1
#define LINK_BEING_UPDATED 2
static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr));
int
Tcl_LinkVar(interp, varName, addr, type)
Tcl_Interp *interp;
CONST char *varName;
char *addr;
int type;
{
Tcl_Obj *objPtr;
Link *linkPtr;
int code;
linkPtr = (Link *) ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
objPtr = ObjValue(linkPtr);
if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
Tcl_DecrRefCount(objPtr);
ckfree((char *) linkPtr);
return TCL_ERROR;
}
code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
(ClientData) linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
}
return code;
}
void
Tcl_UnlinkVar(interp, varName)
Tcl_Interp *interp;
CONST char *varName;
{
Link *linkPtr;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
Tcl_UntraceVar(interp, varName,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, (ClientData) linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
}
void
Tcl_UpdateLinkedVar(interp, varName)
Tcl_Interp *interp;
CONST char *varName;
{
Link *linkPtr;
int savedFlag;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
linkPtr->flags |= LINK_BEING_UPDATED;
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
char **pp, *result;
Tcl_Obj *objPtr, *valueObj;
if (flags & TCL_TRACE_UNSETS) {
if (flags & TCL_INTERP_DESTROYED) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
}
return NULL;
}
if (linkPtr->flags & LINK_BEING_UPDATED) {
return NULL;
}
if (flags & TCL_TRACE_READS) {
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
break;
case TCL_LINK_DOUBLE:
changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
break;
case TCL_LINK_WIDE_INT:
changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
break;
case TCL_LINK_STRING:
changed = 1;
break;
default:
return "internal error: bad linked variable type";
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
}
return NULL;
}
if (linkPtr->flags & LINK_READ_ONLY) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
return "internal error: linked variable couldn't be read";
}
objPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objPtr);
Tcl_ResetResult(interp);
result = NULL;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
result = "variable must have integer value";
goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
result = "variable must have integer value";
goto end;
}
*(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
result = "variable must have real value";
goto end;
}
*(double *)(linkPtr->addr) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
result = "variable must have boolean value";
goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **)(linkPtr->addr);
if (*pp != NULL) {
ckfree(*pp);
}
*pp = (char *) ckalloc((unsigned) valueLength);
memcpy(*pp, value, (unsigned) valueLength);
break;
default:
return "internal error: bad linked variable type";
}
end:
Tcl_DecrRefCount(objPtr);
return result;
}
static Tcl_Obj *
ObjValue(linkPtr)
Link *linkPtr;
{
char *p;
switch (linkPtr->type) {
case TCL_LINK_INT:
linkPtr->lastValue.i = *(int *)(linkPtr->addr);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
linkPtr->lastValue.d = *(double *)(linkPtr->addr);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
linkPtr->lastValue.i = *(int *)(linkPtr->addr);
return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
case TCL_LINK_STRING:
p = *(char **)(linkPtr->addr);
if (p == NULL) {
return Tcl_NewStringObj("NULL", 4);
}
return Tcl_NewStringObj(p, -1);
default:
return Tcl_NewStringObj("??", 2);
}
}