Beispiel #1
0
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);
    }
}
Beispiel #2
0
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);
}
Beispiel #3
0
/*
** 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, &notUsed);
    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;
}
Beispiel #4
0
/*
 * 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;
}
Beispiel #5
0
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;
}
Beispiel #6
0
/* 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;
}
Beispiel #7
0
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;
}
Beispiel #8
0
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;
}
Beispiel #9
0
/*
 * 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;
}
Beispiel #10
0
	/* 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;
}
Beispiel #11
0
/*
 * 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;
}
Beispiel #12
0
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;
}
Beispiel #13
0
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;
}
Beispiel #14
0
/*
 * 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;
}
Beispiel #15
0
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);
  }
}
Beispiel #16
0
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;
}
Beispiel #17
0
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;
}
Beispiel #18
0
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;
}