static void
Prompt(
Tcl_Interp *interp, /* Interpreter to use for prompting. */
int partial) /* Non-zero means there already exists a
* partial command, so use the secondary
* prompt. */
{
Tcl_Obj *promptCmd;
int code;
Tcl_Channel outChannel, errChannel;
promptCmd = Tcl_GetVar2Ex(interp,
partial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY);
if (promptCmd == NULL) {
defaultPrompt:
if (!partial) {
/*
* We must check that outChannel is a real channel - it is
* possible that someone has transferred stdout out of this
* interpreter with "interp transfer".
*/
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_WriteChars(outChannel, "% ", 2);
}
}
} else {
code = Tcl_EvalObjEx(interp, promptCmd, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
/*
* We must check that errChannel is a real channel - it is
* possible that someone has transferred stderr out of this
* interpreter with "interp transfer".
*/
errChannel = Tcl_GetChannel(interp, "stderr", NULL);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
}
int
Pg_disconnect(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
PGconn *conn;
Tcl_Channel conn_chan;
if (argc != 2)
{
Tcl_AppendResult(interp, "Wrong # of arguments\n", "pg_disconnect connection", 0);
return TCL_ERROR;
}
conn_chan = Tcl_GetChannel(interp, argv[1], 0);
if (conn_chan == NULL)
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, argv[1], " is not a valid connection", 0);
return TCL_ERROR;
}
/* Check that it is a PG connection and not something else */
conn = PgGetConnectionId(interp, argv[1], (Pg_ConnectionId **) NULL);
if (conn == (PGconn *) NULL)
return TCL_ERROR;
return Tcl_UnregisterChannel(interp, conn_chan);
}
/*
** Attempt to extract a blob handle (type sqlite3_blob*) from the Tcl
** object passed as the second argument. If successful, set *ppBlob to
** point to the blob handle and return TCL_OK. Otherwise, store an error
** message in the tcl interpreter and return TCL_ERROR. The final value
** of *ppBlob is undefined in this case.
**
** If the object contains a string that begins with "incrblob_", then it
** is assumed to be the name of a Tcl channel opened using the [db incrblob]
** command (see tclsqlite.c). Otherwise, it is assumed to be a pointer
** encoded using the ptrToText() routine or similar.
*/
static int blobHandleFromObj(
Tcl_Interp *interp,
Tcl_Obj *pObj,
sqlite3_blob **ppBlob
){
char *z;
int n;
z = Tcl_GetStringFromObj(pObj, &n);
if( n==0 ){
*ppBlob = 0;
}else if( n>9 && 0==memcmp("incrblob_", z, 9) ){
int notUsed;
Tcl_Channel channel;
ClientData instanceData;
channel = Tcl_GetChannel(interp, z, ¬Used);
if( !channel ) return TCL_ERROR;
Tcl_Flush(channel);
Tcl_Seek(channel, 0, SEEK_SET);
instanceData = Tcl_GetChannelInstanceData(channel);
*ppBlob = *((sqlite3_blob **)instanceData);
}else{
*ppBlob = (sqlite3_blob*)sqlite3TestTextToPtr(z);
}
return TCL_OK;
}
/*
* Find a slot for a new result id. If the table is full, expand it by
* a factor of 2. However, do not expand past the hard max, as the client
* is probably just not clearing result handles like they should.
*/
int
PgSetResultId(Tcl_Interp *interp, CONST84 char *connid_c, PGresult *res)
{
Tcl_Channel conn_chan;
Pg_ConnectionId *connid;
int resid,
i;
char buf[32];
conn_chan = Tcl_GetChannel(interp, connid_c, 0);
if (conn_chan == NULL)
return TCL_ERROR;
connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
/* search, starting at slot after the last one used */
resid = connid->res_last;
for (;;)
{
/* advance, with wraparound */
if (++resid >= connid->res_max)
resid = 0;
/* this slot empty? */
if (!connid->results[resid])
{
connid->res_last = resid;
break; /* success exit */
}
/* checked all slots? */
if (resid == connid->res_last)
break; /* failure exit */
}
if (connid->results[resid])
{
/* no free slot found, so try to enlarge array */
if (connid->res_max >= connid->res_hardmax)
{
Tcl_SetResult(interp, "hard limit on result handles reached",
TCL_STATIC);
return TCL_ERROR;
}
connid->res_last = resid = connid->res_max;
connid->res_max *= 2;
if (connid->res_max > connid->res_hardmax)
connid->res_max = connid->res_hardmax;
connid->results = (PGresult **) ckrealloc((void *) connid->results,
sizeof(PGresult *) * connid->res_max);
for (i = connid->res_last; i < connid->res_max; i++)
connid->results[i] = NULL;
}
connid->results[resid] = res;
sprintf(buf, "%s.%d", connid_c, resid);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
return resid;
}
static int
TestfilewaitCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
CONST char **argv) /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
ClientData data;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" file readable|writable|both timeout\"", NULL);
return TCL_ERROR;
}
channel = Tcl_GetChannel(interp, argv[1], NULL);
if (channel == NULL) {
return TCL_ERROR;
}
if (strcmp(argv[2], "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(argv[2], "writable") == 0){
mask = TCL_WRITABLE;
} else if (strcmp(argv[2], "both") == 0){
mask = TCL_WRITABLE|TCL_READABLE;
} else {
Tcl_AppendResult(interp, "bad argument \"", argv[2],
"\": must be readable, writable, or both", NULL);
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
(ClientData*) &data) != TCL_OK) {
Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
return TCL_ERROR;
}
fd = PTR2INT(data);
if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
result = TclUnixWaitForFile(fd, mask, timeout);
if (result & TCL_READABLE) {
Tcl_AppendElement(interp, "readable");
}
if (result & TCL_WRITABLE) {
Tcl_AppendElement(interp, "writable");
}
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_PidObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
int i;
Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
} else {
/*
* Get the channel and make sure that it refers to a pipe.
*/
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
if (Tcl_GetChannelType(chan) != &pipeChannelType) {
return TCL_OK;
}
/*
* Extract the process IDs from the pipe structure.
*/
pipePtr = Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
int Gmlayer_Init(Tcl_Interp* interp)
{
static int initialized = 0;
Tcl_Obj *version;
int r;
#if 0
out = Tcl_GetChannel(interp, "stdout", NULL);
if (out == NULL) {
Tcl_AppendResult(interp, "could not find stdout", NULL);
return TCL_ERROR;
}
#endif
fit_interp = interp;
debug_message("gmlayer init\n");
if (initialized) {
Tcl_AppendResult(interp, "Only one copy of gmlayer is allowed", NULL);
return TCL_ERROR;
}
#ifdef USE_TCL_STUBS
Tcl_InitStubs(interp, "8.0", 0);
#endif
version = Tcl_SetVar2Ex(interp, "gmlayer_version", NULL,
Tcl_NewDoubleObj(0.1), TCL_LEAVE_ERR_MSG);
if (version == NULL)
return TCL_ERROR;
r = Tcl_PkgProvide(interp, "gmlayer", Tcl_GetString(version));
/* Global variable initialization */
strcpy(parfile, "mlayer.staj");
Constrain = noconstraints;
Tcl_CreateCommand(interp, "gmlayer",
gmlayer_TclCmd,
(ClientData)NULL,
gmlayer_TclEnd);
return r;
}
gdIOCtx *
tclgd_channelNameToIOCtx (Tcl_Interp *interp, char *channelName, int modeFlag)
{
gdIOCtx *outctx;
Tcl_Channel channel;
int mode;
channel = Tcl_GetChannel (interp, channelName, &mode);
if (channel == NULL) {
return NULL;
}
if (!(mode & modeFlag)) {
Tcl_AppendResult (interp, "channel '", channelName, "' not open for ", ((modeFlag & TCL_WRITABLE) ? "writing" : "reading"), NULL);
return NULL;
}
outctx = tclgd_newChannelCtx (channel);
return outctx;
}
/*
* Get back the connection from the Id
*/
PGconn *
PgGetConnectionId(Tcl_Interp *interp, CONST84 char *id,
Pg_ConnectionId ** connid_p)
{
Tcl_Channel conn_chan;
Pg_ConnectionId *connid;
conn_chan = Tcl_GetChannel(interp, id, 0);
if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, id, " is not a valid postgresql connection", 0);
if (connid_p)
*connid_p = NULL;
return (PGconn *) NULL;
}
connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
if (connid_p)
*connid_p = connid;
return connid->conn;
}
/* ARGSUSED */
int
Tcl_PidObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
} else {
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeState *pipePtr;
int i;
Tcl_Obj *resultPtr, *longObjPtr;
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
* Get the connection Id from the result Id
*/
int
PgGetConnByResultId(Tcl_Interp *interp, CONST84 char *resid_c)
{
char *mark;
Tcl_Channel conn_chan;
if (!(mark = strchr(resid_c, '.')))
goto error_out;
*mark = '\0';
conn_chan = Tcl_GetChannel(interp, resid_c, 0);
*mark = '.';
if (conn_chan && Tcl_GetChannelType(conn_chan) == &Pg_ConnType)
{
Tcl_SetResult(interp, (char *) Tcl_GetChannelName(conn_chan),
TCL_VOLATILE);
return TCL_OK;
}
error_out:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, resid_c, " is not a valid connection\n", 0);
return TCL_ERROR;
}
static int
getresid(Tcl_Interp *interp, CONST84 char *id, Pg_ConnectionId ** connid_p)
{
Tcl_Channel conn_chan;
char *mark;
int resid;
Pg_ConnectionId *connid;
if (!(mark = strchr(id, '.')))
return -1;
*mark = '\0';
conn_chan = Tcl_GetChannel(interp, id, 0);
*mark = '.';
if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
{
Tcl_SetResult(interp, "Invalid connection handle", TCL_STATIC);
return -1;
}
if (Tcl_GetInt(interp, mark + 1, &resid) == TCL_ERROR)
{
Tcl_SetResult(interp, "Poorly formated result handle", TCL_STATIC);
return -1;
}
connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
if (resid < 0 || resid >= connid->res_max || connid->results[resid] == NULL)
{
Tcl_SetResult(interp, "Invalid result handle", TCL_STATIC);
return -1;
}
*connid_p = connid;
return resid;
}
int
Tcl_GetOpenFile(
Tcl_Interp *interp, /* Interpreter in which to find file. */
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
int checkUsage, /* 1 means verify that the file was opened in
* a mode that allows the access specified by
* "forWriting". Ignored, we always check that
* the channel is open for the requested
* mode. */
ClientData *filePtr) /* Store pointer to FILE structure here. */
{
Tcl_Channel chan;
int chanMode, fd;
const Tcl_ChannelType *chanTypePtr;
ClientData data;
FILE *f;
chan = Tcl_GetChannel(interp, chanID, &chanMode);
if (chan == NULL) {
return TCL_ERROR;
}
if (forWriting && !(chanMode & TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" wasn't opened for writing", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE",
NULL);
return TCL_ERROR;
} else if (!forWriting && !(chanMode & TCL_READABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" wasn't opened for reading", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE",
NULL);
return TCL_ERROR;
}
/*
* We allow creating a FILE * out of file based, pipe based and socket
* based channels. We currently do not allow any other channel types,
* because it is likely that stdio will not know what to do with them.
*/
chanTypePtr = Tcl_GetChannelType(chan);
if ((chanTypePtr == &fileChannelType)
#ifdef SUPPORTS_TTY
|| (chanTypePtr == &ttyChannelType)
#endif /* SUPPORTS_TTY */
|| (strcmp(chanTypePtr->typeName, "tcp") == 0)
|| (strcmp(chanTypePtr->typeName, "pipe") == 0)) {
if (Tcl_GetChannelHandle(chan,
(forWriting ? TCL_WRITABLE : TCL_READABLE), &data) == TCL_OK) {
fd = PTR2INT(data);
/*
* The call to fdopen below is probably dangerous, since it will
* truncate an existing file if the file is being opened for
* writing....
*/
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot get a FILE * for \"%s\"", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL",
"FILE_FAILURE", NULL);
return TCL_ERROR;
}
*filePtr = f;
return TCL_OK;
}
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" cannot be used to get a FILE *", chanID));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR",
NULL);
return TCL_ERROR;
}
/*
* Create and register a new channel for the connection
*/
int
PgSetConnectionId(Tcl_Interp *interp, PGconn *conn, char *chandle)
{
Tcl_Channel conn_chan;
Tcl_Obj *nsstr;
Pg_ConnectionId *connid;
int i;
CONST char *ns = "";
connid = (Pg_ConnectionId *) ckalloc(sizeof(Pg_ConnectionId));
connid->conn = conn;
connid->res_count = 0;
connid->res_last = -1;
connid->res_max = RES_START;
connid->res_hardmax = RES_HARD_MAX;
connid->res_copy = -1;
connid->res_copyStatus = RES_COPY_NONE;
connid->results = (PGresult **)ckalloc(sizeof(PGresult *) * RES_START);
connid->resultids = (Pg_resultid **)ckalloc(sizeof(Pg_resultid *) * RES_START);
for (i = 0; i < RES_START; i++)
{
connid->results[i] = NULL;
connid->resultids[i] = NULL;
}
connid->notify_list = NULL;
connid->notifier_running = 0;
connid->interp = interp;
connid->nullValueString = NULL;
nsstr = Tcl_NewStringObj("if {[namespace current] != \"::\"} {set k [namespace current]::}", -1);
Tcl_EvalObjEx(interp, nsstr, 0);
/*
Tcl_Eval(interp, "if {[namespace current] != \"::\"} {\
set k [namespace current]::\
}");
*/
ns = Tcl_GetStringResult(interp);
Tcl_ResetResult(interp);
if (chandle == NULL)
{
sprintf(connid->id, "%spgsql%d", ns, PQsocket(conn));
}
else
{
sprintf(connid->id, "%s%s", ns, chandle);
}
conn_chan = Tcl_GetChannel(interp, connid->id, 0);
if (conn_chan != NULL)
{
return 0;
}
connid->notifier_channel = Tcl_MakeTcpClientChannel((ClientData)(long)PQsocket(conn));
/* Code executing outside of any Tcl interpreter can call
Tcl_RegisterChannel with interp as NULL, to indicate that
it wishes to hold a reference to this channel. Subse-
quently, the channel can be registered in a Tcl inter-
preter and it will only be closed when the matching number
of calls to Tcl_UnregisterChannel have been made. This
allows code executing outside of any interpreter to safely
hold a reference to a channel that is also registered in a
Tcl interpreter.
*/
Tcl_RegisterChannel(NULL, connid->notifier_channel);
conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, (ClientData) connid,
TCL_READABLE | TCL_WRITABLE);
Tcl_SetChannelOption(interp, conn_chan, "-buffering", "line");
Tcl_SetResult(interp, connid->id, TCL_VOLATILE);
Tcl_RegisterChannel(interp, conn_chan);
connid->cmd_token=Tcl_CreateObjCommand(interp, connid->id, PgConnCmd, (ClientData) connid, PgDelCmdHandle);
return 1;
}
static void
Prompt(Tcl_Interp *interp, int partial)
{
#ifdef _TCL84
const char *promptCmd;
const char one[12] = "tcl_prompt1";
const char two[12] = "tcl_prompt2";
#elif _TCL85
const char *promptCmd;
const char one[12] = "tcl_prompt1";
const char two[12] = "tcl_prompt2";
#else
char *promptCmd;
char one[12] = "tcl_prompt1";
char two[12] = "tcl_prompt2";
#endif
int code;
Tcl_Channel outChannel, errChannel;
promptCmd = Tcl_GetVar(interp, partial ? two : one, TCL_GLOBAL_ONLY);
if (promptCmd == NULL) {
defaultPrompt:
if (!partial) {
/*
* We must check that outChannel is a real channel - it
* is possible that someone has transferred stdout out of
* this interpreter with "interp transfer".
*/
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_WriteChars(outChannel, "OpenSees > ", 11);
}
}
} else {
code = Tcl_Eval(interp, promptCmd);
if (code != TCL_OK) {
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
/*
* We must check that errChannel is a real channel - it
* is possible that someone has transferred stderr out of
* this interpreter with "interp transfer".
*/
errChannel = Tcl_GetChannel(interp, "stderr", NULL);
if (errChannel != (Tcl_Channel) NULL) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
goto defaultPrompt;
}
}
outChannel = Tcl_GetChannel(interp, "stdout", NULL);
if (outChannel != (Tcl_Channel) NULL) {
Tcl_Flush(outChannel);
}
}
int tclcommand_readmd(ClientData dummy, Tcl_Interp *interp,
int argc, char **argv)
{
char *row;
int pos_row[3] = { -1 }, v_row[3] = { -1 },
#ifdef DIPOLES
dip_row[3] = { -1 },
#endif
f_row[3] = { -1 };
int av_pos = 0, av_v = 0,
#ifdef DIPOLES
av_dip=0,
#endif
#ifdef MASS
av_mass=0,
#endif
#ifdef SHANCHEN
av_solvation=0,
#endif
av_f = 0,
#ifdef ELECTROSTATICS
av_q = 0,
#endif
av_type = 0;
int node, i;
struct MDHeader header;
Particle data;
int tcl_file_mode;
Tcl_Channel channel;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " <file>\"",
(char *) NULL);
return (TCL_ERROR);
}
if ((channel = Tcl_GetChannel(interp, argv[1], &tcl_file_mode)) == NULL)
return (TCL_ERROR);
/* tune channel to binary translation, e.g. none */
Tcl_SetChannelOption(interp, channel, "-translation", "binary");
Tcl_Read(channel, (char *)&header, sizeof(header));
/* check token */
if (strncmp(header.magic, MDMAGIC, 4) || header.n_rows < 0) {
Tcl_AppendResult(interp, "data file \"", argv[1],
"\" does not contain tcl MD data",
(char *) NULL);
return (TCL_ERROR);
}
if (!particle_node)
build_particle_node();
/* parse rows */
row = (char*)malloc(header.n_rows*sizeof(char));
for (i = 0; i < header.n_rows; i++) {
Tcl_Read(channel, (char *)&row[i], sizeof(char));
switch (row[i]) {
case POSX: pos_row[0] = i; break;
case POSY: pos_row[1] = i; break;
case POSZ: pos_row[2] = i; break;
case VX: v_row[0] = i; break;
case VY: v_row[1] = i; break;
case VZ: v_row[2] = i; break;
#ifdef DIPOLES
case MX: dip_row[0] = i; break;
case MY: dip_row[1] = i; break;
case MZ: dip_row[2] = i; break;
#endif
case FX: f_row[0] = i; break;
case FY: f_row[1] = i; break;
case FZ: f_row[2] = i; break;
#ifdef MASS
case MASSES: av_mass = 1; break;
#endif
#ifdef SHANCHEN
case SOLVATION: av_solvation = 1; break;
#endif
#ifdef ELECTROSTATICS
case Q: av_q = 1; break;
#endif
case TYPE: av_type = 1; break;
}
}
/* *_row[0] tells if * data is completely available -
* otherwise we ignore it */
if (pos_row[0] != -1 && pos_row[1] != -1 && pos_row[2] != -1) {
av_pos = 1;
}
if (v_row[0] != -1 && v_row[1] != -1 && v_row[2] != -1) {
av_v = 1;
}
if (f_row[0] != -1 && f_row[1] != -1 && f_row[2] != -1) {
av_f = 1;
}
#ifdef DIPOLES
if (dip_row[0] != -1 && dip_row[1] != -1 && dip_row[2] != -1) {
av_dip = 1;
}
#endif
while (!Tcl_Eof(channel)) {
Tcl_Read(channel, (char *)&data.p.identity, sizeof(int));
if (data.p.identity == -1)
break;
/* printf("id=%d\n", data.identity); */
if (data.p.identity < 0) {
Tcl_AppendResult(interp, "illegal data format in data file \"", argv[1],
"\", perhaps wrong file?",
(char *) NULL);
free(row);
return (TCL_ERROR);
}
for (i = 0; i < header.n_rows; i++) {
switch (row[i]) {
case POSX: Tcl_Read(channel, (char *)&data.r.p[0], sizeof(double)); break;
case POSY: Tcl_Read(channel, (char *)&data.r.p[1], sizeof(double)); break;
case POSZ: Tcl_Read(channel, (char *)&data.r.p[2], sizeof(double)); break;
case VX: Tcl_Read(channel, (char *)&data.m.v[0], sizeof(double)); break;
case VY: Tcl_Read(channel, (char *)&data.m.v[1], sizeof(double)); break;
case VZ: Tcl_Read(channel, (char *)&data.m.v[2], sizeof(double)); break;
case FX: Tcl_Read(channel, (char *)&data.f.f[0], sizeof(double)); break;
case FY: Tcl_Read(channel, (char *)&data.f.f[1], sizeof(double)); break;
case FZ: Tcl_Read(channel, (char *)&data.f.f[2], sizeof(double)); break;
case MASSES:
#ifdef MASS
Tcl_Read(channel, (char *)&data.p.mass, sizeof(double)); break;
#else
{
double dummy_mass;
Tcl_Read(channel, (char *)&dummy_mass, sizeof(double)); break;
}
#endif
#ifdef ELECTROSTATICS
case Q: Tcl_Read(channel, (char *)&data.p.q, sizeof(double)); break;
#endif
#ifdef DIPOLES
case MX: Tcl_Read(channel, (char *)&data.r.dip[0], sizeof(double)); break;
case MY: Tcl_Read(channel, (char *)&data.r.dip[1], sizeof(double)); break;
case MZ: Tcl_Read(channel, (char *)&data.r.dip[2], sizeof(double)); break;
#endif
case TYPE: Tcl_Read(channel, (char *)&data.p.type, sizeof(int)); break;
}
}
node = (data.p.identity <= max_seen_particle) ? particle_node[data.p.identity] : -1;
if (node == -1) {
if (!av_pos) {
Tcl_AppendResult(interp, "new particle without position data",
(char *) NULL);
free(row);
return (TCL_ERROR);
}
}
if (av_pos)
place_particle(data.p.identity, data.r.p);
#ifdef MASS
if (av_mass)
set_particle_mass(data.p.identity, data.p.mass);
#endif
#ifdef SHANCHEN
if (av_solvation)
set_particle_solvation(data.p.identity, data.p.solvation);
#endif
#ifdef ELECTROSTATICS
if (av_q)
set_particle_q(data.p.identity, data.p.q);
#endif
#ifdef DIPOLES
if (av_dip)
set_particle_dip(data.p.identity, data.r.dip);
#endif
if (av_v)
set_particle_v(data.p.identity, data.m.v);
if (av_f)
set_particle_f(data.p.identity, data.f.f);
if (av_type)
set_particle_type(data.p.identity, data.p.type);
}
free(row);
return TCL_OK;
}
static int
FileForRedirect(
Tcl_Interp *interp, /* Intepreter to use for error reporting. */
char *spec, /* Points to character just after redirection
* character. */
char *arg, /* Pointer to entire argument containing spec:
* used for error reporting. */
int atOK, /* Non-zero means that '@' notation can be
* used to specify a channel, zero means that
* it isn't. */
char *nextArg, /* Next argument in argc/argv array, if needed
* for file name or channel name. May be
* NULL. */
int flags, /* Flags to use for opening file or to specify
* mode for channel. */
int *skipPtr, /* (out) Filled with 1 if redirection target
* was in spec, 2 if it was in nextArg. */
int *closePtr) /* (out) Filled with one if the caller should
* close the file when done with it, zero
* otherwise. */
{
int writing = (flags & O_WRONLY);
int fd;
*skipPtr = 1;
if ((atOK != 0) && (*spec == '@')) {
int direction;
Tcl_Channel chan;
spec++;
if (*spec == '\0') {
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
chan = Tcl_GetChannel(interp, spec, NULL);
if (chan == NULL) {
return -1;
}
direction = (writing) ? TCL_WRITABLE : TCL_READABLE;
fd = GetFdFromChannel(chan, direction);
if (fd < 0) {
Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
"\" wasn't opened for ",
((writing) ? "writing" : "reading"), (char *)NULL);
return -1;
}
if (writing) {
/*
* Be sure to flush output to the file, so that anything
* written by the child appears after stuff we've already
* written.
*/
Tcl_Flush(chan);
}
} else {
char *name;
Tcl_DString nameString;
if (*spec == '\0') {
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
name = Tcl_TranslateFileName(interp, spec, &nameString);
if (name != NULL) {
fd = OpenFile(name, flags);
} else {
fd = -1;
}
Tcl_DStringFree(&nameString);
if (fd < 0) {
Tcl_AppendResult(interp, "can't ",
((writing) ? "write" : "read"), " file \"", spec, "\": ",
Tcl_PosixError(interp), (char *)NULL);
return -1;
}
*closePtr = TRUE;
}
return fd;
badLastArg:
Tcl_AppendResult(interp, "can't specify \"", arg,
"\" as last word in command", (char *)NULL);
return -1;
}
int tclcommand_writemd(ClientData data, Tcl_Interp *interp,
int argc, char **argv)
{
static int end_num = -1;
char *row;
int p, i;
struct MDHeader header;
int tcl_file_mode;
Tcl_Channel channel;
if (argc < 3) {
#if defined(ELECTROSTATICS) && defined(DIPOLES)
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " <file> ?posx|posy|posz|q|mx|my|mz|vx|vy|vz|fx|fy|fz|type?* ...\"",
(char *) NULL);
#else
#ifdef ELECTROSTATICS
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " <file> ?posx|posy|posz|q|vx|vy|vz|fx|fy|fz|type?* ...\"",
(char *) NULL);
#endif
#ifdef DIPOLES
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " <file> ?posx|posy|posz|mx|my|mz|vx|vy|vz|fx|fy|fz|type?* ...\"",
(char *) NULL);
#endif
#endif
return (TCL_ERROR);
}
if ((channel = Tcl_GetChannel(interp, argv[1], &tcl_file_mode)) == NULL)
return (TCL_ERROR);
if (!(tcl_file_mode & TCL_WRITABLE)) {
Tcl_AppendResult(interp, "\"", argv[1], "\" not writeable", (char *) NULL);
return (TCL_ERROR);
}
/* tune channel to binary translation, e.g. none */
Tcl_SetChannelOption(interp, channel, "-translation", "binary");
/* assemble rows */
argc -= 2;
argv += 2;
row = (char*)malloc(sizeof(char)*argc);
for (i = 0; i < argc; i++) {
if (!strncmp(*argv, "posx", strlen(*argv))) {
row[i] = POSX;
}
else if (!strncmp(*argv, "posy", strlen(*argv))) {
row[i] = POSY;
}
else if (!strncmp(*argv, "posz", strlen(*argv))) {
row[i] = POSZ;
}
#ifdef MASS
else if (!strncmp(*argv, "mass", strlen(*argv))) {
row[i] = MASSES;
}
#endif
else if (!strncmp(*argv, "q", strlen(*argv))) {
row[i] = Q;
}
#ifdef DIPOLES
else if (!strncmp(*argv, "mx", strlen(*argv))) {
row[i] = MX;
}
else if (!strncmp(*argv, "my", strlen(*argv))) {
row[i] = MY;
}
else if (!strncmp(*argv, "mz", strlen(*argv))) {
row[i] = MZ;
}
#endif
else if (!strncmp(*argv, "vx", strlen(*argv))) {
row[i] = VX;
}
else if (!strncmp(*argv, "vy", strlen(*argv))) {
row[i] = VY;
}
else if (!strncmp(*argv, "vz", strlen(*argv))) {
row[i] = VZ;
}
else if (!strncmp(*argv, "fx", strlen(*argv))) {
row[i] = FX;
}
else if (!strncmp(*argv, "fy", strlen(*argv))) {
row[i] = FY;
}
else if (!strncmp(*argv, "fz", strlen(*argv))) {
row[i] = FZ;
}
else if (!strncmp(*argv, "type", strlen(*argv))) {
row[i] = TYPE;
}
else {
Tcl_AppendResult(interp, "no particle data field \"", *argv, "\"?",
(char *) NULL);
free(row);
return (TCL_ERROR);
}
argv++;
}
if (!particle_node)
build_particle_node();
/* write header and row data */
memmove(header.magic, MDMAGIC, 4*sizeof(char));
header.n_rows = argc;
Tcl_Write(channel, (char *)&header, sizeof(header));
Tcl_Write(channel, row, header.n_rows*sizeof(char));
for (p = 0; p <= max_seen_particle; p++) {
Particle data;
if (get_particle_data(p, &data) == ES_OK) {
unfold_position(data.r.p, data.m.v, data.l.i);
/* write particle index */
Tcl_Write(channel, (char *)&p, sizeof(int));
for (i = 0; i < header.n_rows; i++) {
switch (row[i]) {
case POSX: Tcl_Write(channel, (char *)&data.r.p[0], sizeof(double)); break;
case POSY: Tcl_Write(channel, (char *)&data.r.p[1], sizeof(double)); break;
case POSZ: Tcl_Write(channel, (char *)&data.r.p[2], sizeof(double)); break;
case VX: Tcl_Write(channel, (char *)&data.m.v[0], sizeof(double)); break;
case VY: Tcl_Write(channel, (char *)&data.m.v[1], sizeof(double)); break;
case VZ: Tcl_Write(channel, (char *)&data.m.v[2], sizeof(double)); break;
case FX: Tcl_Write(channel, (char *)&data.f.f[0], sizeof(double)); break;
case FY: Tcl_Write(channel, (char *)&data.f.f[1], sizeof(double)); break;
case FZ: Tcl_Write(channel, (char *)&data.f.f[2], sizeof(double)); break;
#ifdef MASS
case MASSES: Tcl_Write(channel, (char *)&data.p.mass, sizeof(double)); break;
#endif
#ifdef ELECTROSTATICS
case Q: Tcl_Write(channel, (char *)&data.p.q, sizeof(double)); break;
#endif
#ifdef DIPOLES
case MX: Tcl_Write(channel, (char *)&data.r.dip[0], sizeof(double)); break;
case MY: Tcl_Write(channel, (char *)&data.r.dip[1], sizeof(double)); break;
case MZ: Tcl_Write(channel, (char *)&data.r.dip[2], sizeof(double)); break;
#endif
case TYPE: Tcl_Write(channel, (char *)&data.p.type, sizeof(int)); break;
}
}
free_particle(&data);
}
}
/* end marker */
Tcl_Write(channel, (char *)&end_num, sizeof(int));
free(row);
return TCL_OK;
}