void *
TclpMakeTcpClientChannelMode(
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
statePtr = ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, mode);
if (Tcl_SetChannelOption(NULL, statePtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_Close(NULL, statePtr->channel);
return NULL;
}
return statePtr->channel;
}
/* ARGSUSED */
int
Tcl_FconfigureObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
Tcl_WrongNumArgs(interp, 1, objv,
"channelId ?optionName? ?value? ?optionName value?...");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 2) {
Tcl_DString ds; /* DString to hold result of calling
* Tcl_GetChannelOption. */
Tcl_DStringInit(&ds);
if (Tcl_GetChannelOption(interp, chan, NULL, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
} else if (objc == 3) {
Tcl_DString ds; /* DString to hold result of calling
* Tcl_GetChannelOption. */
Tcl_DStringInit(&ds);
optionName = TclGetString(objv[2]);
if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
for (i = 3; i < objc; i += 2) {
optionName = TclGetString(objv[i-1]);
valueName = TclGetString(objv[i]);
if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
!= TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
int LoadFromFile(Tcl_Interp * interp, CxImage * image, char * fileName, int Type) {
Tcl_Obj *data = Tcl_NewObj();
Tcl_Channel chan = Tcl_OpenFileChannel(interp, fileName, "r", 0);
BYTE * FileData = NULL;
int length = 0;
int retVal;
if (chan == NULL)
return FALSE;
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = GetFileTypeFromFileName((char *)fileName);
}
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = CXIMAGE_FORMAT_GIF;
}
Tcl_SetChannelOption(interp, chan, "-encoding", "binary");
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
Tcl_ReadChars(chan, data, -1, 0);
Tcl_Close(interp, chan);
FileData = Tcl_GetByteArrayFromObj(data, &length);
if (! image->Decode(FileData, length, Type) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_GIF) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_PNG) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_JPG) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_TGA) &&
! image->Decode(FileData, length, CXIMAGE_FORMAT_BMP))
retVal = FALSE;
else
retVal = TRUE;
Tcl_DecrRefCount(data);
return retVal;
}
int SaveToFile(Tcl_Interp * interp, CxImage * image, char * fileName, int Type) {
Tcl_Channel chan = Tcl_OpenFileChannel(interp, fileName, "w", 0644);
BYTE * FileData = NULL;
long length = 0;
if (chan == NULL)
return FALSE;
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = GetFileTypeFromFileName((char *)fileName);
}
if (Type == CXIMAGE_FORMAT_UNKNOWN) {
Type = CXIMAGE_FORMAT_GIF;
}
Tcl_SetChannelOption(interp, chan, "-encoding", "binary");
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
if (!image->Encode(FileData, length, Type) ) {
Tcl_AppendResult(interp, image->GetLastError(), NULL);
return TCL_ERROR;
}
Tcl_WriteObj(chan, Tcl_NewByteArrayObj(FileData, length));
image->FreeMemory(FileData);
Tcl_ResetResult(interp);
if (Tcl_Close(interp, chan) == TCL_ERROR)
return FALSE;
else
return TRUE;
}
void
TkConsoleCreate()
{
Tcl_Channel consoleChannel;
#ifdef HAVE_UTF
TclInitSubsystems(NULL);
#endif
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
(ClientData)TCL_STDIN, TCL_READABLE);
if (consoleChannel != NULL) {
Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
#ifdef HAVE_UTF
Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8");
#endif
}
Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
(ClientData)TCL_STDOUT, TCL_WRITABLE);
if (consoleChannel != NULL) {
Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
#ifdef HAVE_UTF
Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8");
#endif
}
Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
(ClientData)TCL_STDERR, TCL_WRITABLE);
if (consoleChannel != NULL) {
Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
#ifdef HAVE_UTF
Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8");
#endif
}
Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
}
/* ARGSUSED */
static void
TcpAccept(
ClientData data, /* Callback token. */
int mask) /* Not used. */
{
TcpFdList *fds = data; /* Client data of server socket. */
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
address addr; /* The remote address */
socklen_t len; /* For accept interface */
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
len = sizeof(addr);
newsock = accept(fds->fd, &addr.sa, &len);
if (newsock < 0) {
return;
}
/*
* Set close-on-exec flag to prevent the newly accepted socket from being
* inherited by child processes.
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = ckalloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
sprintf(channelName, SOCK_TEMPLATE, (long) newSockState);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, (TCL_READABLE | TCL_WRITABLE));
Tcl_SetChannelOption(NULL, newSockState->channel, "-translation",
"auto crlf");
if (fds->statePtr->acceptProc != NULL) {
getnameinfo(&addr.sa, len, host, sizeof(host), port, sizeof(port),
NI_NUMERICHOST|NI_NUMERICSERV);
fds->statePtr->acceptProc(fds->statePtr->acceptProcData,
newSockState->channel, host, atoi(port));
}
}
/*
* 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);
}
static int
TlsBlockModeProc(ClientData instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
State *statePtr = (State *) instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
statePtr->flags |= TLS_TCL_ASYNC;
} else {
statePtr->flags &= ~(TLS_TCL_ASYNC);
}
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
return 0;
} else {
return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
"-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1");
}
}
Tcl_Channel
Tcl_OpenTcpClient(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
int port, /* Port number to open. */
const char *host, /* Host on which to open port. */
const char *myaddr, /* Client-side address */
int myport, /* Client-side port */
int async) /* If nonzero, attempt to do an asynchronous
* connect. Otherwise we do a blocking
* connect. */
{
TcpState *statePtr;
const char *errorMsg = NULL;
struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
char channelName[SOCK_CHAN_LENGTH];
/*
* Do the name lookups for the local and remote addresses.
*/
if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)
|| !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
&errorMsg)) {
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open socket: %s", errorMsg));
}
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
statePtr = ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
statePtr->cachedBlocking = TCL_MODE_BLOCKING;
statePtr->addrlist = addrlist;
statePtr->myaddrlist = myaddrlist;
statePtr->fds.fd = -1;
/*
* Create a new client socket and wrap it in a channel.
*/
if (TcpConnect(interp, statePtr) != TCL_OK) {
TcpCloseProc(statePtr, NULL);
return NULL;
}
sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr,
(TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
Tcl_Close(NULL, statePtr->channel);
return NULL;
}
return statePtr->channel;
}
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
DWORD id, modes;
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
infoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
* channel names unique, since some may share handles (stdin/stdout/stderr
* for instance).
*/
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
(ClientData) infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
GetConsoleMode(infoPtr->handle, &modes);
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
infoPtr, 0, &id);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
}
if (permissions & TCL_WRITABLE) {
infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
infoPtr, 0, &id);
SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
if (tclWinProcs->useWide)
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
else
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
return infoPtr->channel;
}
/* 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;
}
Tcl_Channel
TclpGetDefaultStdChannel(
int type) /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel = NULL;
int fd = 0; /* Initializations needed to prevent */
int mode = 0; /* compiler warning (used before set). */
const char *bufMode = NULL;
/*
* Some #def's to make the code a little clearer!
*/
#define ZERO_OFFSET ((Tcl_SeekOffset) 0)
#define ERROR_OFFSET ((Tcl_SeekOffset) -1)
switch (type) {
case TCL_STDIN:
if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
fd = 0;
mode = TCL_READABLE;
bufMode = "line";
break;
case TCL_STDOUT:
if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
fd = 1;
mode = TCL_WRITABLE;
bufMode = "line";
break;
case TCL_STDERR:
if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return NULL;
}
fd = 2;
mode = TCL_WRITABLE;
bufMode = "none";
break;
default:
Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type");
break;
}
#undef ZERO_OFFSET
#undef ERROR_OFFSET
channel = Tcl_MakeFileChannel(INT2PTR(fd), mode);
if (channel == NULL) {
return NULL;
}
/*
* Set up the normal channel options for stdio handles.
*/
if (Tcl_GetChannelType(channel) == &fileChannelType) {
Tcl_SetChannelOption(NULL, channel, "-translation", "auto");
} else {
Tcl_SetChannelOption(NULL, channel, "-translation", "auto crlf");
}
Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode);
return channel;
}
Tcl_Channel
TclpOpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting; can be
* NULL. */
Tcl_Obj *pathPtr, /* Name of file to open. */
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a file, with
* what modes to create it? */
{
int fd, channelPermissions;
FileState *fsPtr;
const char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
const Tcl_ChannelType *channelTypePtr;
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
channelPermissions = TCL_READABLE;
break;
case O_WRONLY:
channelPermissions = TCL_WRITABLE;
break;
case O_RDWR:
channelPermissions = (TCL_READABLE | TCL_WRITABLE);
break;
default:
/*
* This may occurr if modeString was "", for example.
*/
Tcl_Panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
TclGetString(pathPtr), "\": filename is invalid on this platform",
NULL);
}
return NULL;
}
#ifdef DJGPP
SET_BITS(mode, O_BINARY);
#endif
fd = TclOSopen(native, mode, permissions);
if (fd < 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
TclGetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
*/
fcntl(fd, F_SETFD, FD_CLOEXEC);
sprintf(channelName, "file%d", fd);
#ifdef SUPPORTS_TTY
if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) {
/*
* Initialize the serial port to a set of sane parameters. Especially
* important if the remote device is set to echo and the serial port
* driver was also set to echo -- as soon as a char were sent to the
* serial port, the remote device would echo it, then the serial
* driver would echo it back to the device, etc.
*
* Note that we do not do this if we're dealing with /dev/tty itself,
* as that tends to cause Bad Things To Happen when you're working
* interactively. Strictly a better check would be to see if the FD
* being set up is a device and has the same major/minor as the
* initial std FDs (beware reopening!) but that's nearly as messy.
*/
translation = "auto crlf";
channelTypePtr = &ttyChannelType;
TtyInit(fd);
} else
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
}
fsPtr = ckalloc(sizeof(FileState));
fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fd = fd;
fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, channelPermissions);
if (translation != NULL) {
/*
* Gotcha. Most modems need a "\r" at the end of the command sequence.
* If you just send "at\n", the modem will not respond with "OK"
* because it never got a "\r" to actually invoke the command. So, by
* default, newlines are translated to "\r\n" on output to avoid "bug"
* reports that the serial port isn't working.
*/
if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation",
translation) != TCL_OK) {
Tcl_Close(NULL, fsPtr->channel);
return NULL;
}
}
return fsPtr->channel;
}
/*
* 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;
}
char *
TkGetBitmapData(
Tcl_Interp *interp, /* For reporting errors, or NULL. */
const char *string, /* String describing bitmap. May be NULL. */
const char *fileName, /* Name of file containing bitmap description.
* Used only if string is NULL. Must not be
* NULL if string is NULL. */
int *widthPtr, int *heightPtr,
/* Dimensions of bitmap get returned here. */
int *hotXPtr, int *hotYPtr) /* Position of hot spot or -1,-1. */
{
int width, height, numBytes, hotX, hotY;
const char *expandedFileName;
char *p, *end;
ParseInfo pi;
char *data = NULL;
Tcl_DString buffer;
pi.string = string;
if (string == NULL) {
if ((interp != NULL) && Tcl_IsSafe(interp)) {
Tcl_AppendResult(interp, "can't get bitmap data from a file in a",
" safe interpreter", NULL);
return NULL;
}
expandedFileName = Tcl_TranslateFileName(interp, fileName, &buffer);
if (expandedFileName == NULL) {
return NULL;
}
pi.chan = Tcl_OpenFileChannel(interp, expandedFileName, "r", 0);
Tcl_DStringFree(&buffer);
if (pi.chan == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read bitmap file \"",
fileName, "\": ", Tcl_PosixError(interp), NULL);
}
return NULL;
}
if (Tcl_SetChannelOption(interp, pi.chan, "-translation", "binary")
!= TCL_OK) {
return NULL;
}
if (Tcl_SetChannelOption(interp, pi.chan, "-encoding", "binary")
!= TCL_OK) {
return NULL;
}
} else {
pi.chan = NULL;
}
/*
* Parse the lines that define the dimensions of the bitmap, plus the
* first line that defines the bitmap data (it declares the name of a data
* variable but doesn't include any actual data). These lines look
* something like the following:
*
* #define foo_width 16
* #define foo_height 16
* #define foo_x_hot 3
* #define foo_y_hot 3
* static char foo_bits[] = {
*
* The x_hot and y_hot lines may or may not be present. It's important to
* check for "char" in the last line, in order to reject old X10-style
* bitmaps that used shorts.
*/
width = 0;
height = 0;
hotX = -1;
hotY = -1;
while (1) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
&& (strcmp(pi.word+pi.wordLength-6, "_width") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
width = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.wordLength >= 7) && (pi.word[pi.wordLength-7] == '_')
&& (strcmp(pi.word+pi.wordLength-7, "_height") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
height = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
&& (strcmp(pi.word+pi.wordLength-6, "_x_hot") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
hotX = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_')
&& (strcmp(pi.word+pi.wordLength-6, "_y_hot") == 0)) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
hotY = strtol(pi.word, &end, 0);
if ((end == pi.word) || (*end != 0)) {
goto error;
}
} else if ((pi.word[0] == 'c') && (strcmp(pi.word, "char") == 0)) {
while (1) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
if ((pi.word[0] == '{') && (pi.word[1] == 0)) {
goto getData;
}
}
} else if ((pi.word[0] == '{') && (pi.word[1] == 0)) {
if (interp != NULL) {
Tcl_AppendResult(interp, "format error in bitmap data; ",
"looks like it's an obsolete X10 bitmap file", NULL);
}
goto errorCleanup;
}
}
/*
* Now we've read everything but the data. Allocate an array and read in
* the data.
*/
getData:
if ((width <= 0) || (height <= 0)) {
goto error;
}
numBytes = ((width+7)/8) * height;
data = ckalloc((unsigned) numBytes);
for (p = data; numBytes > 0; p++, numBytes--) {
if (NextBitmapWord(&pi) != TCL_OK) {
goto error;
}
*p = (char) strtol(pi.word, &end, 0);
if (end == pi.word) {
goto error;
}
}
/*
* All done. Clean up and return.
*/
if (pi.chan != NULL) {
Tcl_Close(NULL, pi.chan);
}
*widthPtr = width;
*heightPtr = height;
*hotXPtr = hotX;
*hotYPtr = hotY;
return data;
error:
if (interp != NULL) {
Tcl_SetResult(interp, "format error in bitmap data", TCL_STATIC);
}
errorCleanup:
if (data != NULL) {
ckfree(data);
}
if (pi.chan != NULL) {
Tcl_Close(NULL, pi.chan);
}
return NULL;
}
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;
}
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
FileWritePPM(
Tcl_Interp *interp,
CONST char *fileName,
Tcl_Obj *format,
Tk_PhotoImageBlock *blockPtr)
{
Tcl_Channel chan;
int w, h, greenOffset, blueOffset, nBytes;
unsigned char *pixelPtr, *pixLinePtr;
char header[16 + TCL_INTEGER_SPACE * 2];
chan = Tcl_OpenFileChannel(interp, fileName, "w", 0666);
if (chan == NULL) {
return TCL_ERROR;
}
if (Tcl_SetChannelOption(interp, chan, "-translation", "binary")
!= TCL_OK) {
Tcl_Close(NULL, chan);
return TCL_ERROR;
}
if (Tcl_SetChannelOption(interp, chan, "-encoding", "binary")
!= TCL_OK) {
Tcl_Close(NULL, chan);
return TCL_ERROR;
}
sprintf(header, "P6\n%d %d\n255\n", blockPtr->width, blockPtr->height);
Tcl_Write(chan, header, -1);
pixLinePtr = blockPtr->pixelPtr + blockPtr->offset[0];
greenOffset = blockPtr->offset[1] - blockPtr->offset[0];
blueOffset = blockPtr->offset[2] - blockPtr->offset[0];
if ((greenOffset == 1) && (blueOffset == 2) && (blockPtr->pixelSize == 3)
&& (blockPtr->pitch == (blockPtr->width * 3))) {
nBytes = blockPtr->height * blockPtr->pitch;
if (Tcl_Write(chan, (char *) pixLinePtr, nBytes) != nBytes) {
goto writeerror;
}
} else {
for (h = blockPtr->height; h > 0; h--) {
pixelPtr = pixLinePtr;
for (w = blockPtr->width; w > 0; w--) {
if ( Tcl_Write(chan,(char *)&pixelPtr[0], 1) == -1 ||
Tcl_Write(chan,(char *)&pixelPtr[greenOffset],1)==-1 ||
Tcl_Write(chan,(char *)&pixelPtr[blueOffset],1) ==-1) {
goto writeerror;
}
pixelPtr += blockPtr->pixelSize;
}
pixLinePtr += blockPtr->pitch;
}
}
if (Tcl_Close(NULL, chan) == 0) {
return TCL_OK;
}
chan = NULL;
writeerror:
Tcl_AppendResult(interp, "error writing \"", fileName, "\": ",
Tcl_PosixError(interp), NULL);
if (chan != NULL) {
Tcl_Close(NULL, chan);
}
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);
}
}
Tcl_Channel
TclWinOpenConsoleChannel(
HANDLE handle,
char *channelName,
int permissions)
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
DWORD modes;
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
infoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel. This keeps the
* channel names unique, since some may share handles (stdin/stdout/stderr
* for instance).
*/
sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering. IOW,
* we only want to catch when complete lines are ready for reading.
*/
GetConsoleMode(infoPtr->handle, &modes);
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread);
}
if (permissions & TCL_WRITABLE) {
StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
#ifdef UNICODE
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode");
#else
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
#endif
return infoPtr->channel;
}
