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; }