void
TclGetAndDetachPids(
Tcl_Interp *interp, /* Interpreter to append the PIDs to. */
Tcl_Channel chan) /* Handle for the pipeline. */
{
PipeState *pipePtr;
const Tcl_ChannelType *chanTypePtr;
int i;
char buf[TCL_INTEGER_SPACE];
/*
* Punt if the channel is not a command channel.
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
for (i = 0; i < pipePtr->numPids; i++) {
TclFormatInt(buf, (long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_AppendElement(interp, buf);
Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
}
if (pipePtr->numPids > 0) {
ckfree((char *) pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
void
TclGetAndDetachPids(
Tcl_Interp *interp, /* Interpreter to append the PIDs to. */
Tcl_Channel chan) /* Handle for the pipeline. */
{
PipeState *pipePtr;
const Tcl_ChannelType *chanTypePtr;
Tcl_Obj *pidsObj;
int i;
/*
* Punt if the channel is not a command channel.
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewIntObj(
PTR2INT(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/* ARGSUSED */
static void
TransformWatchProc(
ClientData instanceData, /* Channel to watch. */
int mask) /* Events of interest. */
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel downChan;
/*
* The caller expressed interest in events occuring for this channel. We
* are forwarding the call to the underlying channel now.
*/
dataPtr->watchMask = mask;
/*
* No channel handlers any more. We will be notified automatically about
* events on the channel below via a call to our 'TransformNotifyProc'.
* But we have to pass the interest down now. We are allowed to add
* additional 'interest' to the mask if we want to. But this
* transformation has no such interest. It just passes the request down,
* unchanged.
*/
if (dataPtr->self == NULL) {
return;
}
downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_GetChannelType(downChan)->watchProc(
Tcl_GetChannelInstanceData(downChan), mask);
/*
* Management of the internal timer.
*/
if ((dataPtr->timer != NULL) &&
(!(mask & TCL_READABLE) || ResultEmpty(&dataPtr->result))) {
/*
* A pending timer exists, but either is there no (more) interest in
* the events it generates or nothing is available for reading, so
* remove it.
*/
Tcl_DeleteTimerHandler(dataPtr->timer);
dataPtr->timer = NULL;
}
if ((dataPtr->timer == NULL) && (mask & TCL_READABLE)
&& !ResultEmpty(&dataPtr->result)) {
/*
* There is no pending timer, but there is interest in readable events
* and we actually have data waiting, so generate a timer to flush
* that.
*/
dataPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY,
TransformChannelHandlerTimer, dataPtr);
}
}
static int
TransformGetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
if (getOptionProc != NULL) {
return getOptionProc(Tcl_GetChannelInstanceData(downChan), interp,
optionName, dsPtr);
} else if (optionName == NULL) {
/*
* Request is query for all options, this is ok.
*/
return TCL_OK;
}
/*
* Request for a specific option has to fail, since we don't have any.
*/
return TCL_ERROR;
}
/*
*-------------------------------------------------------------------
*
* TlsGetOptionProc --
*
* Computes an option value for a SSL socket based channel, or a
* list of all options and their values.
*
* Results:
* A standard Tcl result. The value of the specified option or a
* list of all options and their values is returned in the
* supplied DString.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------
*/
static int
TlsGetOptionProc(ClientData instanceData, /* Socket state. */
Tcl_Interp *interp, /* For errors - can be NULL. */
CONST84 char *optionName, /* Name of the option to
* retrieve the value for, or
* NULL to get all options and
* their values. */
Tcl_DString *dsPtr) /* Where to store the computed value
* initialized by caller. */
{
State *statePtr = (State *) instanceData;
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
Tcl_Channel downChan = Tls_GetParent(statePtr);
Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
if (getOptionProc != NULL) {
return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
interp, optionName, dsPtr);
} else if (optionName == (char*) NULL) {
/*
* Request is query for all options, this is ok.
*/
return TCL_OK;
}
/*
* Request for a specific option has to fail, we don't have any.
*/
return TCL_ERROR;
} else {
size_t len = 0;
if (optionName != (char *) NULL) {
len = strlen(optionName);
}
#if 0
if ((len == 0) || ((len > 1) && (optionName[1] == 'c') &&
(strncmp(optionName, "-cipher", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-cipher");
}
Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
if (len) {
return TCL_OK;
}
}
#endif
return TCL_OK;
}
}
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
*/
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset,
mode, errorCodePtr);
}
/*
* It is a real request to change the position. Flush all data waiting for
* output and discard everything in the input buffers. Then pass the
* request down, unchanged.
*/
PreserveData(dataPtr);
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
P_NO_PRESERVE);
}
if (dataPtr->mode & TCL_READABLE) {
ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
P_NO_PRESERVE);
ResultClear(&dataPtr->result);
dataPtr->readIsFlushed = 0;
dataPtr->eofPending = 0;
}
ReleaseData(dataPtr);
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
/* 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;
}
static int
TransformSetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverSetOptionProc *setOptionProc;
setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
if (setOptionProc == NULL) {
return TCL_ERROR;
}
return setOptionProc(Tcl_GetChannelInstanceData(downChan), interp,
optionName, value);
}
/*
* Get back the connection from the Id
*/
PGconn *
PgGetConnectionId(Tcl_Interp *interp, CONST84 char *id,
Pg_ConnectionId ** connid_p)
{
Tcl_Channel conn_chan;
Pg_ConnectionId *connid;
conn_chan = Tcl_GetChannel(interp, id, 0);
if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, id, " is not a valid postgresql connection", 0);
if (connid_p)
*connid_p = NULL;
return (PGconn *) NULL;
}
connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
if (connid_p)
*connid_p = connid;
return connid->conn;
}
/* ARGSUSED */
int
Tcl_PidObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewLongObj((long) getpid()));
} else {
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeState *pipePtr;
int i;
Tcl_Obj *resultPtr, *longObjPtr;
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
}
pipePtr = (PipeState *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
}
/*
* Get the connection Id from the result Id
*/
int
PgGetConnByResultId(Tcl_Interp *interp, CONST84 char *resid_c)
{
char *mark;
Tcl_Channel conn_chan;
if (!(mark = strchr(resid_c, '.')))
goto error_out;
*mark = '\0';
conn_chan = Tcl_GetChannel(interp, resid_c, 0);
*mark = '.';
if (conn_chan && Tcl_GetChannelType(conn_chan) == &Pg_ConnType)
{
Tcl_SetResult(interp, (char *) Tcl_GetChannelName(conn_chan),
TCL_VOLATILE);
return TCL_OK;
}
error_out:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, resid_c, " is not a valid connection\n", 0);
return TCL_ERROR;
}
static int
getresid(Tcl_Interp *interp, CONST84 char *id, Pg_ConnectionId ** connid_p)
{
Tcl_Channel conn_chan;
char *mark;
int resid;
Pg_ConnectionId *connid;
if (!(mark = strchr(id, '.')))
return -1;
*mark = '\0';
conn_chan = Tcl_GetChannel(interp, id, 0);
*mark = '.';
if (conn_chan == NULL || Tcl_GetChannelType(conn_chan) != &Pg_ConnType)
{
Tcl_SetResult(interp, "Invalid connection handle", TCL_STATIC);
return -1;
}
if (Tcl_GetInt(interp, mark + 1, &resid) == TCL_ERROR)
{
Tcl_SetResult(interp, "Poorly formated result handle", TCL_STATIC);
return -1;
}
connid = (Pg_ConnectionId *) Tcl_GetChannelInstanceData(conn_chan);
if (resid < 0 || resid >= connid->res_max || connid->results[resid] == NULL)
{
Tcl_SetResult(interp, "Invalid result handle", TCL_STATIC);
return -1;
}
*connid_p = connid;
return resid;
}
int
Tk_CreateConsoleWindow(
Tcl_Interp *interp) /* Interpreter to use for prompting. */
{
Tcl_Channel chan;
ConsoleInfo *info;
Tk_Window mainWindow;
Tcl_Command token;
int result = TCL_OK;
int haveConsoleChannel = 1;
/* Init an interp with Tcl and Tk */
Tcl_Interp *consoleInterp = Tcl_CreateInterp();
if (Tcl_Init(consoleInterp) != TCL_OK) {
goto error;
}
if (Tk_Init(consoleInterp) != TCL_OK) {
goto error;
}
/*
* Fetch the instance data from whatever std channel is a
* console channel. If none, create fresh instance data.
*/
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
== &consoleChannelType) {
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
== &consoleChannelType) {
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
== &consoleChannelType) {
} else {
haveConsoleChannel = 0;
}
if (haveConsoleChannel) {
ChannelData *data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
info = data->info;
if (info->consoleInterp) {
/* New ConsoleInfo for a new console window */
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
info->refCount = 0;
/* Update any console channels to make use of the new console */
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
}
} else {
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
info->refCount = 0;
}
info->consoleInterp = consoleInterp;
info->interp = interp;
Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, info);
info->refCount++;
Tcl_CreateThreadExitHandler(DeleteConsoleInterp, consoleInterp);
/*
* Add console commands to the interp
*/
token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd, info,
ConsoleDeleteProc);
info->refCount++;
/*
* We don't have to count the ref held by the [consoleinterp] command
* in the consoleInterp. The ref held by the consoleInterp delete
* handler takes care of us.
*/
Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
info, NULL);
mainWindow = Tk_MainWindow(interp);
if (mainWindow) {
Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
ConsoleEventProc, info);
info->refCount++;
}
Tcl_Preserve(consoleInterp);
result = Tcl_GlobalEval(consoleInterp, "source $tk_library/console.tcl");
if (result == TCL_ERROR) {
Tcl_SetReturnOptions(interp,
Tcl_GetReturnOptions(consoleInterp, result));
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
}
Tcl_Release(consoleInterp);
if (result == TCL_ERROR) {
Tcl_DeleteCommandFromToken(interp, token);
mainWindow = Tk_MainWindow(interp);
if (mainWindow) {
Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
ConsoleEventProc, info);
if (--info->refCount <= 0) {
ckfree((char *) info);
}
}
goto error;
}
return TCL_OK;
error:
Tcl_AddErrorInfo(interp, "\n (creating console window)");
if (!Tcl_InterpDeleted(consoleInterp)) {
Tcl_DeleteInterp(consoleInterp);
}
return TCL_ERROR;
}
static Tcl_WideInt
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
Tcl_WideInt offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
ClientData parentData = Tcl_GetChannelInstanceData(parent);
if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
*/
if (parentWideSeekProc != NULL) {
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode,
errorCodePtr));
}
/*
* It is a real request to change the position. Flush all data waiting for
* output and discard everything in the input buffers. Then pass the
* request down, unchanged.
*/
PreserveData(dataPtr);
if (dataPtr->mode & TCL_WRITABLE) {
ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
P_NO_PRESERVE);
}
if (dataPtr->mode & TCL_READABLE) {
ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
P_NO_PRESERVE);
ResultClear(&dataPtr->result);
dataPtr->readIsFlushed = 0;
dataPtr->eofPending = 0;
}
ReleaseData(dataPtr);
/*
* If we have a wide seek capability, we should stick with that.
*/
if (parentWideSeekProc != NULL) {
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
/*
* We're transferring to narrow seeks at this point; this is a bit complex
* because we have to check whether the seek is possible first (i.e.
* whether we are losing information in truncating the bits of the
* offset). Luckily, there's a defined error for what happens when trying
* to go out of the representable range.
*/
if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
*errorCodePtr = EOVERFLOW;
return Tcl_LongAsWide(-1);
}
return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset),
mode, errorCodePtr));
}
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;
}
static void
TlsWatchProc(ClientData instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed
* combination of TCL_READABLE,
* TCL_WRITABLE and TCL_EXCEPTION. */
{
State *statePtr = (State *) instanceData;
dprintf(stderr, "TlsWatchProc(0x%x)\n", mask);
/* Pretend to be dead as long as the verify callback is running.
* Otherwise that callback could be invoked recursively. */
if (statePtr->flags & TLS_TCL_CALLBACK) { return; }
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
Tcl_Channel downChan;
statePtr->watchMask = mask;
/* No channel handlers any more. We will be notified automatically
* about events on the channel below via a call to our
* 'TransformNotifyProc'. But we have to pass the interest down now.
* We are allowed to add additional 'interest' to the mask if we want
* to. But this transformation has no such interest. It just passes
* the request down, unchanged.
*/
downChan = Tls_GetParent(statePtr);
(Tcl_GetChannelType(downChan))
->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
/*
* Management of the internal timer.
*/
if (statePtr->timer != (Tcl_TimerToken) NULL) {
Tcl_DeleteTimerHandler(statePtr->timer);
statePtr->timer = (Tcl_TimerToken) NULL;
}
if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
/*
* There is interest in readable events and we actually have
* data waiting, so generate a timer to flush that.
*/
statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
TlsChannelHandlerTimer, (ClientData) statePtr);
}
} else {
if (mask == statePtr->watchMask)
return;
if (statePtr->watchMask) {
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
TlsChannelHandler, (ClientData) statePtr);
}
statePtr->watchMask = mask;
if (statePtr->watchMask) {
/*
* Setup active monitor for events on underlying Channel.
*/
Tcl_CreateChannelHandler(Tls_GetParent(statePtr),
statePtr->watchMask, TlsChannelHandler,
(ClientData) statePtr);
}
}
}
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;
}
