QVariant
TclInterp::getVar(const QString& n)
{
Tcl_Obj* name = getObject(n);
Tcl_Obj* value = Tcl_ObjGetVar2(interp, name, NULL, 0);
return getValue(value);
}
HRESULT
ComObject::hresultFromErrorCode () const
{
#if TCL_MINOR_VERSION >= 1
Tcl_Obj *pErrorCode =
Tcl_GetVar2Ex(m_interp, "::errorCode", 0, TCL_LEAVE_ERR_MSG);
#else
TclObject errorCodeVarName("::errorCode");
Tcl_Obj *pErrorCode =
Tcl_ObjGetVar2(m_interp, errorCodeVarName, 0, TCL_LEAVE_ERR_MSG);
#endif
if (pErrorCode == 0) {
return E_UNEXPECTED;
}
Tcl_Obj *pErrorClass;
if (Tcl_ListObjIndex(m_interp, pErrorCode, 0, &pErrorClass) != TCL_OK) {
return E_UNEXPECTED;
}
if (strcmp(Tcl_GetStringFromObj(pErrorClass, 0), "COM") != 0) {
return E_UNEXPECTED;
}
Tcl_Obj *pHresult;
if (Tcl_ListObjIndex(m_interp, pErrorCode, 1, &pHresult) != TCL_OK) {
return E_UNEXPECTED;
}
HRESULT hr;
if (Tcl_GetLongFromObj(m_interp, pHresult, &hr) != TCL_OK) {
return E_UNEXPECTED;
}
return hr;
}
QVariant
TclInterp::getVar(const QString& t, const QString& n)
{
Tcl_Obj* array = getObject(t);
Tcl_Obj* element = getObject(n);
Tcl_Obj* value = Tcl_ObjGetVar2(interp, array, element, 0);
return getValue(value);
}
int
ComObject::getVariable (TclObject name, TclObject &value) const
{
Tcl_Obj *pValue = Tcl_ObjGetVar2(m_interp, name, 0, TCL_LEAVE_ERR_MSG);
if (pValue == 0) {
return TCL_ERROR;
}
value = pValue;
return TCL_OK;
}
/*
** This is the callback from a quota-over-limit.
*/
static void tclQuotaCallback(
const char *zFilename, /* Name of file whose size increases */
sqlite3_int64 *piLimit, /* IN/OUT: The current limit */
sqlite3_int64 iSize, /* Total size of all files in the group */
void *pArg /* Client data */
){
TclQuotaCallback *p; /* Callback script object */
Tcl_Obj *pEval; /* Script to evaluate */
Tcl_Obj *pVarname; /* Name of variable to pass as 2nd arg */
unsigned int rnd; /* Random part of pVarname */
int rc; /* Tcl error code */
p = (TclQuotaCallback *)pArg;
if( p==0 ) return;
pVarname = Tcl_NewStringObj("::piLimit_", -1);
Tcl_IncrRefCount(pVarname);
sqlite3_randomness(sizeof(rnd), (void *)&rnd);
Tcl_AppendObjToObj(pVarname, Tcl_NewIntObj((int)(rnd&0x7FFFFFFF)));
Tcl_ObjSetVar2(p->interp, pVarname, 0, Tcl_NewWideIntObj(*piLimit), 0);
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewStringObj(zFilename, -1));
Tcl_ListObjAppendElement(0, pEval, pVarname);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewWideIntObj(iSize));
rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
if( rc==TCL_OK ){
Tcl_Obj *pLimit = Tcl_ObjGetVar2(p->interp, pVarname, 0, 0);
rc = Tcl_GetWideIntFromObj(p->interp, pLimit, piLimit);
Tcl_UnsetVar(p->interp, Tcl_GetString(pVarname), 0);
}
Tcl_DecrRefCount(pEval);
Tcl_DecrRefCount(pVarname);
if( rc!=TCL_OK ) Tcl_BackgroundError(p->interp);
}
static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
CONST char *name1, /* First part of variable name. */
CONST char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
double valueDouble;
/*
* If the variable is being unset, then just re-create it (with a trace)
* unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
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 we were invoked because of a call to Tcl_UpdateLinkedVar, then don't
* do anything at all. In particular, we don't want to get upset that the
* variable is being modified, even if it is supposed to be read-only.
*/
if (linkPtr->flags & LINK_BEING_UPDATED) {
return NULL;
}
/*
* For read accesses, update the Tcl variable if the C variable has
* changed since the last time we updated the Tcl variable.
*/
if (flags & TCL_TRACE_READS) {
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
changed = (LinkedVar(int) != linkPtr->lastValue.i);
break;
case TCL_LINK_DOUBLE:
changed = (LinkedVar(double) != linkPtr->lastValue.d);
break;
case TCL_LINK_WIDE_INT:
changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
break;
case TCL_LINK_WIDE_UINT:
changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
break;
case TCL_LINK_CHAR:
changed = (LinkedVar(char) != linkPtr->lastValue.c);
break;
case TCL_LINK_UCHAR:
changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
break;
case TCL_LINK_SHORT:
changed = (LinkedVar(short) != linkPtr->lastValue.s);
break;
case TCL_LINK_USHORT:
changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
break;
case TCL_LINK_UINT:
changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
break;
case TCL_LINK_LONG:
changed = (LinkedVar(long) != linkPtr->lastValue.l);
break;
case TCL_LINK_ULONG:
changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
break;
case TCL_LINK_FLOAT:
changed = (LinkedVar(float) != linkPtr->lastValue.f);
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;
}
/*
* For writes, first make sure that the variable is writable. Then convert
* the Tcl value to C if possible. If the variable isn't writable or can't
* be converted, then restore the varaible's old value and return an
* error. Another tricky thing: we have to save and restore the interp's
* result, since the variable access could occur when the result has been
* partially set.
*/
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) {
/*
* This shouldn't ever happen.
*/
return "internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have integer value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have integer value";
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
#ifdef ACCEPT_NAN
if (valueObj->typePtr != &tclDoubleType) {
#endif
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return "variable must have real value";
#ifdef ACCEPT_NAN
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
#endif
}
LinkedVar(double) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have boolean value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_CHAR:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have char value";
}
linkPtr->lastValue.c = (char)valueInt;
LinkedVar(char) = linkPtr->lastValue.c;
break;
case TCL_LINK_UCHAR:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > UCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned char value";
}
linkPtr->lastValue.uc = (unsigned char) valueInt;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
break;
case TCL_LINK_SHORT:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have short value";
}
linkPtr->lastValue.s = (short)valueInt;
LinkedVar(short) = linkPtr->lastValue.s;
break;
case TCL_LINK_USHORT:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > USHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned short value";
}
linkPtr->lastValue.us = (unsigned short)valueInt;
LinkedVar(unsigned short) = linkPtr->lastValue.us;
break;
case TCL_LINK_UINT:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || valueWide > UINT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned int value";
}
linkPtr->lastValue.ui = (unsigned int)valueWide;
LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
case TCL_LINK_LONG:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have long value";
}
linkPtr->lastValue.l = (long)valueWide;
LinkedVar(long) = linkPtr->lastValue.l;
break;
case TCL_LINK_ULONG:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned long value";
}
linkPtr->lastValue.ul = (unsigned long)valueWide;
LinkedVar(unsigned long) = linkPtr->lastValue.ul;
break;
case TCL_LINK_WIDE_UINT:
/*
* FIXME: represent as a bignum.
*/
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned wide int value";
}
linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
case TCL_LINK_FLOAT:
if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have float value";
}
linkPtr->lastValue.f = (float)valueDouble;
LinkedVar(float) = linkPtr->lastValue.f;
break;
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **) linkPtr->addr;
*pp = ckrealloc(*pp, valueLength);
memcpy(*pp, value, (unsigned) valueLength);
break;
default:
return "internal error: bad linked variable type";
}
return NULL;
}
static char *gap5_defs_trace(ClientData cd, Tcl_Interp *interp,
char *n1, char *n2, int flags) {
gap5_defs = Tcl_ObjGetVar2(interp, defs_name, NULL, TCL_GLOBAL_ONLY);
return NULL;
}
/* Main global setup function */
int init_globals(Tcl_Interp *interp) {
static int done_init = 0;
extern int gap_fatal_errors;
char *env;
if (done_init)
return 0;
else
done_init++;
/* lookup tables */
set_char_set(1); /* 1 == DNA */
set_dna_lookup(); /* general lookup and complementing */
set_iubc_lookup(); /* iubc codes for restriction enzymes */
#if 0
set_mask_lookup(); /* used to mask/mark consensus */
#endif
init_genetic_code();
#if 0
inits_(); /* fortran stuff */
initlu_(&idm); /* fortran stuff */
#endif
/* Init Tcl note database */
init_tcl_notes(interp);
if (NULL == (env = getenv("STADTABL")))
verror(ERR_FATAL, "init_globals",
"STADTABL environment variable is not set.");
else {
char buf[1024];
sprintf(buf, "%s/align_lib_nuc_matrix", env);
nt_matrix = create_matrix(buf, nt_order);
if (nt_matrix)
init_W128(nt_matrix, nt_order, 0);
else
verror(ERR_FATAL, "init_globals",
"%s: file not found", buf);
}
/*
* gap5_defs (a Tcl_Obj pointer)
*
* We keep this up to date by creating a write trace on the object and
* doing an ObjGetVar2 when it changes. This way the object is always
* valid.
* Firstly we have to create gap5_defs though as initially it doesn't
* exist.
*/
{
Tcl_Obj *val;
defs_name = Tcl_NewStringObj("gap5_defs", -1); /* global */
val = Tcl_ObjGetVar2(interp, defs_name, NULL, TCL_GLOBAL_ONLY);
if (NULL == val)
val = Tcl_NewStringObj("", -1);
gap5_defs = Tcl_ObjSetVar2(interp, defs_name, NULL, val,
TCL_GLOBAL_ONLY);
Tcl_TraceVar(interp, "gap5_defs", TCL_TRACE_WRITES | TCL_GLOBAL_ONLY,
gap5_defs_trace, NULL);
}
/* consensus_cutoff */
Tcl_TraceVar(interp, "consensus_cutoff", TCL_TRACE_WRITES|TCL_GLOBAL_ONLY,
change_consensus_cutoff, (ClientData)NULL);
/* quality_cutoff */
Tcl_LinkVar(interp, "quality_cutoff", (char *)&quality_cutoff,
TCL_LINK_INT);
/* chem_as_double */
Tcl_LinkVar(interp, "chem_as_double", (char *)&chem_as_double,
TCL_LINK_INT);
/* gap_fatal_errors */
Tcl_LinkVar(interp, "gap_fatal_errors", (char *)&gap_fatal_errors,
TCL_LINK_BOOLEAN);
#if 0
/* maxseq */
Tcl_LinkVar(interp, "maxseq", (char *)&maxseq,
TCL_LINK_INT);
/* maxdb */
Tcl_LinkVar(interp, "maxdb", (char *)&maxdb,
TCL_LINK_INT);
#endif
/* ignore_checkdb */
Tcl_LinkVar(interp, "ignore_checkdb", (char *)&ignore_checkdb,
TCL_LINK_INT);
/* consensus_mode */
Tcl_LinkVar(interp, "consensus_mode", (char *)&consensus_mode,
TCL_LINK_INT);
/* consensus_iub */
Tcl_LinkVar(interp, "consensus_iub", (char *)&consensus_iub,
TCL_LINK_INT);
/* exec_notes */
Tcl_LinkVar(interp, "exec_notes", (char *)&exec_notes,
TCL_LINK_INT);
/* rawdata_note */
Tcl_LinkVar(interp, "rawdata_note", (char *)&rawdata_note,
TCL_LINK_INT);
/* align_open_cost */
Tcl_LinkVar(interp, "align_open_cost", (char *)&gopenval,
TCL_LINK_INT);
/* align_extend_cost */
Tcl_LinkVar(interp, "align_extend_cost", (char *)&gextendval,
TCL_LINK_INT);
/* template_size_tolerance */
Tcl_LinkVar(interp, "template_size_tolerance",
(char *)&template_size_tolerance,
TCL_LINK_DOUBLE);
/* min_vector_len */
Tcl_LinkVar(interp, "min_vector_len", (char *)&min_vector_len,
TCL_LINK_INT);
/* template_check_flags */
Tcl_LinkVar(interp, "template_check_flags", (char *)&template_check_flags,
TCL_LINK_INT);
return TCL_OK;
}
int
TypedArguments::initArgument (
Tcl_Interp *interp,
Tcl_Obj *pObj,
int argIndex,
const Parameter ¶meter)
{
TclObject argument(pObj);
VARTYPE vt = parameter.type().vartype();
if (pObj->typePtr == &Extension::naType) {
// This variant indicates a missing optional argument.
m_args[argIndex] = vtMissing;
} else if (parameter.type().pointerCount() > 0) {
// The argument is passed by reference.
switch (vt) {
case VT_INT:
// IDispatch::Invoke returns DISP_E_TYPEMISMATCH on
// VT_INT | VT_BYREF parameters.
vt = VT_I4;
break;
case VT_UINT:
// IDispatch::Invoke returns DISP_E_TYPEMISMATCH on
// VT_UINT | VT_BYREF parameters.
vt = VT_UI4;
break;
case VT_USERDEFINED:
// Assume user defined types derive from IUnknown.
vt = VT_UNKNOWN;
break;
}
if (vt == VT_SAFEARRAY) {
m_args[argIndex].vt = VT_BYREF | VT_ARRAY |
parameter.type().elementType().vartype();
} else {
m_args[argIndex].vt = VT_BYREF | vt;
}
if (vt == VT_VARIANT || vt == VT_DECIMAL) {
// Set a pointer to out variant.
m_args[argIndex].byref = &m_outValues[argIndex];
} else {
// Set a pointer to variant data value.
m_args[argIndex].byref = &m_outValues[argIndex].byref;
}
if (parameter.flags() & PARAMFLAG_FIN) {
if (parameter.flags() & PARAMFLAG_FOUT) {
// Set the value for an in/out parameter.
Tcl_Obj *pValue = Tcl_ObjGetVar2(
interp, pObj, NULL, TCL_LEAVE_ERR_MSG);
if (pValue == 0) {
return TCL_ERROR;
}
TclObject value(pValue);
// If the argument is an interface pointer, increment its
// reference count because the _variant_t destructor will
// release it.
value.toNativeValue(
&m_outValues[argIndex], parameter.type(), interp, true);
} else {
// If the argument is an interface pointer, increment its
// reference count because the _variant_t destructor will
// release it.
argument.toNativeValue(
&m_outValues[argIndex], parameter.type(), interp, true);
}
} else {
if (vt == VT_UNKNOWN) {
m_outValues[argIndex].vt = vt;
m_outValues[argIndex].punkVal = NULL;
} else if (vt == VT_DISPATCH) {
m_outValues[argIndex].vt = vt;
m_outValues[argIndex].pdispVal = NULL;
} else if (vt == VT_SAFEARRAY) {
VARTYPE elementType = parameter.type().elementType().vartype();
m_outValues[argIndex].vt = VT_ARRAY | elementType;
m_outValues[argIndex].parray =
SafeArrayCreateVector(elementType, 0, 1);
} else if (vt != VT_VARIANT) {
m_outValues[argIndex].ChangeType(vt);
}
}
} else {
// If the argument is an interface pointer, increment its reference
// count because the _variant_t destructor will release it.
argument.toNativeValue(
&m_args[argIndex], parameter.type(), interp, true);
}
return TCL_OK;
}
static int
ConfigureScale(
Tcl_Interp *interp, /* Used for error reporting. */
register TkScale *scalePtr, /* Information about widget; may or may not
* already have values for some fields. */
int objc, /* Number of valid entries in objv. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tk_SavedOptions savedOptions;
Tcl_Obj *errorResult = NULL;
int error;
double varValue;
/*
* Eliminate any existing trace on a variable monitored by the scale.
*/
if (scalePtr->varNamePtr != NULL) {
Tcl_UntraceVar(interp, Tcl_GetString(scalePtr->varNamePtr),
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
ScaleVarProc, scalePtr);
}
for (error = 0; error <= 1; error++) {
if (!error) {
/*
* First pass: set options to new values.
*/
if (Tk_SetOptions(interp, (char *) scalePtr,
scalePtr->optionTable, objc, objv, scalePtr->tkwin,
&savedOptions, NULL) != TCL_OK) {
continue;
}
} else {
/*
* Second pass: restore options to old values.
*/
errorResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errorResult);
Tk_RestoreSavedOptions(&savedOptions);
}
/*
* If the scale is tied to the value of a variable, then set the
* scale's value from the value of the variable, if it exists and it
* holds a valid double value.
*/
if (scalePtr->varNamePtr != NULL) {
double value;
Tcl_Obj *valuePtr;
valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL,
TCL_GLOBAL_ONLY);
if ((valuePtr != NULL) &&
(Tcl_GetDoubleFromObj(NULL, valuePtr, &value) == TCL_OK)) {
scalePtr->value = TkRoundToResolution(scalePtr, value);
}
}
/*
* Several options need special processing, such as parsing the
* orientation and creating GCs.
*/
scalePtr->fromValue = TkRoundToResolution(scalePtr,
scalePtr->fromValue);
scalePtr->toValue = TkRoundToResolution(scalePtr, scalePtr->toValue);
scalePtr->tickInterval = TkRoundToResolution(scalePtr,
scalePtr->tickInterval);
/*
* Make sure that the tick interval has the right sign so that
* addition moves from fromValue to toValue.
*/
if ((scalePtr->tickInterval < 0)
^ ((scalePtr->toValue - scalePtr->fromValue) < 0)) {
scalePtr->tickInterval = -scalePtr->tickInterval;
}
ComputeFormat(scalePtr);
scalePtr->labelLength = scalePtr->label ? (int)strlen(scalePtr->label) : 0;
Tk_SetBackgroundFromBorder(scalePtr->tkwin, scalePtr->bgBorder);
if (scalePtr->highlightWidth < 0) {
scalePtr->highlightWidth = 0;
}
scalePtr->inset = scalePtr->highlightWidth + scalePtr->borderWidth;
break;
}
if (!error) {
Tk_FreeSavedOptions(&savedOptions);
}
/*
* Set the scale value to itself; all this does is to make sure that the
* scale's value is within the new acceptable range for the scale. We
* don't set the var here because we need to make special checks for
* possibly changed varNamePtr.
*/
TkScaleSetValue(scalePtr, scalePtr->value, 0, 1);
/*
* Reestablish the variable trace, if it is needed.
*/
if (scalePtr->varNamePtr != NULL) {
Tcl_Obj *valuePtr;
/*
* Set the associated variable only when the new value differs from
* the current value, or the variable doesn't yet exist.
*/
valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL,
TCL_GLOBAL_ONLY);
if ((valuePtr == NULL) || (Tcl_GetDoubleFromObj(NULL,
valuePtr, &varValue) != TCL_OK)) {
ScaleSetVariable(scalePtr);
} else {
char varString[TCL_DOUBLE_SPACE], scaleString[TCL_DOUBLE_SPACE];
sprintf(varString, scalePtr->format, varValue);
sprintf(scaleString, scalePtr->format, scalePtr->value);
if (strcmp(varString, scaleString)) {
ScaleSetVariable(scalePtr);
}
}
Tcl_TraceVar(interp, Tcl_GetString(scalePtr->varNamePtr),
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
ScaleVarProc, scalePtr);
}
ScaleWorldChanged(scalePtr);
if (error) {
Tcl_SetObjResult(interp, errorResult);
Tcl_DecrRefCount(errorResult);
return TCL_ERROR;
}
return TCL_OK;
}
/* ARGSUSED */
static char *
ScaleVarProc(
ClientData clientData, /* Information about button. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
register TkScale *scalePtr = clientData;
const char *resultStr;
double value;
Tcl_Obj *valuePtr;
int result;
/*
* If the variable is unset, then immediately recreate it unless the whole
* interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
Tcl_TraceVar(interp, Tcl_GetString(scalePtr->varNamePtr),
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
ScaleVarProc, clientData);
scalePtr->flags |= NEVER_SET;
TkScaleSetValue(scalePtr, scalePtr->value, 1, 0);
}
return NULL;
}
/*
* If we came here because we updated the variable (in TkScaleSetValue),
* then ignore the trace. Otherwise update the scale with the value of the
* variable.
*/
if (scalePtr->flags & SETTING_VAR) {
return NULL;
}
resultStr = NULL;
valuePtr = Tcl_ObjGetVar2(interp, scalePtr->varNamePtr, NULL,
TCL_GLOBAL_ONLY);
result = Tcl_GetDoubleFromObj(interp, valuePtr, &value);
if (result != TCL_OK) {
resultStr = "can't assign non-numeric value to scale variable";
ScaleSetVariable(scalePtr);
} else {
scalePtr->value = TkRoundToResolution(scalePtr, value);
/*
* This code is a bit tricky because it sets the scale's value before
* calling TkScaleSetValue. This way, TkScaleSetValue won't bother to
* set the variable again or to invoke the -command. However, it also
* won't redisplay the scale, so we have to ask for that explicitly.
*/
TkScaleSetValue(scalePtr, scalePtr->value, 1, 0);
}
TkEventuallyRedrawScale(scalePtr, REDRAW_SLIDER);
return (char *) resultStr;
}
