/** Reads a Tcl vector and returns a C vector.
\param interp The Tcl interpreter
\param data_in String containing a Tcl vector of doubles
\param nrep Pointer to the C vector
\param len Pointer to an int to store the length of the vector
\return \em TCL_OK if everything went fine \em TCL_ERROR otherwise and
interp->result is set to an error message.
If \em TCL_OK is returned you have to make sure to free the memory
pointed to by nrep.
*/
int uwerr_read_tcl_double_vector(Tcl_Interp *interp, char * data_in ,
double ** nrep, int * len)
{
char ** col;
int i;
*len = -1;
if (Tcl_SplitList(interp, data_in, len, &col) == TCL_ERROR)
return TCL_ERROR;
if (*len < 1) {
Tcl_AppendResult(interp, "Argument is not a vector.",
(char *)NULL);
return TCL_ERROR;
}
if (!(*nrep = (double*)malloc((*len)*sizeof(double)))) {
Tcl_AppendResult(interp, "Out of Memory.",
(char *)NULL);
Tcl_Free((char *)col);
return TCL_ERROR;
}
for (i = 0; i < *len; ++i) {
if (Tcl_GetDouble(interp, col[i], &((*nrep)[i])) == TCL_ERROR) {
Tcl_Free((char *)col);
free(*nrep);
return TCL_ERROR;
}
}
Tcl_Free((char *)col);
return TCL_OK;
}
// move all atoms by a given vector
int ScriptTcl::Tcl_moveallby(ClientData clientData,
Tcl_Interp *interp, int argc, char *argv[]) {
ScriptTcl *script = (ScriptTcl *)clientData;
script->initcheck();
if (argc != 2) {
Tcl_SetResult(interp, "wrong # args", TCL_VOLATILE);
return TCL_ERROR;
}
char **fstring;
int fnum;
double x, y, z;
if (Tcl_SplitList(interp, argv[1], &fnum, &fstring) != TCL_OK)
return TCL_ERROR;
if ( (fnum != 3) ||
(Tcl_GetDouble(interp, fstring[0],&x) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[1],&y) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[2],&z) != TCL_OK) ) {
Tcl_SetResult(interp,"argument not a vector",TCL_VOLATILE);
Tcl_Free((char*)fstring);
return TCL_ERROR;
}
Tcl_Free((char*)fstring);
MoveAllByMsg *msg = new MoveAllByMsg;
msg->offset = Vector(x,y,z);
(CProxy_PatchMgr(CkpvAccess(BOCclass_group).patchMgr)).moveAllBy(msg);
script->barrier();
return TCL_OK;
}
/* Exposed as private function to librt, but not (currently) beyond librt -
* see librt_private.h */
int
tcl_list_to_avs(const char *tcl_list, struct bu_attribute_value_set *avs, int offset)
{
int i = 0;
int list_c = 0;
const char **listv = (const char **)NULL;
if (Tcl_SplitList(NULL, tcl_list, &list_c, (const char ***)&listv) != TCL_OK) {
return -1;
}
if (!BU_AVS_IS_INITIALIZED(avs)) BU_AVS_INIT(avs);
if (!list_c) {
Tcl_Free((char *)listv);
return 0;
}
if (list_c > 2) {
for (i = offset; i < list_c; i += 2) {
(void)bu_avs_add(avs, listv[i], listv[i+1]);
}
} else {
return -1;
}
Tcl_Free((char *)listv);
return 0;
}
/*
* Syslog_Delete - Tcl_CmdDeleteProc for syslog command.
* Frees all hash tables and closes log if it was opened.
*/
static void Syslog_Delete(ClientData data)
{ SyslogInfo *info=(SyslogInfo *)data;
Tcl_DeleteHashTable(info->facilities);
Tcl_Free((char *)info->facilities);
Tcl_DeleteHashTable(info->priorities);
Tcl_Free((char *)info->priorities);
if (info->logOpened) {
closelog();
}
Tcl_Free((char *)info);
}
int ARecDelInst(ClientData data)
{
ARecField *inst = (ARecField *) data;
Tcl_DecrRefCount(inst->nameobj);
ARecFreePointers(inst, inst->recs);
Tcl_Free((void *) inst->recs);
Tcl_Free((void *) inst);
return TCL_OK;
}
static void
QueryConfigDelete(
ClientData clientData)
{
QCCD *cdPtr = clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
Tcl_Free(cdPtr->encoding);
}
Tcl_Free(cdPtr);
}
/****
* implementation of list2shape (creates RFshape from a list { {a p} {a p} ... }
****/
int tclList2Shape(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
char **list1, **list2;
int nlist1, nlist2, i, slot;
if (argc != 2)
return TclError(interp,"Usage: <RFshape> list2shape { {a1 p1} {a2 p2} ... }");
if (Tcl_SplitList(interp,argv[1],&nlist1,&list1) != TCL_OK)
return TclError(interp,"list2shape: unable to decompose list argument");
/* get a new slot and allocate */
slot = RFshapes_slot();
if (slot == -1) {
Tcl_Free((char *)list1);
return TclError(interp,"list2shape error: no more free slots available, free some shape first!");
}
RFshapes[slot] = RFshapes_alloc(nlist1);
for (i=0; i<nlist1; i++) {
if (Tcl_SplitList(interp,list1[i],&nlist2,&list2) != TCL_OK) {
Tcl_Free((char *)list1);
return TclError(interp,"list2shape can not read list element %d",i+1);
}
if (nlist2 != 2) {
Tcl_Free((char *)list1);
Tcl_Free((char *)list2);
return TclError(interp,"list2shape: expecting two elements like {amplitude phase} in list");
}
if (Tcl_GetDouble(interp,list2[0],&RFshapes[slot][i+1].ampl) != TCL_OK) {
Tcl_Free((char *)list1);
Tcl_Free((char *)list2);
return TclError(interp,"lis2shape cannot interpret amplitude in element %d",i+1);
}
if (Tcl_GetDouble(interp,list2[1],&RFshapes[slot][i+1].phase) != TCL_OK) {
Tcl_Free((char *)list1);
Tcl_Free((char *)list2);
return TclError(interp,"lis2shape cannot interpret phase in element %d",i+1);
}
Tcl_Free((char *)list2);
}
Tcl_Free((char *)list1);
sprintf(interp->result,"%d",slot);
return TCL_OK;
}
/*
* 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);
}
/*
* Sets an active tag array from the 'list' string.
* An empty 'list' sets the array to contain nothing, but a NULL list sets
* the array to the default - all.
*/
int SetActiveTags2 (char *list, int *num, char ***types) {
if (*types)
Tcl_Free((char *)*types);
if (list) {
if (SplitList(list, num, types) == -1) {
*types = NULL;
*num = 0;
return -1;
}
} else {
int i;
if (NULL == (*types = (char **)Tcl_Alloc(tag_db_count * sizeof(char *)))){
*num = 0;
return -1;
}
for (i = 0; i < tag_db_count; i++) {
(*types)[i] = tag_db[i].id;
}
*num = tag_db_count;
}
return 0;
}
void
Tfp_ArrayDestroy( Tfp_ArrayType *arr )
{
Tcl_HashEntry *p;
Tcl_HashSearch s;
if (arr->cleanProc != (Tfp_ArrayDeleteProc *) NULL) {
for (p = Tcl_FirstHashEntry( arr->table, &s ); p != (Tcl_HashEntry *) NULL;
p = Tcl_NextHashEntry( &s )) {
(*arr->cleanProc) ( Tcl_GetHashValue( p ) );
}
}
Tcl_DeleteHashTable( arr->table );
Tcl_Free( (char *) arr->table );
Tcl_Free( (char *) arr );
}
/* 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");
}
}
static int
rcClose (ClientData cd_, Tcl_Interp* interp)
{
ReflectingChannel* chan = (ReflectingChannel*) cd_;
int n = -1;
Tcl_SavedResult sr;
Tcl_Obj* cmd = rcBuildCmdList(chan, Tcl_NewStringObj("close", -1));
Tcl_Interp* ip = chan->_interp;
Tcl_SaveResult(ip, &sr);
if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK)
Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n);
Tcl_RestoreResult(ip, &sr);
Tcl_DecrRefCount(cmd);
if (chan->_timer != NULL) {
Tcl_DeleteTimerHandler(chan->_timer);
chan->_timer = NULL;
}
Tcl_DecrRefCount(chan->_context);
Tcl_DecrRefCount(chan->_seek);
Tcl_DecrRefCount(chan->_read);
Tcl_DecrRefCount(chan->_write);
Tcl_DecrRefCount(chan->_name);
Tcl_Free((char*) chan);
return TCL_OK;
}
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;
}
/* Parsing results */
CAMLprim value camltk_splitlist (value v)
{
int argc;
char **argv;
int result;
char *utf;
CheckInit();
utf = caml_string_to_tcl(v);
/* argv is allocated by Tcl, to be freed by us */
result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
switch(result) {
case TCL_OK:
{ value res = copy_string_list(argc,argv);
Tcl_Free((char *)argv); /* only one large block was allocated */
/* argv points into utf: utf must be freed after argv are freed */
stat_free( utf );
return res;
}
case TCL_ERROR:
default:
stat_free( utf );
tk_error(Tcl_GetStringResult(cltclinterp));
}
}
int ScriptTcl::Tcl_move(ClientData clientData,
Tcl_Interp *interp, int argc, char *argv[]) {
ScriptTcl *script = (ScriptTcl *)clientData;
script->initcheck();
if (argc != 4) {
Tcl_SetResult(interp,"wrong # args",TCL_VOLATILE);
return TCL_ERROR;
}
char **fstring; int fnum; int atomid; int moveto; double x, y, z;
if (Tcl_GetInt(interp,argv[1],&atomid) != TCL_OK) return TCL_ERROR;
if (argv[2][0]=='t' && argv[2][1]=='o' && argv[2][2]==0) moveto = 1;
else if (argv[2][0]=='b' && argv[2][1]=='y' && argv[2][2]==0) moveto = 0;
else {
Tcl_SetResult(interp,"syntax is 'move <id> to|by {<x> <y> <z>}'",TCL_VOLATILE);
return TCL_ERROR;
}
if (Tcl_SplitList(interp, argv[3], &fnum, &fstring) != TCL_OK) {
return TCL_ERROR;
}
if ( (fnum != 3) ||
(Tcl_GetDouble(interp, fstring[0],&x) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[1],&y) != TCL_OK) ||
(Tcl_GetDouble(interp, fstring[2],&z) != TCL_OK) ) {
Tcl_SetResult(interp,"third argument not a vector",TCL_VOLATILE);
Tcl_Free((char*)fstring);
return TCL_ERROR;
}
Tcl_Free((char*)fstring);
SimParameters *simParams = Node::Object()->simParameters;
iout << "TCL: Moving atom " << atomid << " ";
if ( moveto ) iout << "to"; else iout << "by";
iout << " " << Vector(x,y,z) << ".\n" << endi;
MoveAtomMsg *msg = new MoveAtomMsg;
msg->atomid = atomid - 1;
msg->moveto = moveto;
msg->coord = Vector(x,y,z);
(CProxy_PatchMgr(CkpvAccess(BOCclass_group).patchMgr)).moveAtom(msg);
script->barrier();
return TCL_OK;
}
/*
** release the memory successfully allocated for an audio tap
*/
static void _delete_impl(_t *data) {
if (data->buffs != NULL) {
for (int i = 0; i < data->buff_n; i += 1) {
if (data->buffs[i].buff != NULL)
Tcl_DecrRefCount(data->buffs[i].buff);
}
Tcl_Free((char *)data->buffs);
}
}
/*
** Called when the command is deleted.
*/
static void DbDeleteCmd(void *db){
SqliteDb *pDb = (SqliteDb*)db;
sqlite_close(pDb->db);
while( pDb->pFunc ){
SqlFunc *pFunc = pDb->pFunc;
pDb->pFunc = pFunc->pNext;
Tcl_Free((char*)pFunc);
}
if( pDb->zBusy ){
Tcl_Free(pDb->zBusy);
}
if( pDb->zTrace ){
Tcl_Free(pDb->zTrace);
}
if( pDb->zAuth ){
Tcl_Free(pDb->zAuth);
}
Tcl_Free((char*)pDb);
}
int ARecDelType(ClientData data)
{
int i;
ARecType *type = (ARecType *) data;
type = ARecLookupType(type->nameobj);
Tcl_DecrRefCount(type->nameobj);
for ( i = 0; i < type->nfield; i++ ) { Tcl_DecrRefCount(type->field[i].nameobj); }
Tcl_Free((void *) type->shadow);
Tcl_Free((void *) type->field);
ARecInstDeleteRecs(ARecTypeInst, (char *) type, 1);
return TCL_OK;
}
static void
DeleteHistoryObjs(
ClientData clientData,
Tcl_Interp *interp)
{
register HistoryObjs *histObjsPtr = clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
Tcl_Free(histObjsPtr);
}
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
void *handle = loadHandle->clientData;
dlclose(handle);
Tcl_Free(loadHandle);
}
static void
PkguaDeleteTokens(
Tcl_Interp *interp)
{
Tcl_HashEntry *entryPtr =
Tcl_FindHashEntry(&interpTokenMap, (char *) interp);
if (entryPtr) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
Tcl_DeleteHashEntry(entryPtr);
}
}
static void
PkguaFreeTokensHashTable(void)
{
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
for (entryPtr = Tcl_FirstHashEntry(&interpTokenMap, &search);
entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
Tcl_Free((char *) Tcl_GetHashValue(entryPtr));
}
interpTokenMapInitialised = 0;
}
/*
* 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);
}
/*
* Syslog_ListHash - appends to interp result all the values of given
* hash table
*/
static void Syslog_ListHash(Tcl_Interp *interp,Tcl_HashTable *table)
{
Tcl_HashSearch *searchPtr=(Tcl_HashSearch *)
Tcl_Alloc(sizeof(Tcl_HashSearch));
Tcl_HashEntry *entry;
char separator[3]={' ',' ',0};
entry=Tcl_FirstHashEntry(table,searchPtr);
while (entry) {
Tcl_AppendResult(interp,separator,Tcl_GetHashKey(table,entry),NULL);
separator[0]=',';
entry=Tcl_NextHashEntry(searchPtr);
}
Tcl_Free((char *)searchPtr);
}
static int ThreadEventProc(Tcl_Event *event, int mask)
{
int code;
ThreadEvent *data = (ThreadEvent *)event; /* event is really a ThreadEvent */
Tcl_Preserve(data->interpreter);
code = Tcl_EvalEx(data->interpreter, data->script, -1, TCL_EVAL_GLOBAL);
Tcl_Free(data->script);
if (code != TCL_OK) {
ThreadErrorProc(data->interpreter);
}
Tcl_Release(data->interpreter);
return 1;
}
/* Parse an n-tuple of doubles specified as a tcl-list.
* Used for grabbing point or vector coordinates, colors, and other things.
* Puts results into an array of doubles.
*/
int get_tcl_tuple ( Tcl_Interp *ip, const char *inList, double *p, int n )
{
CONST84 char **indices;
double tmp;
int num_doubles;
int rtn;
char s[100];
int i;
rtn = Tcl_SplitList(ip, inList, &num_doubles, &indices);
if ((TCL_OK != rtn) || (n != num_doubles)) {
sprintf(s,"%d",n);
Tcl_AppendResult(ip,
"Expected a tuple of ", s, " doubles.\n",
(char *) 0
);
Tcl_Free((char *)indices);
return TCL_ERROR;
}
for (i = 0; i < n; i++) {
if (TCL_OK != Tcl_GetDouble(ip, indices[i], &tmp)) {
Tcl_Free((char *)indices);
sprintf(s,"%d",n);
Tcl_AppendResult(ip,
"Expected a tuple of ", s, " doubles.\n",
(char *) 0
);
return TCL_ERROR;
}
p[i] = tmp;
}
Tcl_Free((char *)indices);
return TCL_OK;
}
pure_expr *tk_split(const char *s)
{
int argc, ret;
const char **argv;
ret = Tcl_SplitList(NULL, s, &argc, &argv);
if (ret == TCL_OK) {
pure_expr *x;
if (argc <= 0)
x = pure_listl(0);
else {
pure_expr **xv = (pure_expr**)malloc(argc*sizeof(pure_expr*));
int i;
for (i = 0; i < argc; i++)
xv[i] = pure_string_dup(argv[i]);
x = pure_listv(argc, xv);
free(xv);
}
Tcl_Free((char *)argv);
return x;
} else {
if (argv) Tcl_Free((char *)argv);
return NULL;
}
}
/*
* 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);
}
/* 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);
}
}
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;
}
