int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result. */
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
int flags) /* Reserved for future use. */
{
int fileNums[2];
if (pipe(fileNums) < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
fcntl(fileNums[0], F_SETFD, FD_CLOEXEC);
fcntl(fileNums[1], F_SETFD, FD_CLOEXEC);
*rchan = Tcl_MakeFileChannel(INT2PTR(fileNums[0]), TCL_READABLE);
Tcl_RegisterChannel(interp, *rchan);
*wchan = Tcl_MakeFileChannel(INT2PTR(fileNums[1]), TCL_WRITABLE);
Tcl_RegisterChannel(interp, *wchan);
return TCL_OK;
}
int tclcommand_replacestdchannel(ClientData clientData, Tcl_Interp *interp, int argc, char **argv)
{
Tcl_Channel channel=NULL;
if (argc != 3){
Tcl_AppendResult(interp,"Wrong # of args! Usage: ",argv[0]," [stdout|stderr|stdin] <pipename>",(char *)NULL);
return TCL_ERROR;
}
if(access(argv[2],F_OK)<0){
Tcl_AppendResult(interp,"File ",argv[2]," does not exist!",(char *) NULL);
return TCL_ERROR;
}
if(strcmp(argv[1],"stdout")==0){
if(access(argv[2],W_OK)<0){
Tcl_AppendResult(interp,"You do not have permission to access ",argv[2],(char *) NULL);
return TCL_ERROR;
}
Tcl_UnregisterChannel(interp,Tcl_GetStdChannel(TCL_STDOUT));
channel = Tcl_OpenFileChannel(interp, argv[2], "WRONLY",0666);
Tcl_RegisterChannel(interp,channel);
Tcl_SetStdChannel(channel,TCL_STDOUT);
}
else if(strcmp(argv[1],"stderr")==0){
if(access(argv[2],W_OK)<0){
Tcl_AppendResult(interp,"You do not have permission to access ",argv[2],(char *) NULL);
return TCL_ERROR;
}
Tcl_UnregisterChannel(interp,Tcl_GetStdChannel(TCL_STDERR));
channel = Tcl_OpenFileChannel(interp, argv[2], "WRONLY",0666);
Tcl_RegisterChannel(interp,channel);
Tcl_SetStdChannel(channel,TCL_STDERR);
}
else if(strcmp(argv[1],"stdin")==0){
if(access(argv[2],R_OK)<0){
Tcl_AppendResult(interp,"You do not have permission to access ",argv[2],(char *) NULL);
return TCL_ERROR;
}
Tcl_UnregisterChannel(interp,Tcl_GetStdChannel(TCL_STDIN));
channel = Tcl_OpenFileChannel(interp, argv[2], "RDONLY",0666);
Tcl_RegisterChannel(interp,channel);
Tcl_SetStdChannel(channel,TCL_STDIN);
}
else{
Tcl_AppendResult(interp,"invalid first argument (got: ",argv[1]," )",(char *) NULL);
return TCL_ERROR;
}
if(channel == NULL)
return TCL_ERROR;
return TCL_OK;
}
static int
cmd_rechan(ClientData cd_, Tcl_Interp* ip_, int objc_, Tcl_Obj*const* objv_)
{
ReflectingChannel *rc;
int mode;
char buffer [20];
if (objc_ != 3) {
Tcl_WrongNumArgs(ip_, 1, objv_, "command mode");
return TCL_ERROR;
}
if (Tcl_ListObjLength(ip_, objv_[1], &mode) == TCL_ERROR ||
Tcl_GetIntFromObj(ip_, objv_[2], &mode) == TCL_ERROR)
return TCL_ERROR;
Tcl_MutexLock(&rechanMutex);
sprintf(buffer, "rechan%d", ++mkChanSeq);
Tcl_MutexUnlock(&rechanMutex);
rc = rcCreate (ip_, objv_[1], mode, buffer);
rc->_chan = Tcl_CreateChannel(&reChannelType, buffer, (ClientData) rc, mode);
Tcl_RegisterChannel(ip_, rc->_chan);
Tcl_SetChannelOption(ip_, rc->_chan, "-buffering", "none");
Tcl_SetChannelOption(ip_, rc->_chan, "-blocking", "0");
Tcl_SetResult(ip_, buffer, TCL_VOLATILE);
return TCL_OK;
}
/*
* Create and register a new channel for the connection
*/
void
PgSetConnectionId(Tcl_Interp *interp, PGconn *conn)
{
Tcl_Channel conn_chan;
Pg_ConnectionId *connid;
int i;
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);
for (i = 0; i < RES_START; i++)
connid->results[i] = NULL;
connid->notify_list = NULL;
connid->notifier_running = 0;
sprintf(connid->id, "pgsql%d", PQsocket(conn));
#if TCL_MAJOR_VERSION >= 8
connid->notifier_channel = Tcl_MakeTcpClientChannel((ClientData) PQsocket(conn));
Tcl_RegisterChannel(NULL, connid->notifier_channel);
#else
connid->notifier_socket = -1;
#endif
#if TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION == 5
/* Original signature (only seen in Tcl 7.5) */
conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, NULL, NULL, (ClientData) connid);
#else
/* Tcl 7.6 and later use this */
conn_chan = Tcl_CreateChannel(&Pg_ConnType, connid->id, (ClientData) connid,
TCL_READABLE | TCL_WRITABLE);
#endif
Tcl_SetChannelOption(interp, conn_chan, "-buffering", "line");
Tcl_SetResult(interp, connid->id, TCL_VOLATILE);
Tcl_RegisterChannel(interp, conn_chan);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreatePipe --
*
* System dependent interface to create a pipe for the [chan pipe]
* command. Stolen from TclX.
*
* Parameters:
* o interp - Errors returned in result.
* o rchan, wchan - Returned read and write side.
* o flags - Reserved for future use.
* Results:
* TCL_OK or TCL_ERROR.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp,
Tcl_Channel *rchan,
Tcl_Channel *wchan,
int flags)
{
int fileNums[2];
if (pipe(fileNums) < 0) {
Tcl_AppendResult(interp, "pipe creation failed: ",
Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
*rchan = Tcl_MakeFileChannel((ClientData) INT2PTR(fileNums[0]),
TCL_READABLE);
Tcl_RegisterChannel(interp, *rchan);
*wchan = Tcl_MakeFileChannel((ClientData) INT2PTR(fileNums[1]),
TCL_WRITABLE);
Tcl_RegisterChannel(interp, *wchan);
return TCL_OK;
}
void
TnmCreateSocketHandler(int sock, int mask, TnmSocketProc *proc, ClientData clientData)
{
SocketHandler *shPtr;
shPtr = (SocketHandler *) ckalloc(sizeof(SocketHandler));
shPtr->sd = sock;
shPtr->channel = Tcl_MakeTcpClientChannel((ClientData) sock);
shPtr->proc = proc;
shPtr->clientData = clientData;
Tcl_RegisterChannel((Tcl_Interp *) NULL, shPtr->channel);
Tcl_CreateChannelHandler(shPtr->channel, mask, proc, clientData);
shPtr->nextPtr = socketHandlerList;
socketHandlerList = shPtr;
}
/*-----------------------------------------------------------------------------
* BindFileHandles --
*
* Bind the file handles for a socket to one or two Tcl file channels.
* Binding to two handles is for compatibility with older interfaces.
* If an error occurs, both file descriptors will be closed and cleaned up.
*
* Parameters:
* o interp (O) - File handles or error messages are return in result.
* o options (I) - Options set controling buffering and handle allocation:
* o SERVER_BUF - Two file handle buffering.
* o SERVER_NOBUF - No buffering.
* o socketFD (I) - File number of the socket that was opened.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
BindFileHandles (Tcl_Interp *interp, unsigned options, int socketFD)
{
Tcl_Channel channel;
channel = Tcl_MakeTcpClientChannel ((ClientData) socketFD);
Tcl_RegisterChannel (interp, channel);
if (options & SERVER_NOBUF) {
if (TclX_SetChannelOption (interp, channel, TCLX_COPT_BUFFERING,
TCLX_BUFFERING_NONE) == TCL_ERROR)
goto errorExit;
}
Tcl_AppendElement (interp, Tcl_GetChannelName (channel));
return TCL_OK;
errorExit:
CloseForError (interp, channel, socketFD);
return TCL_ERROR;
}
int sequencer_make_channel(ClientData clientData, Tcl_Interp *interp, snd_sequencer_t *sequencer, int direction) {
if (snd_sequencer_poll_descriptors_count(sequencer) != 1) {
Tcl_AppendResult(interp, "sequencer device needs more than one file descriptor", NULL);
snd_sequencer_close(sequencer);
return TCL_ERROR;
}
sequencer_instance_t *sqi = (sequencer_instance_t *)ckalloc(sizeof(sequencer_instance_t));
char channel_name[256];
snprintf(channel_name, sizeof(channel_name), "sequencer@%s", snd_sequencer_name(sequencer));
sqi->direction = direction;
sqi->sequencer = sequencer;
struct pollfd pollfd;
snd_sequencer_poll_descriptors(sqi->sequencer, &pollfd, 1);
sqi->fd = pollfd.fd;
sqi->chan = Tcl_CreateChannel(&sequencer_channel_type, channel_name, sqi, direction);
if (sqi->chan == NULL) {
ckfree((char *)sqi);
snd_sequencer_close(sequencer);
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, sqi->chan);
Tcl_AppendResult(interp, channel_name, NULL);
return TCL_OK;
}
int
Tcl_SocketObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *socketOptions[] = {
"-async", "-myaddr", "-myport","-server", NULL
};
enum socketOptions {
SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
};
int optionIndex, a, server = 0, port, myport = 0, async = 0;
char *host, *script = NULL, *myaddr = NULL;
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
const char *arg = Tcl_GetString(objv[a]);
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets", NULL);
return TCL_ERROR;
}
async = 1;
break;
case SKT_MYADDR:
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myaddr option", NULL);
return TCL_ERROR;
}
myaddr = TclGetString(objv[a]);
break;
case SKT_MYPORT: {
char *myPortName;
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myport option", NULL);
return TCL_ERROR;
}
myPortName = TclGetString(objv[a]);
if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {
return TCL_ERROR;
}
break;
}
case SKT_SERVER:
if (async == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets", NULL);
return TCL_ERROR;
}
server = 1;
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -server option", NULL);
return TCL_ERROR;
}
script = TclGetString(objv[a]);
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
}
if (server) {
host = myaddr; /* NULL implies INADDR_ANY */
if (myport != 0) {
Tcl_AppendResult(interp, "option -myport is not valid for servers",
NULL);
return TCL_ERROR;
}
} else if (a < objc) {
host = TclGetString(objv[a]);
a++;
} else {
Interp *iPtr;
wrongNumArgs:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv,
"?-myaddr addr? ?-myport myport? ?-async? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
"-server command ?-myaddr addr? port");
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
return TCL_ERROR;
}
if (a == objc-1) {
if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
&port) != TCL_OK) {
return TCL_ERROR;
}
} else {
goto wrongNumArgs;
}
if (server) {
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)
ckalloc((unsigned) sizeof(AcceptCallback));
unsigned len = strlen(script) + 1;
char *copyScript = ckalloc(len);
memcpy(copyScript, script, len);
acceptCallbackPtr->script = copyScript;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
acceptCallbackPtr);
if (chan == NULL) {
ckfree(copyScript);
ckfree((char *) acceptCallbackPtr);
return TCL_ERROR;
}
/*
* Register with the interpreter to let us know when the interpreter
* is deleted (by having the callback set the interp field of the
* acceptCallbackPtr's structure to NULL). This is to avoid trying to
* eval the script in a deleted interpreter.
*/
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
/*
* Register a close callback. This callback will inform the
* interpreter (if it still exists) that this channel does not need to
* be informed when the interpreter is deleted.
*/
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
}
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
return TCL_OK;
}
static void
AcceptCallbackProc(
ClientData callbackData, /* The data stored when the callback was
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
* connection. */
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
* away, this is signalled by setting the interp field of the callback
* data to NULL.
*/
if (acceptCallbackPtr->interp != NULL) {
char portBuf[TCL_INTEGER_SPACE];
char *script = acceptCallbackPtr->script;
Tcl_Interp *interp = acceptCallbackPtr->interp;
int result;
Tcl_Preserve(script);
Tcl_Preserve(interp);
TclFormatInt(portBuf, port);
Tcl_RegisterChannel(interp, chan);
/*
* Artificially bump the refcount to protect the channel from being
* deleted while the script is being evaluated.
*/
Tcl_RegisterChannel(NULL, chan);
result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
" ", address, " ", portBuf, NULL);
if (result != TCL_OK) {
TclBackgroundException(interp, result);
Tcl_UnregisterChannel(interp, chan);
}
/*
* Decrement the artificially bumped refcount. After this it is not
* safe anymore to use "chan", because it may now be deleted.
*/
Tcl_UnregisterChannel(NULL, chan);
Tcl_Release(interp);
Tcl_Release(script);
} else {
/*
* The interpreter has been deleted, so there is no useful way to
* utilize the client socket - just close it.
*/
Tcl_Close(NULL, chan);
}
}
/* ARGSUSED */
int
Tcl_OpenObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int pipeline, prot;
const char *modeString, *what;
Tcl_Channel chan;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
return TCL_ERROR;
}
prot = 0666;
if (objc == 2) {
modeString = "r";
} else {
modeString = TclGetString(objv[2]);
if (objc == 4) {
char *permString = TclGetString(objv[3]);
int code = TCL_ERROR;
int scanned = TclParseAllWhiteSpace(permString, -1);
/* Support legacy octal numbers */
if ((permString[scanned] == '0')
&& (permString[scanned+1] >= '0')
&& (permString[scanned+1] <= '7')) {
Tcl_Obj *permObj;
TclNewLiteralStringObj(permObj, "0o");
Tcl_AppendToObj(permObj, permString+scanned+1, -1);
code = TclGetIntFromObj(NULL, permObj, &prot);
Tcl_DecrRefCount(permObj);
}
if ((code == TCL_ERROR)
&& TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
return TCL_ERROR;
}
}
}
pipeline = 0;
what = TclGetString(objv[1]);
if (what[0] == '|') {
pipeline = 1;
}
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
int mode, seekFlag, cmdObjc, binary;
const char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
}
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
if (mode == -1) {
chan = NULL;
} else {
int flags = TCL_STDERR | TCL_ENFORCE_MODE;
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
flags |= TCL_STDOUT;
break;
case O_WRONLY:
flags |= TCL_STDIN;
break;
case O_RDWR:
flags |= (TCL_STDIN | TCL_STDOUT);
break;
default:
Tcl_Panic("Tcl_OpenCmd: invalid mode value");
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if (binary && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
ckfree((char *) cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
return TCL_OK;
}
int
Tcl_AppInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
Tcl_Channel tempChan;
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#ifdef TCL_TEST
if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
(Tcl_PackageInitProc *) NULL);
if (TclObjTest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
#endif /* TCL_TEST */
/*
* Call the init procedures for included packages. Each call should
* look like this:
*
* if (Mod_Init(interp) == TCL_ERROR) {
* return TCL_ERROR;
* }
*
* where "Mod" is the name of the module.
*/
/*
* Call Tcl_CreateCommand for application-specific commands, if
* they weren't already created by the init procedures called above.
* Each call would loo like this:
*
* Tcl_CreateCommand(interp, "tclName", CFuncCmd, NULL, NULL);
*/
/*
* Specify a user-specific startup script to invoke if the application
* is run interactively. On the Mac we can specifiy either a TEXT resource
* which contains the script or the more UNIX like file location
* may also used. (I highly recommend using the resource method.)
*/
Tcl_SetVar(interp, "tcl_rcRsrcName", "tclshrc", TCL_GLOBAL_ONLY);
/* Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY); */
/*
* We have to support at least the quit Apple Event.
*/
TkMacInitAppleEvents(interp);
/*
* Open a file channel to put stderr, stdin, stdout...
*/
tempChan = Tcl_OpenFileChannel(interp, ":temp.in", "a+", 0);
Tcl_SetStdChannel(tempChan,TCL_STDIN);
Tcl_RegisterChannel(interp, tempChan);
Tcl_SetChannelOption(NULL, tempChan, "-translation", "cr");
Tcl_SetChannelOption(NULL, tempChan, "-buffering", "line");
tempChan = Tcl_OpenFileChannel(interp, ":temp.out", "a+", 0);
Tcl_SetStdChannel(tempChan,TCL_STDOUT);
Tcl_RegisterChannel(interp, tempChan);
Tcl_SetChannelOption(NULL, tempChan, "-translation", "cr");
Tcl_SetChannelOption(NULL, tempChan, "-buffering", "line");
tempChan = Tcl_OpenFileChannel(interp, ":temp.err", "a+", 0);
Tcl_SetStdChannel(tempChan,TCL_STDERR);
Tcl_RegisterChannel(interp, tempChan);
Tcl_SetChannelOption(NULL, tempChan, "-translation", "cr");
Tcl_SetChannelOption(NULL, tempChan, "-buffering", "none");
return TCL_OK;
}
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();
}
int
TclFileTemporaryCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
* file in. */
Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
Tcl_Channel chan; /* The channel opened (RDWR) on the temporary
* file, or NULL if there's an error. */
Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL;
/* Pieces of template. Each piece is NULL if
* it is omitted. The platform temporary file
* engine might ignore some pieces. */
if (objc < 1 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?");
return TCL_ERROR;
}
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
int length;
Tcl_Obj *templateObj = objv[2];
const char *string = TclGetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
if (length == 0) {
goto makeTemporary;
}
/*
* The template only gives a directory if there is a directory
* separator in it.
*/
if (strchr(string, '/') != NULL
|| (tclPlatform == TCL_PLATFORM_WINDOWS
&& strchr(string, '\\') != NULL)) {
tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
/*
* Only allow creation of temporary files in the native filesystem
* since they are frequently used for integration with external
* tools or system libraries. [Bug 2388866]
*/
if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj)
!= &tclNativeFilesystem) {
TclDecrRefCount(tempDirObj);
tempDirObj = NULL;
}
}
/*
* The template only gives the filename if the last character isn't a
* directory separator.
*/
if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS
|| string[length-1] != '\\')) {
Tcl_Obj *tailObj = TclPathPart(interp, templateObj,
TCL_PATH_TAIL);
if (tailObj != NULL) {
tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT);
tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION);
TclDecrRefCount(tailObj);
}
}
}
/*
* Convert empty parts of the template into unspecified parts.
*/
if (tempDirObj && !TclGetString(tempDirObj)[0]) {
TclDecrRefCount(tempDirObj);
tempDirObj = NULL;
}
if (tempBaseObj && !TclGetString(tempBaseObj)[0]) {
TclDecrRefCount(tempBaseObj);
tempBaseObj = NULL;
}
if (tempExtObj && !TclGetString(tempExtObj)[0]) {
TclDecrRefCount(tempExtObj);
tempExtObj = NULL;
}
/*
* Create and open the temporary file.
*/
makeTemporary:
chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj);
/*
* If we created pieces of template, get rid of them now.
*/
if (tempDirObj) {
TclDecrRefCount(tempDirObj);
}
if (tempBaseObj) {
TclDecrRefCount(tempBaseObj);
}
if (tempExtObj) {
TclDecrRefCount(tempExtObj);
}
/*
* Deal with results.
*/
if (chan == NULL) {
if (nameVarObj) {
TclDecrRefCount(nameObj);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create temporary file: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
if (nameVarObj != NULL) {
if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_UnregisterChannel(interp, chan);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
}
/*-----------------------------------------------------------------------------
* TclX_ServerCreateCmd --
* Implements the TCL server_create command:
*
* server_create ?options?
*
* Creates a socket, binds the address and port on the local machine
* (optionally specified by the caller), and starts the port listening
* for connections by calling listen (2).
*
* Options may be "-myip ip_address", "-myport port_number",
* "-myport reserved", and "-backlog backlog".
*
* Results:
* If successful, a Tcl fileid is returned.
*
*-----------------------------------------------------------------------------
*/
static int
TclX_ServerCreateCmd (ClientData clientData,
Tcl_Interp *interp,
int argc,
const char **argv)
{
int socketFD = -1, nextArg;
struct sockaddr_in local;
int myPort, value;
int backlog = 5;
int getReserved = FALSE;
Tcl_Channel channel = NULL;
/*
* Parse arguments.
*/
bzero ((VOID *) &local, sizeof (local));
local.sin_family = AF_INET;
local.sin_addr.s_addr = INADDR_ANY;
nextArg = 1;
while ((nextArg < argc) && (argv [nextArg][0] == '-')) {
if (STREQU ("-myip", argv [nextArg])) {
if (nextArg >= argc - 1)
goto missingArg;
nextArg++;
if (TclXOSInetAtoN (interp, argv [nextArg],
&local.sin_addr) == TCL_ERROR)
return TCL_ERROR;
} else if (STREQU ("-myport", argv [nextArg])) {
if (nextArg >= argc - 1)
goto missingArg;
nextArg++;
if (STREQU (argv [nextArg], "reserved")) {
getReserved = TRUE;
} else {
if (Tcl_GetInt (interp, argv [nextArg], &myPort) != TCL_OK)
return TCL_ERROR;
local.sin_port = htons (myPort);
}
} else if (STREQU ("-backlog", argv [nextArg])) {
if (nextArg >= argc - 1)
goto missingArg;
nextArg++;
if (Tcl_GetInt (interp, argv [nextArg], &backlog) != TCL_OK)
return TCL_ERROR;
} else if (STREQU ("-reuseaddr", argv [nextArg])) {
/* Ignore for compatibility */
} else {
TclX_AppendObjResult (interp, "expected ",
"\"-myip\", \"-myport\", or \"-backlog\", ",
"got \"", argv [nextArg], "\"",
(char *) NULL);
return TCL_ERROR;
}
nextArg++;
}
if (nextArg != argc) {
TclX_AppendObjResult (interp, tclXWrongArgs, argv[0],
" ?options?", (char *) NULL);
return TCL_ERROR;
}
/*
* Allocate a reserved port if requested.
*/
if (getReserved) {
int port;
if (rresvport (&port) < 0)
goto unixError;
local.sin_port = port;
}
/*
* Open a socket and bind an address and port to it.
*/
socketFD = socket (local.sin_family, SOCK_STREAM, 0);
if (socketFD < 0)
goto unixError;
value = 1;
if (setsockopt (socketFD, SOL_SOCKET, SO_REUSEADDR,
(void*) &value, sizeof (value)) < 0) {
goto unixError;
}
if (bind (socketFD, (struct sockaddr *) &local, sizeof (local)) < 0) {
goto unixError;
}
if (listen (socketFD, backlog) < 0)
goto unixError;
channel = Tcl_MakeTcpClientChannel ((ClientData) socketFD);
Tcl_RegisterChannel (interp, channel);
TclX_AppendObjResult (interp, Tcl_GetChannelName (channel), (char *) NULL);
return TCL_OK;
/*
* Exit points for errors.
*/
missingArg:
TclX_AppendObjResult (interp, "missing argument for ", argv [nextArg],
(char *) NULL);
return TCL_ERROR;
unixError:
TclX_AppendObjResult (interp, Tcl_PosixError (interp), (char *) NULL);
CloseForError (interp, channel, socketFD);
return TCL_ERROR;
}
void
Tk_InitConsoleChannels(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey consoleInitKey;
int *consoleInitPtr, doIn, doOut, doErr;
ConsoleInfo *info;
Tcl_Channel consoleChannel;
/*
* Ensure that we are getting a compatible version of Tcl. This is really
* only an issue when Tk is loaded dynamically.
*/
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
return;
}
consoleInitPtr = Tcl_GetThreadData(&consoleInitKey, (int) sizeof(int));
if (*consoleInitPtr) {
/*
* We've already initialized console channels in this thread.
*/
return;
}
*consoleInitPtr = 1;
doIn = ShouldUseConsoleChannel(TCL_STDIN);
doOut = ShouldUseConsoleChannel(TCL_STDOUT);
doErr = ShouldUseConsoleChannel(TCL_STDERR);
if (!(doIn || doOut || doErr)) {
/*
* No std channels should be tied to the console; thus, no need to
* create the console.
*/
return;
}
/*
* At least one std channel wants to be tied to the console, so create the
* interp for it to live in.
*/
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
info->consoleInterp = NULL;
info->interp = NULL;
info->refCount = 0;
if (doIn) {
ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
data->info = info;
data->info->refCount++;
data->type = TCL_STDIN;
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
data, TCL_READABLE);
if (consoleChannel != NULL) {
Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8");
}
Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
Tcl_RegisterChannel(NULL, consoleChannel);
}
if (doOut) {
ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
data->info = info;
data->info->refCount++;
data->type = TCL_STDOUT;
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
data, TCL_WRITABLE);
if (consoleChannel != NULL) {
Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8");
}
Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
Tcl_RegisterChannel(NULL, consoleChannel);
}
if (doErr) {
ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
data->info = info;
data->info->refCount++;
data->type = TCL_STDERR;
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
data, TCL_WRITABLE);
if (consoleChannel != NULL) {
Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8");
}
Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
Tcl_RegisterChannel(NULL, consoleChannel);
}
}
/*
* 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;
}
