static void
ThreadErrorProc(
Tcl_Interp *interp) /* Interp that failed */
{
Tcl_Channel errChannel;
const char *errorInfo, *argv[3];
char *script;
char buf[TCL_DOUBLE_SPACE+1];
sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
Tcl_WriteChars(errChannel, buf, -1);
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_WriteChars(errChannel, errorInfo, -1);
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
TclThreadSend(interp, errorThreadId, script, 0);
ckfree(script);
}
}
rpmtcl rpmtclNew(char ** av, uint32_t flags)
{
rpmtcl tcl =
#ifdef NOTYET
(flags & 0x80000000) ? rpmtclI() :
#endif
rpmtclGetPool(_rpmtclPool);
#if defined(WITH_TCL)
static char * _av[] = { "rpmtcl", NULL };
Tcl_Interp * tclI = Tcl_CreateInterp();
char b[32];
int ac;
if (av == NULL) av = _av;
ac = argvCount((ARGV_t)av);
Tcl_SetVar(tclI, "argv", Tcl_Merge(ac-1, (const char *const *)av+1), TCL_GLOBAL_ONLY);
(void)sprintf(b, "%d", ac-1);
Tcl_SetVar(tclI, "argc", b, TCL_GLOBAL_ONLY);
Tcl_SetVar(tclI, "argv0", av[0], TCL_GLOBAL_ONLY);
Tcl_SetVar(tclI, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
tcl->I = tclI;
{ Tcl_Channel tclout = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_SetChannelOption(tclI, tclout, "-translation", "auto");
Tcl_StackChannel(tclI, &rpmtclIO, tcl, TCL_WRITABLE, tclout);
tcl->tclout = (void *) tclout;
}
#endif
tcl->iob = rpmiobNew(0);
return rpmtclLink(tcl);
}
pure_expr *tk_join(pure_expr *x)
{
size_t i, n;
pure_expr **xv;
if (pure_is_listv(x, &n, &xv)) {
char *s, *ret;
char **argv = (char**)malloc(n*sizeof(char*));
pure_expr *x;
for (i = 0; i < n; i++) {
x = xv[i];
if (pure_is_string_dup(x, &s))
argv[i] = s;
else {
size_t j;
for (j = 0; j < i; j++) free(argv[j]);
free(argv);
free(xv);
return NULL;
}
}
free(xv);
ret = Tcl_Merge(n, (const char**)argv);
for (i = 0; i < n; i++) free(argv[i]);
free(argv);
x = pure_string_dup(ret);
Tcl_Free(ret);
return x;
} else
return NULL;
}
/* Fill a preallocated vector arguments, doing expansion and all.
* Assumes Tcl will
* not tamper with our strings
* make copies if strings are "persistent"
*/
int fill_args (char **argv, int where, value v)
{
value l;
switch (Tag_val(v)) {
case 0:
argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
return (where + 1);
case 1:
for (l=Field(v,0); Is_block(l); l=Field(l,1))
where = fill_args(argv,where,Field(l,0));
return where;
case 2:
{ char **tmpargv;
char *merged;
int i;
int size = argv_size(Field(v,0));
tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
fill_args(tmpargv,0,Field(v,0));
tmpargv[size] = NULL;
merged = Tcl_Merge(size,tmpargv);
for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
stat_free((char *)tmpargv);
/* must be freed by stat_free */
argv[where] = (char*)stat_alloc(strlen(merged)+1);
strcpy(argv[where], merged);
Tcl_Free(merged);
return (where + 1);
}
default:
tk_error("fill_args: illegal tag");
}
}
/*
* Provide user feedback and warnings beyond result values.
* If we are running interactively, Tcl_Main will take care of echoing results
* to the console. If we run a script, we need to output the results
* ourselves.
*/
void newhandle_msg(void *v, const char *msg) {
Tcl_Interp *interp = (Tcl_Interp *)v;
const char *words[3] = {"puts", "-nonewline", "psfgen) "};
char *script = NULL;
// prepend "psfgen) " to all output
script = Tcl_Merge(3, words);
Tcl_Eval(interp,script);
Tcl_Free(script);
// emit the output
words[1] = msg;
script = Tcl_Merge(2, words);
Tcl_Eval(interp,script);
Tcl_Free(script);
}
static int
get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
char **new_args;
char *merge;
int result, i;
/* We can't directly run Tk_GetOpenFile, because it wants some
ClientData that we're best off not knowing. So instead we
re-eval. This is a lot less efficient, but it doesn't really
matter. */
new_args = (char **) ckalloc ((argc + 2) * sizeof (char *));
new_args[0] = "tk_getOpenFile";
new_args[1] = "-choosedir";
new_args[2] = "1";
for (i = 1; i < argc; ++i)
new_args[2 + i] = argv[i];
merge = Tcl_Merge (argc + 2, new_args);
result = Tcl_GlobalEval (interp, merge);
ckfree (merge);
ckfree ((char *) new_args);
return result;
}
static char *
FormatConfigInfo(
Tcl_Interp *interp, /* Interpreter to use for things like
* floating-point precision. */
Tk_Window tkwin, /* Window corresponding to widget. */
register Tk_ConfigSpec *specPtr,
/* Pointer to information describing
* option. */
char *widgRec) /* Pointer to record holding current values of
* info for widget. */
{
CONST char *argv[6];
char *result;
char buffer[200];
Tcl_FreeProc *freeProc = NULL;
argv[0] = specPtr->argvName;
argv[1] = specPtr->dbName;
argv[2] = specPtr->dbClass;
argv[3] = specPtr->defValue;
if (specPtr->type == TK_CONFIG_SYNONYM) {
return Tcl_Merge(2, argv);
}
argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer,
&freeProc);
if (argv[1] == NULL) {
argv[1] = "";
}
if (argv[2] == NULL) {
argv[2] = "";
}
if (argv[3] == NULL) {
argv[3] = "";
}
if (argv[4] == NULL) {
argv[4] = "";
}
result = Tcl_Merge(5, argv);
if (freeProc != NULL) {
if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) {
ckfree((char *)argv[4]);
} else {
(*freeProc)((char *)argv[4]);
}
}
return result;
}
/*
* Same as above but allow user control over prepending of "psfgen) "
* and newlines.
*/
void newhandle_msg_ex(void *v, const char *msg, int prepend, int newline) {
Tcl_Interp *interp = (Tcl_Interp *)v;
const char *words[3] = {"puts", "-nonewline", "psfgen) "};
char *script = NULL;
if (prepend) {
// prepend "psfgen) " to all output
script = Tcl_Merge(3, words);
Tcl_Eval(interp,script);
Tcl_Free(script);
}
// emit the output
if (newline) {
words[1] = msg;
script = Tcl_Merge(2, words);
} else {
words[2] = msg;
script = Tcl_Merge(3, words);
}
Tcl_Eval(interp,script);
Tcl_Free(script);
}
/* after initial data has been loaded, & maybe again later */
int Nget_height_cmd(Nv_data * data, Tcl_Interp * interp, /* Current interpreter. */
int argc, char **argv)
{
float longdim, exag, texag, hmin, hmax;
int nsurfs, i, *surf_list;
char min[128];
char max[128];
char val[128];
float fmin, fmax;
char *list[4];
surf_list = GS_get_surf_list(&nsurfs);
if (nsurfs) {
GS_get_longdim(&longdim);
GS_get_zrange_nz(&hmin, &hmax);
exag = 0.0;
for (i = 0; i < nsurfs; i++) {
if (GS_get_exag_guess(surf_list[i], &texag) > -1)
if (texag)
exag = texag > exag ? texag : exag;
}
if (exag == 0.0)
exag = 1.0;
fmin = hmin - (2. * longdim / exag);
fmax = hmin + (3 * longdim / exag);
}
else {
fmax = 10000.0;
fmin = 0.0;
}
/* The one decimal place of accuracy is necessary to force Tcl to */
/* parse these values as floating point rather than integers. This */
/* avoids problems with integers which are too large to represent. */
sprintf(min, "%.1f", fmin);
sprintf(max, "%.1f", fmax);
sprintf(val, "%.1f", fmin + (fmax - fmin) / 2.0);
list[0] = val;
list[1] = min;
list[2] = max;
list[3] = NULL;
Tcl_SetResult(interp, Tcl_Merge(3, list), TCL_DYNAMIC);
return TCL_OK;
}
/*
* 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);
}
char *Tksh_ConvertList(Tcl_Interp *interp, char *list, int toMode)
{
int fromMode = (toMode == INTERP_KSH) ? INTERP_TCL : INTERP_KSH;
int oldMode, argc;
char *result, **argv;
result = NULL;
oldMode = TkshSetListMode(fromMode);
if (Tcl_SplitList(interp, list, &argc, &argv) == TCL_OK)
{
TkshSetListMode(toMode);
result = Tcl_Merge(argc, argv);
}
TkshSetListMode(oldMode);
return result;
}
/* Return list of timers. */
void list_timers(Tcl_Interp *irp, tcl_timer_t *stack)
{
char mins[10], id[16], *x;
EGG_CONST char *argv[3];
tcl_timer_t *mark;
for (mark = stack; mark; mark = mark->next) {
egg_snprintf(mins, sizeof mins, "%u", mark->mins);
egg_snprintf(id, sizeof id, "timer%lu", mark->id);
argv[0] = mins;
argv[1] = mark->cmd;
argv[2] = id;
x = Tcl_Merge(3, argv);
Tcl_AppendElement(irp, x);
Tcl_Free((char *) x);
}
}
/*
* Must be called for each and every start message in order to free the
* DString allocated.
* "parent" is a tk window path for the dialogue. Specify NULL to indicate
* a bail-out state (where we free the DString but decide not to bring up
* a message box afterall.
*/
void end_message(const char *parent)
{
int argc = 1;
char *argv[1], *merged;
argv[0] = Tcl_DStringValue(&message);
if (NULL == (merged = Tcl_Merge(argc, argv))) {
info_win = 0;
Tcl_DStringFree(&message);
return;
}
/* display message box */
if (parent && _interp) {
Tcl_VarEval(_interp, "messagebox ", parent, " ", merged, NULL);
}
info_win = 0;
Tcl_DStringFree(&message);
Tcl_Free(merged);
}
static int tcl_botlist(ClientData cd, Tcl_Interp *irp,
int argc, char *argv[])
{
char *p, sh[2], string[20];
EGG_CONST char *list[4];
tand_t *bot;
BADARGS(1, 1, "");
sh[1] = 0;
list[3] = sh;
list[2] = string;
for (bot = tandbot; bot; bot = bot->next) {
list[0] = bot->bot;
list[1] = (bot->uplink == (tand_t *) 1) ? botnetnick : bot->uplink->bot;
strncpyz(string, int_to_base10(bot->ver), sizeof string);
sh[0] = bot->share;
p = Tcl_Merge(4, list);
Tcl_AppendElement(irp, p);
Tcl_Free((char *) p);
}
return TCL_OK;
}
static int tcl_dcclist(ClientData cd, Tcl_Interp *irp,
int argc, char *argv[])
{
int i;
char *p, idxstr[10], timestamp[11], other[160];
long tv;
EGG_CONST char *list[6];
BADARGS(1, 2, " ?type?");
for (i = 0; i < dcc_total; i++) {
if (argc == 1 || ((argc == 2) && (dcc[i].type &&
!egg_strcasecmp(dcc[i].type->name, argv[1])))) {
egg_snprintf(idxstr, sizeof idxstr, "%ld", dcc[i].sock);
tv = dcc[i].timeval;
egg_snprintf(timestamp, sizeof timestamp, "%ld", tv);
if (dcc[i].type && dcc[i].type->display)
dcc[i].type->display(i, other);
else {
egg_snprintf(other, sizeof other, "?:%lX !! ERROR !!",
(long) dcc[i].type);
break;
}
list[0] = idxstr;
list[1] = dcc[i].nick;
list[2] = dcc[i].host;
list[3] = dcc[i].type ? dcc[i].type->name : "*UNKNOWN*";
list[4] = other;
list[5] = timestamp;
p = Tcl_Merge(6, list);
Tcl_AppendElement(irp, p);
Tcl_Free((char *) p);
}
}
return TCL_OK;
}
static isc_result_t
tcldb_lookup(const char *zone, const char *name, void *dbdata,
dns_sdblookup_t *lookup)
#endif /* DNS_CLIENTINFO_VERSION */
{
isc_result_t result = ISC_R_SUCCESS;
int tclres;
int rrc; /* RR count */
char **rrv; /* RR vector */
int i;
char *cmdv[3];
char *cmd;
#ifdef DNS_CLIENTINFO_VERSION
UNUSED(methods);
UNUSED(clientinfo);
#endif /* DNS_CLIENTINFO_VERSION */
tcldb_driver_t *driver = (tcldb_driver_t *) dbdata;
cmdv[0] = "lookup";
cmdv[1] = zone;
cmdv[2] = name;
cmd = Tcl_Merge(3, cmdv);
tclres = Tcl_Eval(driver->interp, cmd);
Tcl_Free(cmd);
if (tclres != TCL_OK) {
isc_log_write(dns_lctx, DNS_LOGCATEGORY_GENERAL,
DNS_LOGMODULE_SDB, ISC_LOG_ERROR,
"zone '%s': tcl lookup function failed: %s",
zone, driver->interp->result);
return (ISC_R_FAILURE);
}
if (strcmp(driver->interp->result, "NXDOMAIN") == 0) {
result = ISC_R_NOTFOUND;
goto fail;
}
tclres = Tcl_SplitList(driver->interp, driver->interp->result,
&rrc, &rrv);
if (tclres != TCL_OK)
goto malformed;
for (i = 0; i < rrc; i++) {
isc_result_t tmpres;
int fieldc; /* Field count */
char **fieldv; /* Field vector */
tclres = Tcl_SplitList(driver->interp, rrv[i],
&fieldc, &fieldv);
if (tclres != TCL_OK) {
tmpres = ISC_R_FAILURE;
goto failrr;
}
if (fieldc != 3)
goto malformed;
tmpres = dns_sdb_putrr(lookup, fieldv[0], atoi(fieldv[1]),
fieldv[2]);
Tcl_Free((char *) fieldv);
failrr:
if (tmpres != ISC_R_SUCCESS)
result = tmpres;
}
Tcl_Free((char *) rrv);
if (result == ISC_R_SUCCESS)
return (result);
malformed:
isc_log_write(dns_lctx, DNS_LOGCATEGORY_GENERAL,
DNS_LOGMODULE_SDB, ISC_LOG_ERROR,
"zone '%s': "
"malformed return value from tcl lookup function: %s",
zone, driver->interp->result);
result = ISC_R_FAILURE;
fail:
return (result);
}
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");
}
static int tcl_whom(ClientData cd, Tcl_Interp *irp,
int argc, char *argv[])
{
int chan, i;
char c[2], idle[11], work[20], *p;
long tv = 0;
EGG_CONST char *list[7];
BADARGS(2, 2, " chan");
if (argv[1][0] == '*')
chan = -1;
else {
if ((argv[1][0] < '0') || (argv[1][0] > '9')) {
Tcl_SetVar(interp, "chan", argv[1], 0);
if ((Tcl_VarEval(interp, "assoc ", "$chan", NULL) != TCL_OK) ||
!interp->result[0]) {
Tcl_AppendResult(irp, "channel name is invalid", NULL);
return TCL_ERROR;
}
chan = atoi(interp->result);
} else
chan = atoi(argv[1]);
if ((chan < 0) || (chan > 199999)) {
Tcl_AppendResult(irp, "channel out of range; must be 0 through 199999",
NULL);
return TCL_ERROR;
}
}
for (i = 0; i < dcc_total; i++)
if (dcc[i].type == &DCC_CHAT) {
if (dcc[i].u.chat->channel == chan || chan == -1) {
c[0] = geticon(i);
c[1] = 0;
tv = (now - dcc[i].timeval) / 60;
egg_snprintf(idle, sizeof idle, "%li", tv);
list[0] = dcc[i].nick;
list[1] = botnetnick;
list[2] = dcc[i].host;
list[3] = c;
list[4] = idle;
list[5] = dcc[i].u.chat->away ? dcc[i].u.chat->away : "";
if (chan == -1) {
egg_snprintf(work, sizeof work, "%d", dcc[i].u.chat->channel);
list[6] = work;
}
p = Tcl_Merge((chan == -1) ? 7 : 6, list);
Tcl_AppendElement(irp, p);
Tcl_Free((char *) p);
}
}
for (i = 0; i < parties; i++) {
if (party[i].chan == chan || chan == -1) {
c[0] = party[i].flag;
c[1] = 0;
if (party[i].timer == 0L)
strcpy(idle, "0");
else {
tv = (now - party[i].timer) / 60;
egg_snprintf(idle, sizeof idle, "%li", tv);
}
list[0] = party[i].nick;
list[1] = party[i].bot;
list[2] = party[i].from ? party[i].from : "";
list[3] = c;
list[4] = idle;
list[5] = party[i].status & PLSTAT_AWAY ? party[i].away : "";
if (chan == -1) {
egg_snprintf(work, sizeof work, "%d", party[i].chan);
list[6] = work;
}
p = Tcl_Merge((chan == -1) ? 7 : 6, list);
Tcl_AppendElement(irp, p);
Tcl_Free((char *) p);
}
}
return TCL_OK;
}
//
// to create a NL frame element and add to the domain
//
int
TclModelBuilder_addFrameElement(ClientData clientData, Tcl_Interp *interp,
int inArgc, TCL_Char **inArgv,
Domain *theDomain,
TclModelBuilder *theBuilder)
{
theTclModelBuilderDomain = theDomain;
theTclModelBuilder = theBuilder;
int NDM, NDF;
NDM = theTclModelBuilder->getNDM(); // dimension of the structure (1d, 2d, or 3d)
NDF = theTclModelBuilder->getNDF(); // number of degrees of freedom per node
// split possible lists present in argv
char *List;
List = Tcl_Merge (inArgc, inArgv);
if (List == 0)
{
opserr << "WARNING - TclModelBuilder_addFrameElement - problem merging list\n";
return TCL_ERROR;
}
// opserr << "List :" << List << endln;
// remove braces from list
for (int i = 0; List[i] != '\0'; i++)
{
if ((List[i] == '{') || (List[i] == '}'))
List[i] = ' ';
}
int argc;
TCL_Char **argv;
if (Tcl_SplitList(interp, List, &argc, &argv) != TCL_OK)
{
opserr << "WARNING - TclModelBuilder_addFrameElement - problem spliting list\n";
return TCL_ERROR;
}
Tcl_Free (List);
// opserr << "argc : " << argc;
// for (int i=0; i<argc; i++)
// {
// opserr <<"string " << i << " : " << argv[i] << endln;
// }
// create plane frame elements
if ((NDM == 2 && NDF == 3) || (NDM == 3 && NDF == 6)) {
int eleTag, iNode, jNode, numIntgrPts, transfTag;
int secTag[10]; // Max size of integration rule ... can change if needed
if (argc < 8) {
opserr << "WARNING bad command - want: element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
int argi = 2;
if (Tcl_GetInt(interp, argv[argi++], &eleTag) != TCL_OK) {
opserr << "WARNING invalid eleTag: element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[argi++], &iNode) != TCL_OK) {
opserr << "WARNING invalid iNode: element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[argi++], &jNode) != TCL_OK) {
opserr << "WARNING invalid jNode: element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
if (Tcl_GetInt(interp, argv[argi++], &numIntgrPts) != TCL_OK) {
opserr << "WARNING invalid numIntgrPts: element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
if (strcmp(argv[argi], "-sections") == 0) {
argi++;
if (argi+numIntgrPts > argc) {
opserr << "WARNING insufficient number of section tags - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
int section;
for (int i = 0; i < numIntgrPts; i++) {
if (Tcl_GetInt(interp, argv[argi+i], §ion) != TCL_OK) {
opserr << "WARNING invalid secTag - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
secTag[i] = section;
}
argi += numIntgrPts;
}
else {
int section;
if (Tcl_GetInt(interp, argv[argi++], §ion) != TCL_OK) {
opserr << "WARNING invalid secTag - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
for (int i = 0; i < numIntgrPts; i++)
secTag[i] = section;
}
if (argi >= argc || Tcl_GetInt(interp, argv[argi++], &transfTag) != TCL_OK) {
opserr << "WARNING invalid transfTag? - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
// some additional options at end of command .. setting defaults of 10 and 1.0e-10
double massDens = 0.0;
int nMaxLocIters = 10;
double locToler = 1e-08;
while (argi != argc) {
if (strcmp(argv[argi],"-mass") == 0) {
// allow user to specify mass (per unit length)
argi++;
if (argi == argc || Tcl_GetDouble(interp, argv[argi++], &massDens) != TCL_OK) {
opserr << "WARNING invalid massDens - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
}
else if (strcmp(argv[argi],"-iter") == 0) {
// allow user to specify maximum number of local iterations
argi++;
if (argi == argc || Tcl_GetInt(interp, argv[argi++], &nMaxLocIters) != TCL_OK) {
opserr << "WARNING invalid nMaxLocIters - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
// specify local tolerance
if (argi == argc || Tcl_GetDouble(interp, argv[argi++], &locToler) != TCL_OK) {
opserr << "WARNING invalid locToler - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
return TCL_ERROR;
}
}
else {
opserr << "WARNING bad command - element nonlinearBeamColumn eleTag? iNode? jNode? numIntgrPts? secTag? transfTag? <-mass massDens?> <-iter nMaxLocIters? locToler?>\n";
opserr << "invalid: " << argv[argi] << endln;
return TCL_ERROR;
}
}
// create the element
// get pointer to the sections for the whole beam
SectionForceDeformation **sections = new SectionForceDeformation* [numIntgrPts];
if (!sections) {
opserr << "WARNING TclElmtBuilder - addFrameElement - Insufficient memory to create sections\n";
return TCL_ERROR;
}
for (int j=0; j<numIntgrPts; j++) {
SectionForceDeformation *theSection = theTclModelBuilder->getSection(secTag[j]);
if (theSection == 0) {
opserr << "WARNING TclElmtBuilder - frameElement - no Section found with tag ";
opserr << secTag[j] << endln;
delete [] sections;
return TCL_ERROR;
}
sections[j] = theSection;
}
// opserr << "massDens " << massDens << endln;
// construct the element
Element *element = 0;
if (NDM == 2) {
CrdTransf2d *theCrdTransf = theTclModelBuilder->getCrdTransf2d(transfTag);
if (theCrdTransf == 0) {
opserr << "WARNING TclElmtBuilder - frameElement - no geometric transformation found with tag ";
opserr << transfTag << endln;
return TCL_ERROR;
}
element = new NLBeamColumn2d(eleTag, iNode, jNode, numIntgrPts, sections,
*theCrdTransf, massDens, nMaxLocIters, locToler, 10);
delete [] sections;
}
else {
CrdTransf3d *theCrdTransf = theTclModelBuilder->getCrdTransf3d(transfTag);
if (theCrdTransf == 0) {
opserr << "WARNING TclElmtBuilder - frameElement - no geometric transformation found with tag ";
opserr << transfTag << endln;
return TCL_ERROR;
}
element = new NLBeamColumn3d(eleTag, iNode, jNode, numIntgrPts, sections,
*theCrdTransf, massDens, nMaxLocIters, locToler);
delete [] sections;
}
if (element == 0) {
opserr << "WARNING TclElmtBuilder - addFrameElement - ran out of memory to create element\n";
return TCL_ERROR;
}
if (theTclModelBuilderDomain->addElement(element) == false) {
opserr << "WARNING TclElmtBuilder - addFrameElement - could not add element to domain ";
opserr << eleTag << endln;
return TCL_ERROR;
}
}
else {
opserr << "WARNING NDM = " << NDM << " and NDF = " << NDF << "is imcompatible with available frame elements\n";
return TCL_ERROR;
}
Tcl_Free ((char *)argv);
// if get here we have sucessfully created the element and added it to the domain
return TCL_OK;
}
TclInterpreter::TclInterpreter(int argc, char **argv)
:wrapper(), cmds(this)
{
/* fmk - beginning of modifications for OpenSees */
fprintf(stderr,"\n\n\t OpenSees -- Open System For Earthquake Engineering Simulation");
fprintf(stderr,"\n\tPacific Earthquake Engineering Research Center -- 3.0.0\n\n");
fprintf(stderr,"\t (c) Copyright 1999,2000 The Regents of the University of California");
fprintf(stderr,"\n\t\t\t\t All Rights Reserved\n");
fprintf(stderr," (Copyright and Disclaimer @ http://www.berkeley.edu/OpenSees/copyright.html)\n\n\n");
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
/*
* Make command-line arguments available in the Tcl variables "argc"
* and "argv". If the first argument doesn't start with a "-" then
* strip it off and use it as the name of a script file to process.
*/
if (tclStartupScriptFileName == NULL) {
if ((argc > 1) && (argv[1][0] != '-')) {
tclStartupScriptFileName = argv[1];
argc--;
argv++;
}
}
args = Tcl_Merge(argc-1, argv+1);
Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&argString);
ckfree(args);
if (tclStartupScriptFileName == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
} else {
tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,
tclStartupScriptFileName, -1, &argString);
}
TclFormatInt(buffer, argc-1);
Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
char one[2] = "1";
char zero[2] = "0";
Tcl_SetVar(interp, "tcl_interactive",
((tclStartupScriptFileName == NULL) && tty) ? one : zero,
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
#ifndef TCL_LOCAL_APPINIT
#define TCL_LOCAL_APPINIT Tcl_AppInit
#endif
if ((*Tcl_AppInit)(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteChars(errChannel,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
wrapper.addOpenSeesCommands(interp);
}
static PyObject *
Tkapp_Call(PyObject *self, PyObject *args)
{
/* This is copied from Merge() */
PyObject *tmp = NULL;
char *argvStore[ARGSZ];
char **argv = NULL;
int fvStore[ARGSZ];
int *fv = NULL;
int argc = 0, fvc = 0, i;
PyObject *res = NULL; /* except this has a different type */
Tcl_CmdInfo info; /* and this is added */
Tcl_Interp *interp = Tkapp_Interp(self); /* and this too */
if (!(tmp = PyList_New(0)))
return NULL;
argv = argvStore;
fv = fvStore;
if (args == NULL)
argc = 0;
else if (!PyTuple_Check(args)) {
argc = 1;
fv[0] = 0;
if (!(argv[0] = AsString(args, tmp)))
goto finally;
}
else {
argc = PyTuple_Size(args);
if (argc > ARGSZ) {
argv = (char **)ckalloc(argc * sizeof(char *));
fv = (int *)ckalloc(argc * sizeof(int));
if (argv == NULL || fv == NULL) {
PyErr_NoMemory();
goto finally;
}
}
for (i = 0; i < argc; i++) {
PyObject *v = PyTuple_GetItem(args, i);
if (PyTuple_Check(v)) {
fv[i] = 1;
if (!(argv[i] = Merge(v)))
goto finally;
fvc++;
}
else if (v == Py_None) {
argc = i;
break;
}
else {
fv[i] = 0;
if (!(argv[i] = AsString(v, tmp)))
goto finally;
fvc++;
}
}
}
/* End code copied from Merge() */
/* All this to avoid a call to Tcl_Merge() and the corresponding call
to Tcl_SplitList() inside Tcl_Eval()... It can save a bundle! */
if (Py_VerboseFlag >= 2) {
for (i = 0; i < argc; i++)
PySys_WriteStderr("%s ", argv[i]);
}
ENTER_TCL
info.proc = NULL;
if (argc < 1 ||
!Tcl_GetCommandInfo(interp, argv[0], &info) ||
info.proc == NULL)
{
char *cmd;
cmd = Tcl_Merge(argc, argv);
i = Tcl_Eval(interp, cmd);
ckfree(cmd);
}
else {
Tcl_ResetResult(interp);
i = (*info.proc)(info.clientData, interp, argc, argv);
}
ENTER_OVERLAP
if (info.proc == NULL && Py_VerboseFlag >= 2)
PySys_WriteStderr("... use TclEval ");
if (i == TCL_ERROR) {
if (Py_VerboseFlag >= 2)
PySys_WriteStderr("... error: '%s'\n",
Tcl_GetStringResult(interp));
Tkinter_Error(self);
}
else {
if (Py_VerboseFlag >= 2)
PySys_WriteStderr("-> '%s'\n", Tcl_GetStringResult(interp));
res = PyString_FromString(Tcl_GetStringResult(interp));
}
LEAVE_OVERLAP_TCL
/* Copied from Merge() again */
finally:
for (i = 0; i < fvc; i++)
if (fv[i]) {
ckfree(argv[i]);
}
if (argv != argvStore)
ckfree(FREECAST argv);
if (fv != fvStore)
ckfree(FREECAST fv);
Py_DECREF(tmp);
return res;
}
static char *
Merge(PyObject *args)
{
PyObject *tmp = NULL;
char *argvStore[ARGSZ];
char **argv = NULL;
int fvStore[ARGSZ];
int *fv = NULL;
int argc = 0, fvc = 0, i;
char *res = NULL;
if (!(tmp = PyList_New(0)))
return NULL;
argv = argvStore;
fv = fvStore;
if (args == NULL)
argc = 0;
else if (!PyTuple_Check(args)) {
argc = 1;
fv[0] = 0;
if (!(argv[0] = AsString(args, tmp)))
goto finally;
}
else {
argc = PyTuple_Size(args);
if (argc > ARGSZ) {
argv = (char **)ckalloc(argc * sizeof(char *));
fv = (int *)ckalloc(argc * sizeof(int));
if (argv == NULL || fv == NULL) {
PyErr_NoMemory();
goto finally;
}
}
for (i = 0; i < argc; i++) {
PyObject *v = PyTuple_GetItem(args, i);
if (PyTuple_Check(v)) {
fv[i] = 1;
if (!(argv[i] = Merge(v)))
goto finally;
fvc++;
}
else if (v == Py_None) {
argc = i;
break;
}
else {
fv[i] = 0;
if (!(argv[i] = AsString(v, tmp)))
goto finally;
fvc++;
}
}
}
res = Tcl_Merge(argc, argv);
if (res == NULL)
PyErr_SetString(Tkinter_TclError, "merge failed");
finally:
for (i = 0; i < fvc; i++)
if (fv[i]) {
ckfree(argv[i]);
}
if (argv != argvStore)
ckfree(FREECAST argv);
if (fv != fvStore)
ckfree(FREECAST fv);
Py_DECREF(tmp);
return res;
}
/*
*----------------------------------------------------------------------
*
* Tk_MainOpenSees --
*
* Main program for Wish and most other Tk-based applications.
*
* Results:
* None. This procedure never returns (it exits the process when
* it's done.
*
* Side effects:
* This procedure initializes the Tk world and then starts
* interpreting commands; almost anything could happen, depending
* on the script being interpreted.
*
*----------------------------------------------------------------------
*/
void
Tk_MainOpenSees(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp)
{
char *args, *fileName;
char buf[TCL_INTEGER_SPACE];
int code;
size_t length;
Tcl_Channel inChannel, outChannel;
Tcl_DString argString;
ThreadSpecificData *tsdPtr;
#ifdef __WIN32__
HANDLE handle;
#endif
/* fmk - beginning of modifications for OpenSees */
fprintf(stderr,"\n\n\t OpenSees -- Open System For Earthquake Engineering Simulation");
fprintf(stderr,"\n\tPacific Earthquake Engineering Research Center -- %s\n\n", OPS_VERSION);
fprintf(stderr,"\t (c) Copyright 1999 The Regents of the University of California");
fprintf(stderr,"\n\t\t\t\t All Rights Reserved \n\n\n");
fprintf(stderr,"\t(Copyright statement @ http://www.berkeley.edu/OpenSees/copyright.html)\n\n\n");
/* fmk - end of modifications for OpenSees */
/*
* Ensure that we are getting the matching version of Tcl. This is
* really only an issue when Tk is loaded dynamically.
*/
if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) {
abort();
}
tsdPtr = (ThreadSpecificData *)
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
Tcl_FindExecutable(argv[0]);
tsdPtr->interp = interp;
#if (defined(__WIN32__) || defined(MAC_TCL))
Tk_InitConsoleChannels(interp);
#endif
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
/*
* Parse command-line arguments. A leading "-file" argument is
* ignored (a historical relic from the distant past). If the
* next argument doesn't start with a "-" then strip it off and
* use it as the name of a script file to process.
*/
fileName = TclGetStartupScriptFileName();
if (argc > 1) {
length = strlen(argv[1]);
if ((length >= 2) && (strncmp(argv[1], "-file", length) == 0)) {
argc--;
argv++;
}
}
if (fileName == NULL) {
if ((argc > 1) && (argv[1][0] != '-')) {
fileName = argv[1];
argc--;
argv++;
}
}
OpenSeesParseArgv(argc, argv);
/*
* Make command-line arguments available in the Tcl variables "argc"
* and "argv".
*/
args = Tcl_Merge(argc-1, argv+1);
Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&argString);
ckfree(args);
sprintf(buf, "%d", argc-1);
if (fileName == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
} else {
fileName = Tcl_ExternalToUtfDString(NULL, fileName, -1, &argString);
}
Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
/*
* For now, under Windows, we assume we are not running as a console mode
* app, so we need to use the GUI console. In order to enable this, we
* always claim to be running on a tty. This probably isn't the right
* way to do it.
*/
#ifdef __WIN32__
handle = GetStdHandle(STD_INPUT_HANDLE);
if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)
|| (GetFileType(handle) == FILE_TYPE_UNKNOWN)) {
/*
* If it's a bad or closed handle, then it's been connected
* to a wish console window.
*/
tsdPtr->tty = 1;
} else if (GetFileType(handle) == FILE_TYPE_CHAR) {
/*
* A character file handle is a tty by definition.
*/
tsdPtr->tty = 1;
} else {
tsdPtr->tty = 0;
}
#else
tsdPtr->tty = isatty(0);
#endif
char one[2] = "1";
char zero[2] = "0";
Tcl_SetVar(interp, "tcl_interactive",
((fileName == NULL) && tsdPtr->tty) ? one : zero, TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
if ((*appInitProc)(interp) != TCL_OK) {
TkpDisplayWarning(Tcl_GetStringResult(interp), "Application Inititialization Failed");
}
/*
* Invoke the script specified on the command line, if any.
*/
if (fileName != NULL) {
Tcl_ResetResult(interp);
code = Tcl_EvalFile(interp, fileName);
if (code != TCL_OK) {
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
*/
Tcl_AddErrorInfo(interp, "");
TkpDisplayWarning(Tcl_GetVar(interp, "error Info",
TCL_GLOBAL_ONLY), "Error in startup script");
Tcl_DeleteInterp(interp);
Tcl_Exit(1);
}
tsdPtr->tty = 0;
} else {
/*
* Evaluate the .rc file, if one has been specified.
*/
Tcl_SourceRCFile(interp);
/*
* Establish a channel handler for stdin.
*/
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel) {
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
(ClientData) inChannel);
}
if (tsdPtr->tty) {
Prompt(interp, 0);
}
}
Tcl_DStringFree(&argString);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel) {
Tcl_Flush(outChannel);
}
Tcl_DStringInit(&tsdPtr->command);
Tcl_DStringInit(&tsdPtr->line);
Tcl_ResetResult(interp);
/*
* Loop infinitely, waiting for commands to execute. When there
* are no windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
}
/* Initialisation, based on tkMain.c */
value camltk_opentk(value argv) /* ML */
{
/* argv must contain argv[0], the application command name */
value tmp = Val_unit;
char *argv0;
Begin_root(tmp);
if ( argv == Val_int(0) ){
failwith("camltk_opentk: argv is empty");
}
argv0 = String_val( Field( argv, 0 ) );
if (!cltk_slave_mode) {
/* Create an interpreter, dies if error */
#if TCL_MAJOR_VERSION >= 8
Tcl_FindExecutable(String_val(argv0));
#endif
cltclinterp = Tcl_CreateInterp();
if (Tcl_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
{ /* Sets argv if needed */
int argc = 0;
tmp = Field(argv, 1); /* starts from argv[1] */
while ( tmp != Val_int(0) ) {
argc++;
tmp = Field(tmp, 1);
}
if( argc != 0 ){
int i;
char *args;
char **tkargv;
char argcstr[256];
tkargv = malloc( sizeof( char* ) * argc );
tmp = Field(argv, 1); /* starts from argv[1] */
i = 0;
while ( tmp != Val_int(0) ) {
tkargv[i] = String_val(Field(tmp, 0));
tmp = Field(tmp, 1);
i++;
}
sprintf( argcstr, "%d", argc );
Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
Tcl_Free(args);
free( tkargv );
}
}
if (Tk_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
/* Retrieve the main window */
cltk_mainWindow = Tk_MainWindow(cltclinterp);
if (NULL == cltk_mainWindow)
tk_error(cltclinterp->result);
Tk_GeometryRequest(cltk_mainWindow,200,200);
}
/* Create the camlcallback command */
Tcl_CreateCommand(cltclinterp,
CAMLCB, CamlCBCmd,
(ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
/* This is required by "unknown" and thus autoload */
Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* Our hack for implementing break in callbacks */
Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
/* Load the traditional rc file */
{
char *home = getenv("HOME");
if (home != NULL) {
char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
f[0]='\0';
strcat(f, home);
strcat(f, "/");
strcat(f, RCNAME);
if (0 == access(f,R_OK))
if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
stat_free(f);
tk_error(cltclinterp->result);
};
stat_free(f);
}
}
End_roots();
return Val_unit;
}
TclTextInterp::TclTextInterp(VMDApp *vmdapp, int guienabled, int mpienabled)
: app(vmdapp) {
interp = Tcl_CreateInterp();
#if 0
Tcl_InitMemory(interp); // enable Tcl memory debugging features
// when compiled with TCL_MEM_DEBUG
#endif
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
consoleisatty = vmd_isatty(0); // whether we're interactive or not
ignorestdin = 0;
gotPartial = 0;
needPrompt = 1;
callLevel = 0;
starttime = delay = 0;
#if defined(VMDMPI)
//
// MPI builds of VMD cannot try to read any command input from the
// console because it creates shutdown problems, at least with MPICH.
// File-based command input is fine however.
//
// don't check for interactive console input if running in parallel
if (mpienabled)
ignorestdin = 1;
#endif
#if defined(ANDROIDARMV7A)
//
// For the time being, the Android builds won't attempt to get any
// console input. Any input we're going to get is going to come via
// some means other than stdin, such as a network socket, text box, etc.
//
// Don't check for interactive console input if compiled for Android
ignorestdin = 1;
#endif
// set tcl_interactive, lets us run unix commands as from a shell
#if !defined(VMD_NANOHUB)
Tcl_SetVar(interp, "tcl_interactive", "1", 0);
#else
Tcl_SetVar(interp, "tcl_interactive", "0", 0);
Tcl_Channel channel;
#define CLIENT_READ (3)
#define CLIENT_WRITE (4)
channel = Tcl_MakeFileChannel((ClientData)CLIENT_READ, TCL_READABLE);
if (channel != NULL) {
const char *result;
Tcl_RegisterChannel(interp, channel);
result = Tcl_SetVar2(interp, "vmd_client", "read",
Tcl_GetChannelName(channel),
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
if (result == NULL) {
fprintf(stderr, "can't create variable for client read channel\n");
}
}
channel = Tcl_MakeFileChannel((ClientData)CLIENT_WRITE, TCL_WRITABLE);
if (channel != NULL) {
const char *result;
Tcl_RegisterChannel(interp, channel);
result = Tcl_SetVar2(interp, "vmd_client", "write",
Tcl_GetChannelName(channel),
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
if (result == NULL) {
fprintf(stderr, "can't create variable for client write channel\n");
}
}
write(CLIENT_WRITE, "vmd 1.0\n", 8);
#endif
// pass our instance of VMDApp to a hash table assoc. with the interpreter
Tcl_SetAssocData(interp, "VMDApp", NULL, app);
// Set up argc, argv0, and argv variables
{
char argcbuf[20];
sprintf(argcbuf, "%d", app->argc_m);
Tcl_SetVar(interp, "argc", argcbuf, TCL_GLOBAL_ONLY);
// it might be better to use the same thing that was passed to
// Tcl_FindExecutable, but this is now
Tcl_SetVar(interp, "argv0", app->argv_m[0], TCL_GLOBAL_ONLY);
char *args = Tcl_Merge(app->argc_m-1, app->argv_m+1);
Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
Tcl_Free(args);
}
#if defined(_MSC_VER) && TCL_MINOR_VERSION >= 4
// The Windows versions of Tcl 8.5.x have trouble finding
// the Tcl library subdirectory for unknown reasons.
// We force the appropriate env variables to be set in Tcl,
// despite Windows.
{
char vmdinitscript[4096];
char * tcl_library = getenv("TCL_LIBRARY");
char * tk_library = getenv("TK_LIBRARY");
if (tcl_library) {
sprintf(vmdinitscript, "set env(TCL_LIBRARY) {%s}", tcl_library);
if (Tcl_Eval(interp, vmdinitscript) != TCL_OK) {
msgErr << Tcl_GetStringResult(interp) << sendmsg;
}
}
if (tk_library) {
sprintf(vmdinitscript, "set env(TK_LIBRARY) {%s}", tk_library);
if (Tcl_Eval(interp, vmdinitscript) != TCL_OK) {
msgErr << Tcl_GetStringResult(interp) << sendmsg;
}
}
}
#endif
if (Tcl_Init(interp) == TCL_ERROR) { // new with 7.6
msgErr << "Tcl startup error: " << Tcl_GetStringResult(interp) << sendmsg;
}
#ifdef VMDTK
// and the Tk commands (but only if a GUI is available!)
if (guienabled) {
if (Tk_Init(interp) == TCL_ERROR) {
msgErr << "Tk startup error: " << Tcl_GetStringResult(interp) << sendmsg;
} else {
Tcl_StaticPackage(interp, "Tk",
(Tcl_PackageInitProc *) Tk_Init,
(Tcl_PackageInitProc *) NULL);
}
} // end of check that GUI is allowed
#endif
add_commands();
}
