static void init_tcl_notes(Tcl_Interp *interp) {
int i;
char buf[1024];
readInNoteDB(); /* Parse and load NOTEDB */
sprintf(buf, "%d", note_db_count);
Tcl_SetVar2(interp, "NoteDB", "num_notes", buf, TCL_GLOBAL_ONLY);
for (i = 0; i < note_db_count; i++) {
sprintf(buf, "%d,type", i);
Tcl_SetVar2(interp, "NoteDB", buf, note_db[i].type,
TCL_GLOBAL_ONLY);
sprintf(buf, "%d,id", i);
Tcl_SetVar2(interp, "NoteDB", buf, note_db[i].search_id,
TCL_GLOBAL_ONLY);
sprintf(buf, "%d,dt", i);
Tcl_SetVar2(interp, "NoteDB", buf, note_db[i].default_text,
TCL_GLOBAL_ONLY);
}
return;
}
void
Tcl_AddErrorInfo(
Tcl_Interp *interp /* Interpreter to which error information
* pertains. */
, unsigned char *message /* Message to record. */
)
{
register Interp *iPtr = (Interp *) interp;
/*
* If an error is already being logged, then the new errorInfo
* is the concatenation of the old info and the new message.
* If this is the first piece of info for the error, then the
* new errorInfo is the concatenation of the message in
* interp->result and the new message.
*/
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
Tcl_SetVar2(interp, (unsigned char*) "errorInfo", 0, interp->result,
TCL_GLOBAL_ONLY);
iPtr->flags |= ERR_IN_PROGRESS;
/*
* If the errorCode variable wasn't set by the code that generated
* the error, set it to "NONE".
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
Tcl_SetVar2(interp, (unsigned char*) "errorCode", 0,
(unsigned char*) "NONE", TCL_GLOBAL_ONLY);
}
}
Tcl_SetVar2(interp, (unsigned char*) "errorInfo", 0, message,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
}
static int
query_engine(ClientData clientData,
Tcl_Interp *interp,
int argc,
char *argv[])
{
char var[255];
int port;
channel_t *chan;
assert(argc>0);
port = atoi(argv[argc-1]);
chan = (channel_t*)queue_get_eq(priv_c,(char*)&port,Q_KEEP);
sprintf(var, "%d", chan->port);
Tcl_SetVar2(interp, "c", "port", var, TCL_GLOBAL_ONLY);
sprintf(var, "%.4f", chan->loss*100);
Tcl_SetVar2(interp, "c", "loss", var, TCL_GLOBAL_ONLY);
sprintf(var, "%d", chan->min_delay);
Tcl_SetVar2(interp, "c", "min_delay", var, TCL_GLOBAL_ONLY);
sprintf(var, "%d", chan->max_delay);
Tcl_SetVar2(interp, "c", "max_delay", var, TCL_GLOBAL_ONLY);
sprintf(var, "%.4f", chan->dup_pr * 100);
Tcl_SetVar2(interp, "c", "dup_pr", var, TCL_GLOBAL_ONLY);
Tcl_SetResult(interp,NULL,TCL_STATIC);
UNUSED(clientData);
return TCL_OK;
}
/**********************************
* execute_put_values
Put the values of one tuple into Tcl variables named like the
column names, or into an array indexed by the column names.
**********************************/
static int
execute_put_values(Tcl_Interp *interp, CONST84 char *array_varname,
PGresult *result, int tupno)
{
int i;
int n;
char *fname;
char *value;
/*
* For each column get the column name and value and put it into a Tcl
* variable (either scalar or array item)
*/
n = PQnfields(result);
for (i = 0; i < n; i++)
{
fname = PQfname(result, i);
value = PQgetvalue(result, tupno, i);
if (array_varname != NULL)
{
if (Tcl_SetVar2(interp, array_varname, fname, value,
TCL_LEAVE_ERR_MSG) == NULL)
return TCL_ERROR;
}
else
{
if (Tcl_SetVar(interp, fname, value, TCL_LEAVE_ERR_MSG) == NULL)
return TCL_ERROR;
}
}
return TCL_OK;
}
int NpInitInterp(Tcl_Interp *interp, int install_tk) {
Tcl_Preserve((ClientData) interp);
/*
* Set sharedlib in interp while we are here. This will be used to
* base the location of the default pluginX.Y package in the stardll
* usage scenario.
*/
if (Tcl_SetVar2(interp, "plugin", "sharedlib", dllName, TCL_GLOBAL_ONLY)
== NULL) {
NpPlatformMsg("Failed to set plugin(sharedlib)!", "NpInitInterp");
return TCL_ERROR;
}
/*
* The plugin doesn't directly call Tk C APIs - it's all managed at
* the Tcl level, so we can just pkg req Tk here instead of calling
* Tk_InitStubs.
*/
if (TCL_OK != Tcl_Init(interp)) {
CONST char *msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
fprintf(stderr, "GTKWAVE | Tcl_Init error: %s\n", msg) ;
exit(EXIT_FAILURE);
}
if (install_tk) {
NpLog("Tcl_PkgRequire(\"Tk\", \"%s\", 0)\n", TK_VERSION);
if (1 && Tcl_PkgRequire(interp, "Tk", TK_VERSION, 0) == NULL) {
CONST char *msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
NpPlatformMsg(msg, "NpInitInterp Tcl_PkgRequire(Tk)");
NpPlatformMsg("Failed to create initialize Tk", "NpInitInterp");
return TCL_ERROR;
}
}
return TCL_OK;
}
/* Make the timestep userdata available to Tcl. */
void vtf_set_timestep_userdata(const unsigned int timestep,
const char* userdata) {
static char array_index[255];
if (userdata == NULL || strlen(userdata) == 0) return;
sprintf(array_index, "%s.step%d", molid, timestep);
Tcl_SetVar2(tcl_interp, userdata_varname, array_index, userdata, 0);
}
double func (double x[])
{
int i;
double value;
char buf2[256];
char buf[2048];
sprintf(buf,"%d",++iter);
if (NULL == Tcl_SetVar2(intrp,array,"iter",buf,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)) {
fprintf(stderr,"Error: '%s'\n",intrp->result);
exit(1);
}
strcpy(buf,function);
strcat(buf," {");
for (i=1;i<=npar;i++) {
sprintf(buf2," { %s %g }",name[i],x[i]);
strcat(buf,buf2);
}
strcat(buf," }");
if (Tcl_Eval(intrp,buf) != TCL_OK) {
fprintf(stderr,"Error: '%s'\n",intrp->result);
exit(1);
}
if (Tcl_GetDouble(intrp,intrp->result,&value) != TCL_OK) {
fprintf(stderr,"Error: '%s'\n",intrp->result);
exit(1);
}
return value;
}
/* VARARGS2 */
void
Tcl_SetErrorCode (Tcl_Interp *interp, /* Interpreter whose errorCode variable is
* to be set. */
...) /* One or more elements to add to errorCode,
* terminated with NULL. */
{
va_list argList;
unsigned char *string;
int flags;
Interp *iPtr = (Interp *) interp;
/*
* Scan through the arguments one at a time, appending them to
* $errorCode as list elements.
*/
va_start(argList, interp);
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
while (1) {
string = va_arg(argList, unsigned char *);
if (string == 0) {
break;
}
Tcl_SetVar2((Tcl_Interp *) iPtr, (unsigned char*) "errorCode",
0, string, flags);
flags |= TCL_APPEND_VALUE;
}
va_end(argList);
iPtr->flags |= ERROR_CODE_SET;
}
/* ARGSUSED */
int
Tcl_ErrorCmd(
void *dummy /* Not used. */
, Tcl_Interp *interp /* Current interpreter. */
, int argc /* Number of arguments. */
, unsigned char **argv /* Argument strings. */
)
{
Interp *iPtr = (Interp *) interp;
if ((argc < 2) || (argc > 4)) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" message ?errorInfo? ?errorCode?\"", 0);
return TCL_ERROR;
}
if ((argc >= 3) && (argv[2][0] != 0)) {
Tcl_AddErrorInfo(interp, argv[2]);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
if (argc == 4) {
Tcl_SetVar2(interp, (unsigned char*) "errorCode", 0, argv[3],
TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
}
Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
return TCL_ERROR;
}
int Nip_Init(Tcl_Interp *interp) {
char *s, c[20];
/*
* Set packages(name). This is done to prevent subsequent reloading
* of this library (for efficiency reasons). The only reason that this
* is necessary is that currently gap4 dynamically links with some
* libraries at link time. When they're all at run time this won't
* be necessary.
*/
if (s = Tcl_GetVar2(interp, "packages", "nip", TCL_GLOBAL_ONLY))
sprintf(c, "%d", atoi(s)|2);
else
strcpy(c, "2");
Tcl_SetVar2(interp, "packages", "nip", c, TCL_GLOBAL_ONLY);
if (Seqed_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (SeqedNames_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (NipCmds_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
return TCL_OK;
}
int mpsa_Init(
Tcl_Interp *interp
)
{
ClientData dummy;
int argc = 0;
char **argv = NULL;
char *InitScript;
Tcl_InitHashTable(&mpsa_SimHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&mpsa_ListHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&mpsa_PairListHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&mpsa_ParticletypeHashTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&mpsa_PiptypeHashTable, TCL_STRING_KEYS);
/*
* register external 'mpsa' commands. necessary since these are in a
* 'loadable module' format.
*/
Tcl_SetVar2(interp, "Mpsa", "etc", MPSA_ETC_DIR, TCL_GLOBAL_ONLY);
InitScript = "catch {source $Mpsa(etc)/Init.tcl}";
Tcl_Eval(interp, InitScript);
mpsa_InitCmd(dummy, interp, argc, argv);
Tree_Init(interp);
Cloud_Init(interp);
Sf_Init(interp);
Sn_Init(interp);
Tpp_Init(interp);
Pairlist_Init(interp);
return TCL_OK;
}
void
TclSetupEnv(
Tcl_Interp *interp) /* Interpreter whose "env" array is to be
* managed. */
{
Tcl_DString envString;
char *p1, *p2;
int i;
/*
* Synchronize the values in the environ array with the contents of the
* Tcl "env" variable. To do this:
* 1) Remove the trace that fires when the "env" var is unset.
* 2) Unset the "env" variable.
* 3) If there are no environ variables, create an empty "env" array.
* Otherwise populate the array with current values.
* 4) Add a trace that synchronizes the "env" array.
*/
Tcl_UntraceVar2(interp, "env", NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
if (environ[0] == NULL) {
Tcl_Obj *varNamePtr;
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
TclArraySet(interp, varNamePtr, NULL);
Tcl_DecrRefCount(varNamePtr);
} else {
Tcl_MutexLock(&envMutex);
for (i = 0; environ[i] != NULL; i++) {
p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
p2 = strchr(p1, '=');
if (p2 == NULL) {
/*
* This condition seem to happen occasionally under some
* versions of Solaris, or when encoding accidents swallow the
* '='; ignore the entry.
*/
continue;
}
p2++;
p2[-1] = '\0';
Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&envString);
}
Tcl_MutexUnlock(&envMutex);
}
Tcl_TraceVar2(interp, "env", NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
}
/*
* update global variables
*/
int RtdCamera::updateGlobals()
{
if (was_attached_ != attached()) {
was_attached_ = attached();
sprintf(buffer_, "%d %s", attached(), camera());
Tcl_SetVar2(interp_, image_, "ATTACHED", buffer_, TCL_GLOBAL_ONLY);
}
return TCL_OK;
}
/*
** Called for each row of the result.
**
** This version is used when either of the following is true:
**
** (1) This version of TCL uses UTF-8 and the data in the
** SQLite database is already in the UTF-8 format.
**
** (2) This version of TCL uses ISO8859 and the data in the
** SQLite database is already in the ISO8859 format.
*/
static int DbEvalCallback(
void *clientData, /* An instance of CallbackData */
int nCol, /* Number of columns in the result */
char ** azCol, /* Data for each column */
char ** azN /* Name for each column */
){
CallbackData *cbData = (CallbackData*)clientData;
int i, rc;
if( azCol==0 || (cbData->once && cbData->zArray[0]) ){
Tcl_SetVar2(cbData->interp, cbData->zArray, "*", "", 0);
for(i=0; i<nCol; i++){
Tcl_SetVar2(cbData->interp, cbData->zArray, "*", azN[i],
TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
if( azN[nCol] ){
char *z = sqlite_mprintf("typeof:%s", azN[i]);
Tcl_SetVar2(cbData->interp, cbData->zArray, z, azN[i+nCol],
TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
sqlite_freemem(z);
}
}
cbData->once = 0;
}
if( azCol!=0 ){
if( cbData->zArray[0] ){
for(i=0; i<nCol; i++){
char *z = azCol[i];
if( z==0 ) z = "";
Tcl_SetVar2(cbData->interp, cbData->zArray, azN[i], z, 0);
}
}else{
for(i=0; i<nCol; i++){
char *z = azCol[i];
if( z==0 ) z = "";
Tcl_SetVar(cbData->interp, azN[i], z, 0);
}
}
}
rc = Tcl_EvalObj(cbData->interp, cbData->pCode);
if( rc==TCL_CONTINUE ) rc = TCL_OK;
cbData->tcl_rc = rc;
return rc!=TCL_OK;
}
static char *traced_globchanset(ClientData cdata, Tcl_Interp * irp,
char *name1, char *name2, int flags)
{
char *s;
char *t;
int i;
int items;
char **item;
Context;
if (flags & (TCL_TRACE_READS | TCL_TRACE_UNSETS)) {
Tcl_SetVar2(interp, name1, name2, glob_chanset, TCL_GLOBAL_ONLY);
if (flags & TCL_TRACE_UNSETS)
Tcl_TraceVar(interp, "global-chanset",
TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
traced_globchanset, NULL);
} else { /* write */
s = Tcl_GetVar2(interp, name1, name2, TCL_GLOBAL_ONLY);
Tcl_SplitList(interp, s, &items, &item);
Context;
for (i = 0; i<items; i++) {
if (!(item[i]) || (strlen(item[i]) < 2)) continue;
s = glob_chanset;
while (s[0]) {
t = strchr(s, ' '); /* cant be NULL coz of the extra space */
Context;
t[0] = 0;
if (!strcmp(s + 1, item[i] + 1)) {
s[0] = item[i][0]; /* +- */
t[0] = ' ';
break;
}
t[0] = ' ';
s = t + 1;
}
}
if (item) /* hmm it cant be 0 */
Tcl_Free((char *) item);
Tcl_SetVar2(interp, name1, name2, glob_chanset, TCL_GLOBAL_ONLY);
}
return NULL;
}
static int setVariable( ComboParams *para, const char *val )
{
if( para->variable && para->inSetVar == 0 )
{
const char *ret;
para->inSetVar = 1;
ret = Tcl_SetVar2( para->interp, para->variable, NULL,
val, TCL_GLOBAL_ONLY );
para->inSetVar = 0;
return ret == NULL ? TCL_ERROR : TCL_OK;
}
return TCL_OK;
}
static TkappObject *
Tkapp_New(char *screenName, char *baseName, char *className, int interactive)
{
TkappObject *v;
char *argv0;
v = PyObject_New(TkappObject, &Tkapp_Type);
if (v == NULL)
return NULL;
v->interp = Tcl_CreateInterp();
#if defined(macintosh)
/* This seems to be needed */
ClearMenuBar();
TkMacInitMenus(v->interp);
#endif
/* Delete the 'exit' command, which can screw things up */
Tcl_DeleteCommand(v->interp, "exit");
if (screenName != NULL)
Tcl_SetVar2(v->interp, "env", "DISPLAY",
screenName, TCL_GLOBAL_ONLY);
if (interactive)
Tcl_SetVar(v->interp, "tcl_interactive", "1", TCL_GLOBAL_ONLY);
else
Tcl_SetVar(v->interp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* This is used to get the application class for Tk 4.1 and up */
argv0 = (char*)ckalloc(strlen(className) + 1);
if (!argv0) {
PyErr_NoMemory();
Py_DECREF(v);
return NULL;
}
strcpy(argv0, className);
if (isupper((int)(argv0[0])))
argv0[0] = tolower(argv0[0]);
Tcl_SetVar(v->interp, "argv0", argv0, TCL_GLOBAL_ONLY);
ckfree(argv0);
if (Tcl_AppInit(v->interp) != TCL_OK)
return (TkappObject *)Tkinter_Error((PyObject *)v);
EnableEventHook();
return v;
}
/*
* Set up per-zone state. In our case, the database arguments of the
* zone are collected into a Tcl list and assigned to an element of
* the global array "dbargs".
*/
static isc_result_t
tcldb_create(const char *zone, int argc, char **argv,
void *driverdata, void **dbdata)
{
tcldb_driver_t *driver = (tcldb_driver_t *) driverdata;
char *list = Tcl_Merge(argc, argv);
Tcl_SetVar2(driver->interp, (char *) "dbargs", (char *) zone, list, 0);
Tcl_Free(list);
*dbdata = driverdata;
return (ISC_R_SUCCESS);
}
static bool tk_start(char **result)
{
static bool first_init = false;
Tk_Window mainw;
if (!first_init) {
first_init = true;
/* this works around a bug in some Tcl/Tk versions */
Tcl_FindExecutable(NULL);
/* finalize Tcl at program exit */
atexit(Tcl_Finalize);
}
*result = NULL;
if (interp) return true;
/* start up a new interpreter */
if (!(interp = Tcl_CreateInterp())) return false;
if (Tcl_Init(interp) != TCL_OK) {
if (check_result(interp))
set_result(result, get_result(interp));
else
set_result(result, "error initializing Tcl");
tk_stop();
return false;
}
/* create a command to invoke Pure callbacks from Tcl */
Tcl_CreateCommand(interp, "pure", (Tcl_CmdProc*)tk_pure,
(ClientData)0, NULL);
/* oddly, there are no `env' variables passed, and this one is needed */
Tcl_SetVar2(interp, "env", "DISPLAY", getenv("DISPLAY"), TCL_GLOBAL_ONLY);
if (Tk_Init(interp) != TCL_OK) {
if (check_result(interp))
set_result(result, get_result(interp));
else
set_result(result, "error initializing Tk");
tk_stop();
return false;
}
/* set up an X error handler */
mainw = Tk_MainWindow(interp);
Tk_CreateErrorHandler(Tk_Display(mainw), -1, -1, -1,
XErrorProc, (ClientData)mainw);
return true;
}
void
ParadynTkGUI::chooseMetricsandResources(chooseMandRCBFunc cb,
pdvector<metric_focus_pair> * /* pairList */ )
{
// store record with unique id and callback function
UIMMsgTokenID++;
int newptr;
Tcl_HashEntry *entryPtr = Tcl_CreateHashEntry (&UIMMsgReplyTbl,
(char *)UIMMsgTokenID,
&newptr);
if (newptr == 0) {
showError(21, "");
thr_exit(0);
}
unsigned requestingThread = getRequestingThread();
// in theory, we can check here whether this (VISI-) thread already
// has an outstanding metric request. But for now, we let code in mets.tcl do this...
// pdstring commandStr = pdstring("winfo exists .metmenunew") + pdstring(requestingThread);
// myTclEval(interp, commandStr);
// int result;
// assert(TCL_OK == Tcl_GetBoolean(interp, Tcl_GetStringResult(interp), &result));
// if (result)
// return; // the window is already up for this thread!
UIMReplyRec *reply = new UIMReplyRec;
reply->tid = requestingThread;
reply->cb = (void *) cb;
Tcl_SetHashValue (entryPtr, reply);
if (!all_metrics_set_yet) {
pdvector<met_name_id> *all_mets = dataMgr->getAvailableMetInfo(true);
for (unsigned metlcv=0; metlcv < all_mets->size(); metlcv++) {
unsigned id = (*all_mets)[metlcv].id;
pdstring &name = (*all_mets)[metlcv].name;
all_metric_names[id] = name;
pdstring idString(id);
bool aflag;
aflag=(Tcl_SetVar2(interp, "metricNamesById",
const_cast<char*>(idString.c_str()),
const_cast<char*>(name.c_str()),
TCL_GLOBAL_ONLY) != NULL);
assert(aflag);
}
delete all_mets;
all_metrics_set_yet = true;
}
// Set metIndexes2Id via "temp"
(void)Tcl_UnsetVar(interp, "temp", 0);
// ignore result; temp may not have existed
pdvector<met_name_id> *curr_avail_mets_ptr = dataMgr->getAvailableMetInfo(false);
pdvector<met_name_id> &curr_avail_mets = *curr_avail_mets_ptr;
unsigned numAvailMets = curr_avail_mets.size();
assert( numAvailMets > 0 );
for (unsigned metlcv=0; metlcv < numAvailMets; metlcv++) {
pdstring metricIdStr = pdstring(curr_avail_mets[metlcv].id);
bool aflag;
aflag = (Tcl_SetVar(interp, "temp",
const_cast<char*>(metricIdStr.c_str()),
TCL_APPEND_VALUE | TCL_LIST_ELEMENT) != NULL);
assert(aflag);
}
delete curr_avail_mets_ptr;
pdstring tcommand("getMetsAndRes ");
tcommand += pdstring(UIMMsgTokenID);
tcommand += pdstring(" ") + pdstring(requestingThread);
tcommand += pdstring(" ") + pdstring(numAvailMets);
tcommand += pdstring(" $temp");
int retVal = Tcl_VarEval (interp, tcommand.c_str(), 0);
if (retVal == TCL_ERROR) {
uiMgr->showError (22, "");
cerr << Tcl_GetStringResult(interp) << endl;
thr_exit(0);
}
}
void
TclpSetVariables(
Tcl_Interp *interp)
{
#ifndef NO_UNAME
struct utsname name;
#endif
int unameOK;
Tcl_DString ds;
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
#if MAC_OS_X_VERSION_MAX_ALLOWED > 1020
/*
* Set msgcat fallback locale to current CFLocale identifier.
*/
CFLocaleRef localeRef;
if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL &&
(localeRef = CFLocaleCopyCurrent())) {
CFStringRef locale = CFLocaleGetIdentifier(localeRef);
if (locale) {
char loc[256];
if (CFStringGetCString(locale, loc, 256, kCFStringEncodingUTF8)) {
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY);
}
}
CFRelease(localeRef);
}
#endif /* MAC_OS_X_VERSION_MAX_ALLOWED > 1020 */
if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
CONST char *str;
CFBundleRef bundleRef;
Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
if ((str != NULL) && (str[0] != '\0')) {
char *p = Tcl_DStringValue(&ds);
/*
* Convert DYLD_FRAMEWORK_PATH from colon to space separated.
*/
do {
if (*p == ':') {
*p = ' ';
}
} while (*p++);
Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_DStringFree(&ds);
}
bundleRef = CFBundleGetMainBundle();
if (bundleRef) {
CFURLRef frameworksURL;
Tcl_StatBuf statBuf;
frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef);
if (frameworksURL) {
if (CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
}
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifndef NO_UNAME
if (uname(&name) >= 0) {
CONST char *native;
unameOK = 1;
native = Tcl_ExternalToUtfDString(NULL, name.sysname, -1, &ds);
Tcl_SetVar2(interp, "tcl_platform", "os", native, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* The following code is a special hack to handle differences in the
* way version information is returned by uname. On most systems the
* full version number is available in name.release. However, under
* AIX the major version number is in name.version and the minor
* version number is in name.release.
*/
if ((strchr(name.release, '.') != NULL)
|| !isdigit(UCHAR(name.version[0]))) { /* INTL: digit */
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY);
} else {
#ifdef DJGPP
/*
* For some obscure reason DJGPP puts major version into
* name.release and minor into name.version. As of DJGPP 2.04 this
* is documented in djgpp libc.info file.
*/
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#else
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.version,
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", ".",
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", name.release,
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
#endif /* DJGPP */
}
Tcl_SetVar2(interp, "tcl_platform", "machine", name.machine,
TCL_GLOBAL_ONLY);
}
#endif /* !NO_UNAME */
if (!unameOK) {
Tcl_SetVar2(interp, "tcl_platform", "os", "", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", "", TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "machine", "", TCL_GLOBAL_ONLY);
}
/*
* Copy the username of the real user (according to getuid()) into
* tcl_platform(user).
*/
{
struct passwd *pwEnt = TclpGetPwUid(getuid());
const char *user;
if (pwEnt == NULL) {
user = "";
Tcl_DStringInit(&ds); /* ensure cleanliness */
} else {
user = Tcl_ExternalToUtfDString(NULL, pwEnt->pw_name, -1, &ds);
}
Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
}
}
int text_cmd_plugin(ClientData cd, Tcl_Interp *interp, int argc,
const char *argv[]) {
VMDApp *app = (VMDApp *)cd;
if (!app)
return TCL_ERROR;
// plugin dlopen <filename>
if (argc == 3 && !strupncmp(argv[1], "dlopen", CMDLEN)) {
int rc = app->plugin_dlopen(argv[2]);
if (rc < 0) {
Tcl_AppendResult(interp, "Unable to dlopen plugin file ", argv[2], NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(rc));
return TCL_OK;
}
// plugin update -- updates list of plugins
if (argc == 2 && !strupncmp(argv[1], "update", CMDLEN)) {
app->plugin_update();
return TCL_OK;
}
// plugin list [type]: returns list of category/name pairs. If optional
// type is specified, return only plugins of that type.
if ((argc == 2 || argc == 3) && !strupncmp(argv[1], "list", CMDLEN)) {
const char *type = NULL;
if (argc == 3)
type = argv[2];
PluginList pluginlist;
app->list_plugins(pluginlist, type);
const int num = pluginlist.num();
Tcl_Obj *result = Tcl_NewListObj(0, NULL);
for (int i=0; i<num; i++) {
vmdplugin_t *p = pluginlist[i];
Tcl_Obj *listelem = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(interp, listelem, Tcl_NewStringObj(p->type,-1));
Tcl_ListObjAppendElement(interp, listelem, Tcl_NewStringObj(p->name,-1));
Tcl_ListObjAppendElement(interp, result, listelem);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
// plugin info <type> <name> <varname>
// Puts plugin information for the specified plugin into the array variable
// specified by varname. The following array keys will be used: type,
// name, author, majorversion, minorversion, reentrant.
// returns 1 if plugin information was found, or 0 if no plugin information
// is available for that type and name.
if (argc == 5 && !strupncmp(argv[1], "info", CMDLEN)) {
vmdplugin_t *p = app->get_plugin(argv[2], argv[3]);
if (!p) {
Tcl_SetResult(interp, (char *) "0", TCL_STATIC);
return TCL_OK;
}
char major[32], minor[32], reentrant[32];
sprintf(major, "%d", p->majorv);
sprintf(minor, "%d", p->minorv);
sprintf(reentrant, "%d", p->is_reentrant);
if (!Tcl_SetVar2(interp,argv[4], "type", p->type, TCL_LEAVE_ERR_MSG) ||
!Tcl_SetVar2(interp,argv[4], "name", p->name, TCL_LEAVE_ERR_MSG) ||
!Tcl_SetVar2(interp,argv[4], "author", p->author, TCL_LEAVE_ERR_MSG) ||
!Tcl_SetVar2(interp,argv[4], "majorversion", major, TCL_LEAVE_ERR_MSG) ||
!Tcl_SetVar2(interp,argv[4], "minorversion", minor, TCL_LEAVE_ERR_MSG) ||
!Tcl_SetVar2(interp,argv[4], "reentrant", reentrant, TCL_LEAVE_ERR_MSG)) {
Tcl_AppendResult(interp, "Unable to return plugin information in variable ", argv[4], NULL);
return TCL_ERROR;
}
Tcl_SetResult(interp, (char *) "1", TCL_STATIC);
return TCL_OK;
}
Tcl_AppendResult(interp, "Usage: \n\tplugin dlopen <filename> -- Load plugins from a dynamic library\n",
"\tplugin update -- Update the list of plugins in the GUI\n",
"\tplugin list [<plugin type>] -- List all plugins of the given type\n",
"\tplugin info <type> <name> <arrayname> -- Store info about plugin in array\n",
NULL);
return TCL_ERROR;
}
int TclTextInterp::evalString(const char *s) {
#if defined(VMD_NANOHUB)
if (Tcl_Eval(interp, s) != TCL_OK) {
#else
if (Tcl_RecordAndEval(interp, s, 0) != TCL_OK) {
#endif
// Don't print error message if there's nothing to show.
if (strlen(Tcl_GetStringResult(interp)))
msgErr << Tcl_GetStringResult(interp) << sendmsg;
return FALSE;
}
return TRUE;
}
void TclTextInterp::setString(const char *name, const char *val) {
if (interp)
Tcl_SetVar(interp, name, val,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
}
void TclTextInterp::setMap(const char *name, const char *key,
const char *val) {
if (interp)
Tcl_SetVar2(interp, name, key, val,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
}
// There's a fair amount of code duplication between doEvent and evalFile,
// maybe these could be combined somehow, say by having TclTextInterp keep
// track of its Tcl_Channel objects.
//
// Side note: Reading line-by-line gives different Tcl semantics than
// just calling Tcl_EvalFile. Shell commands (e.g., stty) are properly
// parsed when read line-by-line and passed to Tcl_RecordAndEval, but are
// unrecognized when contained in a file read by Tcl_EvalFile. I would
// consider this a bug.
int TclTextInterp::evalFile(const char *fname) {
Tcl_Channel inchannel = Tcl_OpenFileChannel(interp, fname, "r", 0644);
Tcl_Channel outchannel = Tcl_GetStdChannel(TCL_STDOUT);
if (inchannel == NULL) {
msgErr << "Error opening file " << fname << sendmsg;
msgErr << Tcl_GetStringResult(interp) << sendmsg;
return 1;
}
Tcl_Obj *cmdPtr = Tcl_NewObj();
Tcl_IncrRefCount(cmdPtr);
int length = 0;
while ((length = Tcl_GetsObj(inchannel, cmdPtr)) >= 0) {
Tcl_AppendToObj(cmdPtr, "\n", 1);
char *stringrep = Tcl_GetStringFromObj(cmdPtr, NULL);
if (!Tcl_CommandComplete(stringrep)) {
continue;
}
// check if "exit" was called
if (app->exitFlag) break;
#if defined(VMD_NANOHUB)
Tcl_EvalObjEx(interp, cmdPtr, 0);
#else
Tcl_RecordAndEvalObj(interp, cmdPtr, 0);
#endif
#if TCL_MINOR_VERSION >= 4
Tcl_DecrRefCount(cmdPtr);
cmdPtr = Tcl_NewObj();
Tcl_IncrRefCount(cmdPtr);
#else
// XXX this crashes Tcl 8.5.[46] with an internal panic
Tcl_SetObjLength(cmdPtr, 0);
#endif
// XXX this makes sure the display is updated
// after each line read from the file or pipe
// So, this is also where we'd optimise reading multiple
// lines at once
//
// In VR modes (CAVE, FreeVR, VR Juggler) the draw method will
// not be called from app->display_update(), so multiple lines
// of input could be combined in one frame, if possible
app->display_update();
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
char *bytes = Tcl_GetStringFromObj(resultPtr, &length);
#if defined(VMDTKCON)
if (length > 0) {
vmdcon_append(VMDCON_ALWAYS, bytes,length);
vmdcon_append(VMDCON_ALWAYS, "\n", 1);
}
vmdcon_purge();
#else
if (length > 0) {
#if TCL_MINOR_VERSION >= 4
Tcl_WriteChars(outchannel, bytes, length);
Tcl_WriteChars(outchannel, "\n", 1);
#else
Tcl_Write(outchannel, bytes, length);
Tcl_Write(outchannel, "\n", 1);
#endif
}
Tcl_Flush(outchannel);
#endif
}
Tcl_Close(interp, inchannel);
Tcl_DecrRefCount(cmdPtr);
return 0;
}
/*
** Called for each row of the result.
**
** This version is used when TCL expects UTF-8 data but the database
** uses the ISO8859 format. A translation must occur from ISO8859 into
** UTF-8.
*/
static int DbEvalCallback(
void *clientData, /* An instance of CallbackData */
int nCol, /* Number of columns in the result */
char ** azCol, /* Data for each column */
char ** azN /* Name for each column */
){
CallbackData *cbData = (CallbackData*)clientData;
int i, rc;
Tcl_DString dCol;
Tcl_DStringInit(&dCol);
if( cbData->azColName==0 ){
assert( cbData->once );
cbData->once = 0;
if( cbData->zArray[0] ){
Tcl_SetVar2(cbData->interp, cbData->zArray, "*", "", 0);
}
cbData->azColName = malloc( nCol*sizeof(char*) );
if( cbData->azColName==0 ){ return 1; }
cbData->nColName = nCol;
for(i=0; i<nCol; i++){
Tcl_ExternalToUtfDString(NULL, azN[i], -1, &dCol);
cbData->azColName[i] = malloc( Tcl_DStringLength(&dCol) + 1 );
if( cbData->azColName[i] ){
strcpy(cbData->azColName[i], Tcl_DStringValue(&dCol));
}else{
return 1;
}
if( cbData->zArray[0] ){
Tcl_SetVar2(cbData->interp, cbData->zArray, "*",
Tcl_DStringValue(&dCol), TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
if( azN[nCol]!=0 ){
Tcl_DString dType;
Tcl_DStringInit(&dType);
Tcl_DStringAppend(&dType, "typeof:", -1);
Tcl_DStringAppend(&dType, Tcl_DStringValue(&dCol), -1);
Tcl_DStringFree(&dCol);
Tcl_ExternalToUtfDString(NULL, azN[i+nCol], -1, &dCol);
Tcl_SetVar2(cbData->interp, cbData->zArray,
Tcl_DStringValue(&dType), Tcl_DStringValue(&dCol),
TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
Tcl_DStringFree(&dType);
}
}
Tcl_DStringFree(&dCol);
}
}
if( azCol!=0 ){
if( cbData->zArray[0] ){
for(i=0; i<nCol; i++){
char *z = azCol[i];
if( z==0 ) z = "";
Tcl_DStringInit(&dCol);
Tcl_ExternalToUtfDString(NULL, z, -1, &dCol);
Tcl_SetVar2(cbData->interp, cbData->zArray, cbData->azColName[i],
Tcl_DStringValue(&dCol), 0);
Tcl_DStringFree(&dCol);
}
}else{
for(i=0; i<nCol; i++){
char *z = azCol[i];
if( z==0 ) z = "";
Tcl_DStringInit(&dCol);
Tcl_ExternalToUtfDString(NULL, z, -1, &dCol);
Tcl_SetVar(cbData->interp, cbData->azColName[i],
Tcl_DStringValue(&dCol), 0);
Tcl_DStringFree(&dCol);
}
}
}
rc = Tcl_EvalObj(cbData->interp, cbData->pCode);
if( rc==TCL_CONTINUE ) rc = TCL_OK;
cbData->tcl_rc = rc;
return rc!=TCL_OK;
}
void RtdPerf::reset()
{
char* var = name();
dbl_->log("Reset performance data: %s\n", name());
on(0);
imageCount_ = 0.0;
lastTimeStamp_ = startTime_ = 0.0;
GENtime_ = TCLtime_ = Xtime_ = FREQtime_ = 0.0;
accGENtime_ = accTCLtime_ = accXtime_ = accFREQtime_ = 0.0;
// Clear the Tcl variables.
Tcl_SetVar2(interp_, var, "PERF_COUNT", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_FREQ", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_GEN", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_XFUNC", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_TCL", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_TOTAL", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_FREQ_AVE", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_GEN_AVE", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_XFUNC_AVE", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_TCL_AVE", 0, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp_, var, "PERF_TOTAL_AVE", 0, TCL_GLOBAL_ONLY);
}
/*
* This routine sets the variables of the performance test indicator form,
* when it is realised.
*/
void RtdPerf::endCycle()
{
if ( ! isOn() ) // performance testing is not activated
return;
char* var = name();
dbl_->log("Ended image event cycle: %s\n", name());
imageCount_++;
// Set the frequency Tcl variables. Needs at least two cycles
if (imageCount_ > 1) {
timeInc(&FREQtime_); // set lastTimeStamp_ to current time
FREQtime_ = lastTimeStamp_ - startTime_;
accFREQtime_ += FREQtime_;
sprintf(buffer_, "%.3f", 1.0 / FREQtime_);
Tcl_SetVar2(interp_, var, "PERF_FREQ", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%.3f", (imageCount_ - 1.0) / accFREQtime_);
Tcl_SetVar2(interp_, var, "PERF_FREQ_AVE", buffer_, TCL_GLOBAL_ONLY);
}
startTime_ = lastTimeStamp_;
// Set the total time for the image event.
double aveXtime, aveGENtime, aveTCLtime; // Accumulated averages
double TOTtime = GENtime_ + Xtime_ + TCLtime_;
// Accumulate times (these are total times over all images).
accGENtime_ += GENtime_;
accTCLtime_ += TCLtime_;
accXtime_ += Xtime_;
// Average all the totals. Times in %
double aveTOTtime =
(accGENtime_ + accTCLtime_ + accXtime_) / imageCount_;
aveGENtime = accGENtime_ / imageCount_ * 100.0 / aveTOTtime;
aveXtime = accXtime_ / imageCount_ * 100.0 / aveTOTtime;
aveTCLtime = accTCLtime_ / imageCount_ * 100.0 / aveTOTtime;
GENtime_ = GENtime_ * 100.0 / TOTtime;
Xtime_ = Xtime_ * 100.0 / TOTtime;
TCLtime_ = TCLtime_ * 100.0 / TOTtime;
// Set the Tcl variables
sprintf(buffer_, "%.0f", imageCount_);
Tcl_SetVar2(interp_, var, "PERF_COUNT", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%6.3f", GENtime_);
Tcl_SetVar2(interp_, var, "PERF_GEN", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%6.3f", Xtime_);
Tcl_SetVar2(interp_, var, "PERF_XFUNC", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%6.3f", TCLtime_);
Tcl_SetVar2(interp_, var, "PERF_TCL", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%8.3f", TOTtime * 1.0e+3); // in msec
Tcl_SetVar2(interp_, var, "PERF_TOTAL", buffer_, TCL_GLOBAL_ONLY);
// Do the same for the averaged amounts.
sprintf(buffer_, "%6.3f", aveGENtime);
Tcl_SetVar2(interp_, var, "PERF_GEN_AVE", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%6.3f", aveXtime);
Tcl_SetVar2(interp_, var, "PERF_XFUNC_AVE", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%6.3f", aveTCLtime);
Tcl_SetVar2(interp_, var, "PERF_TCL_AVE", buffer_, TCL_GLOBAL_ONLY);
sprintf(buffer_, "%6.3f", aveTOTtime * 1.0e+3); // in msec
Tcl_SetVar2(interp_, var, "PERF_TOTAL_AVE", buffer_, TCL_GLOBAL_ONLY);
}
int RplCmd::handle_rpl(ClientData clientData, Tcl_Interp *interp, int argc,char *argv[])
{
const char* stoptcl = Tcl_GetVar(interp,"StopTcl",TCL_GLOBAL_ONLY);
if(stoptcl != NULL && (bcmp(stoptcl,"yes",3) == 0)) //TclIntepreter thread stop
return TCL_BREAK;
if(argc != 3)
{
//DataLog::insertERROR("uip6 command wrong, usage: uip6 {ICMP/UDP/TCP} packetName");
return TCL_ERROR;
}
if(strcmp(argv[1],"RPL") != 0)
{
return TCL_ERROR;
}
char* packetName = argv[2];
struct DIO *dio = (struct DIO*)malloc(sizeof(DIO));
const char* a = Tcl_GetVar2(interp,packetName,"DIO,Interval_Doublings",TCL_GLOBAL_ONLY);
dio->instanceId = atoi(Tcl_GetVar2(interp,packetName,"DIO,Instance_Id",TCL_GLOBAL_ONLY));
dio->version = atoi(Tcl_GetVar2(interp,packetName,"DIO,Version",TCL_GLOBAL_ONLY));
dio->rank = atoi(Tcl_GetVar2(interp,packetName,"DIO,Rank",TCL_GLOBAL_ONLY));
dio->dagGrounded = atoi(Tcl_GetVar2(interp,packetName,"DIO,Gounded",TCL_GLOBAL_ONLY));
dio->instanceMop = atoi(Tcl_GetVar2(interp,packetName,"DIO,Mop",TCL_GLOBAL_ONLY));
memcpy(dio->dag_id,Tcl_GetVar2(interp,packetName,"DIO,Dag_Id",TCL_GLOBAL_ONLY),16);
//dio->instanceMop = 0;
dio->dioIntDoubl = atoi(Tcl_GetVar2(interp,packetName,"DIO,Interval_Doublings",TCL_GLOBAL_ONLY));
dio->dioIntMin = atoi(Tcl_GetVar2(interp,packetName,"DIO,Interval_Min",TCL_GLOBAL_ONLY));
dio->dioRedundancy = atoi(Tcl_GetVar2(interp,packetName,"DIO,Redundancy_Constant",TCL_GLOBAL_ONLY));
dio->maxRankInc = atoi(Tcl_GetVar2(interp,packetName,"DIO,Max_Rank_Inc",TCL_GLOBAL_ONLY));
dio->minHopRankInc = atoi(Tcl_GetVar2(interp,packetName,"DIO,Min_Hop_Rank_Inc",TCL_GLOBAL_ONLY));
dio->defaultLifetime = atoi(Tcl_GetVar2(interp,packetName,"DIO,Default_Lifetime",TCL_GLOBAL_ONLY));
dio->lifetimeUnit = atoi(Tcl_GetVar2(interp,packetName,"DIO,Lifetime_Unit",TCL_GLOBAL_ONLY));
memcpy(dio->addrPrefix, Tcl_GetVar2(interp,packetName,"DIO,Prefix",TCL_GLOBAL_ONLY),16);
//ipv6 traffic field
// if(traffic == NULL) //使用默认值
// {
// traffic = Tcl_GetVar2(interp,"IPv6","Traffic_Class",TCL_GLOBAL_ONLY);
// if(traffic == NULL)
// {
// DataLog::insertERROR("Traffic_Class filed has no value");
// return TCL_ERROR;
// }
// }
// UIP_IP_BUF->tcflow = atoi(traffic);
//ipv6 flow field
// if(flow == NULL)
// {
// flow = Tcl_GetVar2(interp,"IPv6","Flow_Label",TCL_GLOBAL_ONLY);
// if(flow == NULL)
// {
// DataLog::insertERROR("Flow_Label filed has no value");
// return TCL_ERROR;
// }
// }
// UIP_IP_BUF->flow = atoi(flow);
// //ipv6 next header field
// if(nextheader == NULL)
// {
// nextheader = Tcl_GetVar2(interp,"IPv6","Next_Header",TCL_GLOBAL_ONLY);
// if(nextheader == NULL)
// {
// DataLog::insertERROR("Next_Header filed has no value");
// return TCL_ERROR;
// }
// }
// UIP_IP_BUF->proto = atoi(nextheader);
// //ipv6 hoplimit field
// if(hoplimit == NULL)
// {
// hoplimit = Tcl_GetVar2(interp,"IPv6","Hop_Limit",TCL_GLOBAL_ONLY);
// if(hoplimit == NULL)
// {
// DataLog::insertERROR("Hop_Limit filed has no value");
// return TCL_ERROR;
// }
// }
// UIP_IP_BUF->ttl = atoi(hoplimit);
// //ipv6 destination address field
// if(dest == NULL)
// {
// dest = Tcl_GetVar2(interp,"IPv6","Destination_Address",TCL_GLOBAL_ONLY);
// if(dest == NULL)
// {
// DataLog::insertERROR("Destination_Address filed has no value");
// return TCL_ERROR;
// }
// }
// Converts::charToByte(dest,32,(unsigned char *)&UIP_IP_BUF->destipaddr);
// //ipv6 source address field
// if(src == NULL)
// {
// src = Tcl_GetVar2(interp,"IPv6","Source_Address",TCL_GLOBAL_ONLY);
// if(src == NULL)
// {
// DataLog::insertERROR("Source_Address filed has no value");
// return TCL_ERROR;
// }
// }
char convert[sizeof(DIO)*2];
Converts::byteToChar((unsigned char*)dio,sizeof(DIO), convert);
Tcl_SetVar2(interp,packetName,"DIO,data",convert,TCL_GLOBAL_ONLY);
//const char* data = Tcl_GetVar2(interp,argv[1],"DIO,data",TCL_GLOBAL_ONLY);
//struct DIO *dio1 = (struct DIO*)malloc(sizeof(DIO));
//int test = Converts::charToByte((const char*)convert,sizeof(DIO),(unsigned char*)dio1);
return TCL_OK;
}
int Tk_utils_Init(Tcl_Interp *interp) {
char *s, c[20], *lib = NULL, buf[1024];
our_interp = interp;
/* FIXME: Remove this, but firstly we need to remove from tcl code */
Tcl_SetVar2(interp, "licence","type", "f", TCL_GLOBAL_ONLY);
/* Master subversion repository version */
Tcl_SetVar(interp, "svn_version", SVN_VERS, TCL_GLOBAL_ONLY);
/* Keyed lists from tclX */
TclX_KeyedListInit(interp);
/* Our updated Raster widget */
Raster_Init(interp);
/* Our own widgets and commands */
Tk_utils_Misc_Init(interp);
TextOutput_Init(interp);
Trace_Init(interp);
Sheet_Init(interp);
/* Other ancillary commands */
Tcl_CreateObjCommand(interp, "read_seq_trace", tcl_read_seq_trace,
(ClientData) NULL,
NULL);
/* Used only by spin2; not currently supported */
/*
Container_Init(interp);
Tk_CreateItemType(&tkGraphType);
Tcl_GraphInit(interp);
*/
/* SeqReg_Init(interp); */
/*
* The auto_path.
*/
if (lib = getenv("STADTCL")) {
sprintf(buf, "%s/tk_utils", lib);
lib = buf;
}
if (lib) {
char *argv[3];
int argc = 3;
char *merged;
argv[0] = "lappend";
argv[1] = "auto_path";
argv[2] = lib;
Tcl_Eval(interp, merged = Tcl_Merge(argc, argv));
Tcl_Free(merged);
}
/*
* Set packages(name). This is done to prevent subsequent reloading
* of this library (for efficiency reasons). The only reason that this
* is necessary is that currently gap4 dynamically links with some
* libraries at link time. When they're all at run time this won't
* be necessary.
*/
if (s = Tcl_GetVar2(interp, "packages", "tk_utils", TCL_GLOBAL_ONLY))
sprintf(c, "%d", atoi(s)|2);
else
strcpy(c, "2");
Tcl_SetVar2(interp, "packages", "tk_utils", c, TCL_GLOBAL_ONLY);
/*
* tk_utils_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 tk_utils_defs though as initially it doesn't
* exist.
*/
{
Tcl_Obj *val = Tcl_NewStringObj("", -1);
defs_name = Tcl_NewStringObj("tk_utils_defs", -1); /* global */
tk_utils_defs = Tcl_ObjSetVar2(interp, defs_name, NULL, val,
TCL_GLOBAL_ONLY);
Tcl_TraceVar(interp, "tk_utils_defs",
TCL_TRACE_WRITES | TCL_GLOBAL_ONLY,
tk_utils_defs_trace, NULL);
}
return Tcl_PkgProvide(interp, "tk_utils", "1.0");
}
/* draw the contig lines of the contig selector */
int
display_contigs(Tcl_Interp *interp, /* in */
GapIO *io, /* in */
char *win_name, /* in */
char *colour, /* in */
int width, /* in */
int tick_wd, /* in */
int tick_ht, /* in */
int offset, /* in */
char *direction) /* in */
{
char cmd[1024];
int i;
int x1 = 1;
int x2 = x1;
int y1 = 1;
int y2 = y1;
sprintf(cmd, "%s delete all", win_name);
Tcl_Eval(interp, cmd);
/* draw first tick */
if (strcmp(direction, "horizontal")==0){
sprintf(cmd, "%s create line %d %d %d %d "
"-fill %s -width %d -tags sep_1\n",
win_name, x1, offset-tick_ht, x1, offset+tick_ht,
colour, tick_wd);
} else if (strcmp(direction, "vertical")==0){
sprintf(cmd, "%s create line %d %d %d %d "
"-fill %s -width %d -tags sep_1\n",
win_name, offset-tick_ht, y1, offset+tick_ht, y1,
colour, tick_wd);
}
/* printf("cmd %s \n", cmd); */
Tcl_Eval(interp, cmd);
#ifdef DEBUG
printf("num contigs %d \n", NumContigs(io));
for (i = 0; i < NumContigs(io); i++ ){
printf("i %d %d\n", i, arr(GCardinal, io->contig_order, i));
}
#endif
for (i = 0; i < NumContigs(io); i++){
if (arr(GCardinal, io->contig_order, i) > 0) {
int clen = io_clength(io, arr(GCardinal, io->contig_order, i));
if (strcmp(direction, "horizontal")==0){
x1 = x2;
x2 = clen + x2;
/*
printf("i %d num %d length %d x1 %d x2 %d \n",
i, arr(GCardinal, io->contig_order, i), clen,
x1, x2);
*/
/* contig line */
sprintf(cmd,"%s create line %d %d %d %d "
"-fill %s -width %d "
"-tags {contig c_%d num_%d hl_%d S}\n",
win_name, x1, offset, x2, offset,
colour, width, i+1,
arr(GCardinal, io->contig_order, i),
arr(GCardinal, io->contig_order, i));
} else if (strcmp(direction, "vertical")==0){
y1 = y2;
y2 = clen + y2;
sprintf(cmd,"%s create line %d %d %d %d "
"-fill %s -width %d "
"-tags {contig c_%d num_%d hl_%d S}\n",
win_name, offset, y1, offset, y2,
colour, width, i+1,
arr(GCardinal, io->contig_order, i),
arr(GCardinal, io->contig_order, i));
}
Tcl_Eval(interp, cmd);
/* Store canvas item number in an array containing contig no. */
{
char aname[1024], aele[50];
sprintf(aname, "%s.Cnum", win_name);
sprintf(aele, "%d", i+1);
Tcl_SetVar2(interp, aname, aele, Tcl_GetStringResult(interp),
TCL_GLOBAL_ONLY);
}
/* tick at end of line */
if (strcmp(direction, "horizontal")==0){
sprintf(cmd, "%s create line %d %d %d %d "
"-fill %s -width %d -tags sep_%d\n",
win_name, x2, offset-tick_ht, x2, offset+tick_ht,
colour, tick_wd, i+2);
} else if (strcmp(direction, "vertical")==0){
sprintf(cmd, "%s create line %d %d %d %d "
"-fill %s -width %d -tags sep_%d\n",
win_name, offset-tick_ht, y2, offset+tick_ht, y2,
colour, tick_wd, i+2);
}
/* printf("cmd %s \n", cmd); */
Tcl_Eval(interp, cmd);
}
}
return TCL_OK;
}
/* ARGSUSED */
static char *
EnvTraceProc(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
const char *name2, /* Name of variable being modified, or NULL if
* whole array is being deleted (UTF-8). */
int flags) /* Indicates what's happening. */
{
/*
* For array traces, let TclSetupEnv do all the work.
*/
if (flags & TCL_TRACE_ARRAY) {
TclSetupEnv(interp);
return NULL;
}
/*
* If name2 is NULL, then return and do nothing.
*/
if (name2 == NULL) {
return NULL;
}
/*
* If a value is being set, call TclSetEnv to do all of the work.
*/
if (flags & TCL_TRACE_WRITES) {
const char *value;
value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
TclSetEnv(name2, value);
}
/*
* If a value is being read, call TclGetEnv to do all of the work.
*/
if (flags & TCL_TRACE_READS) {
Tcl_DString valueString;
const char *value = TclGetEnv(name2, &valueString);
if (value == NULL) {
return "no such variable";
}
Tcl_SetVar2(interp, name1, name2, value, 0);
Tcl_DStringFree(&valueString);
}
/*
* For unset traces, let TclUnsetEnv do all the work.
*/
if (flags & TCL_TRACE_UNSETS) {
TclUnsetEnv(name2);
}
return NULL;
}
