/*
|
/*
|
* tclIOCmd.c --
|
* tclIOCmd.c --
|
*
|
*
|
* Contains the definitions of most of the Tcl commands relating to IO.
|
* Contains the definitions of most of the Tcl commands relating to IO.
|
*
|
*
|
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
|
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
|
*
|
*
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*
|
*
|
* RCS: @(#) $Id: tclIOCmd.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
|
* RCS: @(#) $Id: tclIOCmd.c,v 1.1.1.1 2002-01-16 10:25:27 markom Exp $
|
*/
|
*/
|
|
|
#include "tclInt.h"
|
#include "tclInt.h"
|
#include "tclPort.h"
|
#include "tclPort.h"
|
|
|
/*
|
/*
|
* Return at most this number of bytes in one call to Tcl_Read:
|
* Return at most this number of bytes in one call to Tcl_Read:
|
*/
|
*/
|
|
|
#define TCL_READ_CHUNK_SIZE 4096
|
#define TCL_READ_CHUNK_SIZE 4096
|
|
|
/*
|
/*
|
* Callback structure for accept callback in a TCP server.
|
* Callback structure for accept callback in a TCP server.
|
*/
|
*/
|
|
|
typedef struct AcceptCallback {
|
typedef struct AcceptCallback {
|
char *script; /* Script to invoke. */
|
char *script; /* Script to invoke. */
|
Tcl_Interp *interp; /* Interpreter in which to run it. */
|
Tcl_Interp *interp; /* Interpreter in which to run it. */
|
} AcceptCallback;
|
} AcceptCallback;
|
|
|
/*
|
/*
|
* Static functions for this file:
|
* Static functions for this file:
|
*/
|
*/
|
|
|
static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
|
static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
|
Tcl_Channel chan, char *address, int port));
|
Tcl_Channel chan, char *address, int port));
|
static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
|
static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
|
AcceptCallback *acceptCallbackPtr));
|
AcceptCallback *acceptCallbackPtr));
|
static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
|
static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
|
ClientData clientData, Tcl_Interp *interp));
|
ClientData clientData, Tcl_Interp *interp));
|
static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
|
static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
|
static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
|
static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
|
Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));
|
Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr));
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_PutsObjCmd --
|
* Tcl_PutsObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "puts" Tcl command.
|
* This procedure is invoked to process the "puts" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Produces output on a channel.
|
* Produces output on a channel.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_PutsObjCmd(dummy, interp, objc, objv)
|
Tcl_PutsObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to puts on. */
|
Tcl_Channel chan; /* The channel to puts on. */
|
int i; /* Counter. */
|
int i; /* Counter. */
|
int newline; /* Add a newline at end? */
|
int newline; /* Add a newline at end? */
|
char *channelId; /* Name of channel for puts. */
|
char *channelId; /* Name of channel for puts. */
|
int result; /* Result of puts operation. */
|
int result; /* Result of puts operation. */
|
int mode; /* Mode in which channel is opened. */
|
int mode; /* Mode in which channel is opened. */
|
char *arg;
|
char *arg;
|
int length;
|
int length;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
|
|
i = 1;
|
i = 1;
|
newline = 1;
|
newline = 1;
|
if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL),
|
if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL),
|
"-nonewline") == 0)) {
|
"-nonewline") == 0)) {
|
newline = 0;
|
newline = 0;
|
i++;
|
i++;
|
}
|
}
|
if ((i < (objc-3)) || (i >= objc)) {
|
if ((i < (objc-3)) || (i >= objc)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
|
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* The code below provides backwards compatibility with an old
|
* The code below provides backwards compatibility with an old
|
* form of the command that is no longer recommended or documented.
|
* form of the command that is no longer recommended or documented.
|
*/
|
*/
|
|
|
resultPtr = Tcl_NewObj();
|
resultPtr = Tcl_NewObj();
|
if (i == (objc-3)) {
|
if (i == (objc-3)) {
|
arg = Tcl_GetStringFromObj(objv[i+2], &length);
|
arg = Tcl_GetStringFromObj(objv[i+2], &length);
|
if (strncmp(arg, "nonewline", (size_t) length) != 0) {
|
if (strncmp(arg, "nonewline", (size_t) length) != 0) {
|
Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
|
Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
|
"\": should be \"nonewline\"", (char *) NULL);
|
"\": should be \"nonewline\"", (char *) NULL);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
newline = 0;
|
newline = 0;
|
}
|
}
|
if (i == (objc-1)) {
|
if (i == (objc-1)) {
|
channelId = "stdout";
|
channelId = "stdout";
|
} else {
|
} else {
|
channelId = Tcl_GetStringFromObj(objv[i], NULL);
|
channelId = Tcl_GetStringFromObj(objv[i], NULL);
|
i++;
|
i++;
|
}
|
}
|
chan = Tcl_GetChannel(interp, channelId, &mode);
|
chan = Tcl_GetChannel(interp, channelId, &mode);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
Tcl_DecrRefCount(resultPtr);
|
Tcl_DecrRefCount(resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((mode & TCL_WRITABLE) == 0) {
|
if ((mode & TCL_WRITABLE) == 0) {
|
Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId,
|
Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId,
|
"\" wasn't opened for writing", (char *) NULL);
|
"\" wasn't opened for writing", (char *) NULL);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
arg = Tcl_GetStringFromObj(objv[i], &length);
|
arg = Tcl_GetStringFromObj(objv[i], &length);
|
result = Tcl_Write(chan, arg, length);
|
result = Tcl_Write(chan, arg, length);
|
if (result < 0) {
|
if (result < 0) {
|
goto error;
|
goto error;
|
}
|
}
|
if (newline != 0) {
|
if (newline != 0) {
|
result = Tcl_Write(chan, "\n", 1);
|
result = Tcl_Write(chan, "\n", 1);
|
if (result < 0) {
|
if (result < 0) {
|
goto error;
|
goto error;
|
}
|
}
|
}
|
}
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_OK;
|
return TCL_OK;
|
error:
|
error:
|
Tcl_AppendStringsToObj(resultPtr, "error writing \"",
|
Tcl_AppendStringsToObj(resultPtr, "error writing \"",
|
Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
|
Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
|
(char *) NULL);
|
(char *) NULL);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_FlushObjCmd --
|
* Tcl_FlushObjCmd --
|
*
|
*
|
* This procedure is called to process the Tcl "flush" command.
|
* This procedure is called to process the Tcl "flush" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May cause output to appear on the specified channel.
|
* May cause output to appear on the specified channel.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_FlushObjCmd(dummy, interp, objc, objv)
|
Tcl_FlushObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to flush on. */
|
Tcl_Channel chan; /* The channel to flush on. */
|
char *arg;
|
char *arg;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
int mode;
|
int mode;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
if ((mode & TCL_WRITABLE) == 0) {
|
if ((mode & TCL_WRITABLE) == 0) {
|
Tcl_AppendStringsToObj(resultPtr, "channel \"",
|
Tcl_AppendStringsToObj(resultPtr, "channel \"",
|
Tcl_GetStringFromObj(objv[1], NULL),
|
Tcl_GetStringFromObj(objv[1], NULL),
|
"\" wasn't opened for writing", (char *) NULL);
|
"\" wasn't opened for writing", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Tcl_Flush(chan) != TCL_OK) {
|
if (Tcl_Flush(chan) != TCL_OK) {
|
Tcl_AppendStringsToObj(resultPtr, "error flushing \"",
|
Tcl_AppendStringsToObj(resultPtr, "error flushing \"",
|
Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
|
Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_GetsObjCmd --
|
* Tcl_GetsObjCmd --
|
*
|
*
|
* This procedure is called to process the Tcl "gets" command.
|
* This procedure is called to process the Tcl "gets" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May consume input from channel.
|
* May consume input from channel.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_GetsObjCmd(dummy, interp, objc, objv)
|
Tcl_GetsObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to read from. */
|
Tcl_Channel chan; /* The channel to read from. */
|
int lineLen; /* Length of line just read. */
|
int lineLen; /* Length of line just read. */
|
int mode; /* Mode in which channel is opened. */
|
int mode; /* Mode in which channel is opened. */
|
char *arg;
|
char *arg;
|
Tcl_Obj *resultPtr, *objPtr;
|
Tcl_Obj *resultPtr, *objPtr;
|
|
|
if ((objc != 2) && (objc != 3)) {
|
if ((objc != 2) && (objc != 3)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
resultPtr = Tcl_NewObj();
|
resultPtr = Tcl_NewObj();
|
if ((mode & TCL_READABLE) == 0) {
|
if ((mode & TCL_READABLE) == 0) {
|
Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
|
Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
|
"\" wasn't opened for reading", (char *) NULL);
|
"\" wasn't opened for reading", (char *) NULL);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
lineLen = Tcl_GetsObj(chan, resultPtr);
|
lineLen = Tcl_GetsObj(chan, resultPtr);
|
if (lineLen < 0) {
|
if (lineLen < 0) {
|
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
|
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
|
Tcl_SetObjLength(resultPtr, 0);
|
Tcl_SetObjLength(resultPtr, 0);
|
Tcl_AppendStringsToObj(resultPtr, "error reading \"",
|
Tcl_AppendStringsToObj(resultPtr, "error reading \"",
|
Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
|
Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
|
(char *) NULL);
|
(char *) NULL);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
lineLen = -1;
|
lineLen = -1;
|
}
|
}
|
if (objc == 3) {
|
if (objc == 3) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
|
objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
|
resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
|
resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
|
if (objPtr == NULL) {
|
if (objPtr == NULL) {
|
Tcl_DecrRefCount(resultPtr);
|
Tcl_DecrRefCount(resultPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen);
|
Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ReadObjCmd --
|
* Tcl_ReadObjCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "read" command.
|
* This procedure is invoked to process the Tcl "read" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May consume input from channel.
|
* May consume input from channel.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_ReadObjCmd(dummy, interp, objc, objv)
|
Tcl_ReadObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to read from. */
|
Tcl_Channel chan; /* The channel to read from. */
|
int newline, i; /* Discard newline at end? */
|
int newline, i; /* Discard newline at end? */
|
int toRead; /* How many bytes to read? */
|
int toRead; /* How many bytes to read? */
|
int toReadNow; /* How many bytes to attempt to
|
int toReadNow; /* How many bytes to attempt to
|
* read in the current iteration? */
|
* read in the current iteration? */
|
int charactersRead; /* How many characters were read? */
|
int charactersRead; /* How many characters were read? */
|
int charactersReadNow; /* How many characters were read
|
int charactersReadNow; /* How many characters were read
|
* in this iteration? */
|
* in this iteration? */
|
int mode; /* Mode in which channel is opened. */
|
int mode; /* Mode in which channel is opened. */
|
int bufSize; /* Channel buffer size; used to decide
|
int bufSize; /* Channel buffer size; used to decide
|
* in what chunk sizes to read from
|
* in what chunk sizes to read from
|
* the channel. */
|
* the channel. */
|
char *arg;
|
char *arg;
|
Tcl_Obj *resultPtr;
|
Tcl_Obj *resultPtr;
|
|
|
if ((objc != 2) && (objc != 3)) {
|
if ((objc != 2) && (objc != 3)) {
|
argerror:
|
argerror:
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?");
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?");
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"",
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"",
|
Tcl_GetStringFromObj(objv[0], NULL),
|
Tcl_GetStringFromObj(objv[0], NULL),
|
" ?-nonewline? channelId\"", (char *) NULL);
|
" ?-nonewline? channelId\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
i = 1;
|
i = 1;
|
newline = 0;
|
newline = 0;
|
if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) {
|
if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) {
|
newline = 1;
|
newline = 1;
|
i++;
|
i++;
|
}
|
}
|
|
|
if (i == objc) {
|
if (i == objc) {
|
goto argerror;
|
goto argerror;
|
}
|
}
|
|
|
arg = Tcl_GetStringFromObj(objv[i], NULL);
|
arg = Tcl_GetStringFromObj(objv[i], NULL);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((mode & TCL_READABLE) == 0) {
|
if ((mode & TCL_READABLE) == 0) {
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
|
Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
|
"\" wasn't opened for reading", (char *) NULL);
|
"\" wasn't opened for reading", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
i++; /* Consumed channel name. */
|
i++; /* Consumed channel name. */
|
|
|
/*
|
/*
|
* Compute how many bytes to read, and see whether the final
|
* Compute how many bytes to read, and see whether the final
|
* newline should be dropped.
|
* newline should be dropped.
|
*/
|
*/
|
|
|
toRead = INT_MAX;
|
toRead = INT_MAX;
|
if (i < objc) {
|
if (i < objc) {
|
arg = Tcl_GetStringFromObj(objv[i], NULL);
|
arg = Tcl_GetStringFromObj(objv[i], NULL);
|
if (isdigit((unsigned char) (arg[0]))) {
|
if (isdigit((unsigned char) (arg[0]))) {
|
if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
|
if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
} else if (strcmp(arg, "nonewline") == 0) {
|
} else if (strcmp(arg, "nonewline") == 0) {
|
newline = 1;
|
newline = 1;
|
} else {
|
} else {
|
resultPtr = Tcl_GetObjResult(interp);
|
resultPtr = Tcl_GetObjResult(interp);
|
Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
|
Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
|
"\": should be \"nonewline\"", (char *) NULL);
|
"\": should be \"nonewline\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Create a new object and use that instead of the interpreter
|
* Create a new object and use that instead of the interpreter
|
* result. We cannot use the interpreter's result object because
|
* result. We cannot use the interpreter's result object because
|
* it may get smashed at any time by recursive calls.
|
* it may get smashed at any time by recursive calls.
|
*/
|
*/
|
|
|
resultPtr = Tcl_NewObj();
|
resultPtr = Tcl_NewObj();
|
|
|
bufSize = Tcl_GetChannelBufferSize(chan);
|
bufSize = Tcl_GetChannelBufferSize(chan);
|
|
|
/*
|
/*
|
* If the caller specified a maximum length to read, then that is
|
* If the caller specified a maximum length to read, then that is
|
* a good size to preallocate.
|
* a good size to preallocate.
|
*/
|
*/
|
|
|
if ((toRead != INT_MAX) && (toRead > bufSize)) {
|
if ((toRead != INT_MAX) && (toRead > bufSize)) {
|
Tcl_SetObjLength(resultPtr, toRead);
|
Tcl_SetObjLength(resultPtr, toRead);
|
}
|
}
|
|
|
for (charactersRead = 0; charactersRead < toRead; ) {
|
for (charactersRead = 0; charactersRead < toRead; ) {
|
toReadNow = toRead - charactersRead;
|
toReadNow = toRead - charactersRead;
|
if (toReadNow > bufSize) {
|
if (toReadNow > bufSize) {
|
toReadNow = bufSize;
|
toReadNow = bufSize;
|
}
|
}
|
|
|
/*
|
/*
|
* NOTE: This is a NOOP if we set the size (above) to the
|
* NOTE: This is a NOOP if we set the size (above) to the
|
* number of bytes we expect to read. In the degenerate
|
* number of bytes we expect to read. In the degenerate
|
* case, however, it will grow the buffer by the channel
|
* case, however, it will grow the buffer by the channel
|
* buffersize, which is 4K in most cases. This will result
|
* buffersize, which is 4K in most cases. This will result
|
* in inefficient copying for large files. This will be
|
* in inefficient copying for large files. This will be
|
* fixed in a future release.
|
* fixed in a future release.
|
*/
|
*/
|
|
|
Tcl_SetObjLength(resultPtr, charactersRead + toReadNow);
|
Tcl_SetObjLength(resultPtr, charactersRead + toReadNow);
|
charactersReadNow =
|
charactersReadNow =
|
Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL)
|
Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL)
|
+ charactersRead, toReadNow);
|
+ charactersRead, toReadNow);
|
if (charactersReadNow < 0) {
|
if (charactersReadNow < 0) {
|
Tcl_SetObjLength(resultPtr, 0);
|
Tcl_SetObjLength(resultPtr, 0);
|
Tcl_AppendStringsToObj(resultPtr, "error reading \"",
|
Tcl_AppendStringsToObj(resultPtr, "error reading \"",
|
Tcl_GetChannelName(chan), "\": ",
|
Tcl_GetChannelName(chan), "\": ",
|
Tcl_PosixError(interp), (char *) NULL);
|
Tcl_PosixError(interp), (char *) NULL);
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If we had a short read it means that we have either EOF
|
* If we had a short read it means that we have either EOF
|
* or BLOCKED on the channel, so break out.
|
* or BLOCKED on the channel, so break out.
|
*/
|
*/
|
|
|
charactersRead += charactersReadNow;
|
charactersRead += charactersReadNow;
|
|
|
/*
|
/*
|
* Do not call the driver again if we got a short read
|
* Do not call the driver again if we got a short read
|
*/
|
*/
|
|
|
if (charactersReadNow < toReadNow) {
|
if (charactersReadNow < toReadNow) {
|
break; /* Out of "for" loop. */
|
break; /* Out of "for" loop. */
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If requested, remove the last newline in the channel if at EOF.
|
* If requested, remove the last newline in the channel if at EOF.
|
*/
|
*/
|
|
|
if ((charactersRead > 0) && (newline) &&
|
if ((charactersRead > 0) && (newline) &&
|
(Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) {
|
(Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) {
|
charactersRead--;
|
charactersRead--;
|
}
|
}
|
Tcl_SetObjLength(resultPtr, charactersRead);
|
Tcl_SetObjLength(resultPtr, charactersRead);
|
|
|
/*
|
/*
|
* Now set the object into the interpreter result and release our
|
* Now set the object into the interpreter result and release our
|
* hold on it by decrrefing it.
|
* hold on it by decrrefing it.
|
*/
|
*/
|
|
|
Tcl_SetObjResult(interp, resultPtr);
|
Tcl_SetObjResult(interp, resultPtr);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SeekCmd --
|
* Tcl_SeekCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "seek" command. See
|
* This procedure is invoked to process the Tcl "seek" command. See
|
* the user documentation for details on what it does.
|
* the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Moves the position of the access point on the specified channel.
|
* Moves the position of the access point on the specified channel.
|
* May flush queued output.
|
* May flush queued output.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_SeekCmd(clientData, interp, argc, argv)
|
Tcl_SeekCmd(clientData, interp, argc, argv)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to tell on. */
|
Tcl_Channel chan; /* The channel to tell on. */
|
int offset, mode; /* Where to seek? */
|
int offset, mode; /* Where to seek? */
|
int result; /* Of calling Tcl_Seek. */
|
int result; /* Of calling Tcl_Seek. */
|
|
|
if ((argc != 3) && (argc != 4)) {
|
if ((argc != 3) && (argc != 4)) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" channelId offset ?origin?\"", (char *) NULL);
|
" channelId offset ?origin?\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
chan = Tcl_GetChannel(interp, argv[1], NULL);
|
chan = Tcl_GetChannel(interp, argv[1], NULL);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
|
if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
mode = SEEK_SET;
|
mode = SEEK_SET;
|
if (argc == 4) {
|
if (argc == 4) {
|
size_t length;
|
size_t length;
|
int c;
|
int c;
|
|
|
length = strlen(argv[3]);
|
length = strlen(argv[3]);
|
c = argv[3][0];
|
c = argv[3][0];
|
if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
|
if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
|
mode = SEEK_SET;
|
mode = SEEK_SET;
|
} else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
|
} else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
|
mode = SEEK_CUR;
|
mode = SEEK_CUR;
|
} else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
|
} else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
|
mode = SEEK_END;
|
mode = SEEK_END;
|
} else {
|
} else {
|
Tcl_AppendResult(interp, "bad origin \"", argv[3],
|
Tcl_AppendResult(interp, "bad origin \"", argv[3],
|
"\": should be start, current, or end", (char *) NULL);
|
"\": should be start, current, or end", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
result = Tcl_Seek(chan, offset, mode);
|
result = Tcl_Seek(chan, offset, mode);
|
if (result == -1) {
|
if (result == -1) {
|
Tcl_AppendResult(interp, "error during seek on \"",
|
Tcl_AppendResult(interp, "error during seek on \"",
|
Tcl_GetChannelName(chan), "\": ",
|
Tcl_GetChannelName(chan), "\": ",
|
Tcl_PosixError(interp), (char *) NULL);
|
Tcl_PosixError(interp), (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_TellCmd --
|
* Tcl_TellCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "tell" command.
|
* This procedure is invoked to process the Tcl "tell" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* None.
|
* None.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_TellCmd(clientData, interp, argc, argv)
|
Tcl_TellCmd(clientData, interp, argc, argv)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to tell on. */
|
Tcl_Channel chan; /* The channel to tell on. */
|
char buf[40];
|
char buf[40];
|
|
|
if (argc != 2) {
|
if (argc != 2) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" channelId\"", (char *) NULL);
|
" channelId\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
/*
|
/*
|
* Try to find a channel with the right name and permissions in
|
* Try to find a channel with the right name and permissions in
|
* the IO channel table of this interpreter.
|
* the IO channel table of this interpreter.
|
*/
|
*/
|
|
|
chan = Tcl_GetChannel(interp, argv[1], NULL);
|
chan = Tcl_GetChannel(interp, argv[1], NULL);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
TclFormatInt(buf, Tcl_Tell(chan));
|
TclFormatInt(buf, Tcl_Tell(chan));
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_CloseObjCmd --
|
* Tcl_CloseObjCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "close" command.
|
* This procedure is invoked to process the Tcl "close" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May discard queued input; may flush queued output.
|
* May discard queued input; may flush queued output.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_CloseObjCmd(clientData, interp, objc, objv)
|
Tcl_CloseObjCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to close. */
|
Tcl_Channel chan; /* The channel to close. */
|
int len; /* Length of error output. */
|
int len; /* Length of error output. */
|
char *arg;
|
char *arg;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
chan = Tcl_GetChannel(interp, arg, NULL);
|
chan = Tcl_GetChannel(interp, arg, NULL);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
|
if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
|
/*
|
/*
|
* If there is an error message and it ends with a newline, remove
|
* If there is an error message and it ends with a newline, remove
|
* the newline. This is done for command pipeline channels where the
|
* the newline. This is done for command pipeline channels where the
|
* error output from the subprocesses is stored in interp->result.
|
* error output from the subprocesses is stored in interp->result.
|
*
|
*
|
* NOTE: This is likely to not have any effect on regular error
|
* NOTE: This is likely to not have any effect on regular error
|
* messages produced by drivers during the closing of a channel,
|
* messages produced by drivers during the closing of a channel,
|
* because the Tcl convention is that such error messages do not
|
* because the Tcl convention is that such error messages do not
|
* have a terminating newline.
|
* have a terminating newline.
|
*/
|
*/
|
|
|
len = strlen(interp->result);
|
len = strlen(interp->result);
|
if ((len > 0) && (interp->result[len - 1] == '\n')) {
|
if ((len > 0) && (interp->result[len - 1] == '\n')) {
|
interp->result[len - 1] = '\0';
|
interp->result[len - 1] = '\0';
|
}
|
}
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_FconfigureCmd --
|
* Tcl_FconfigureCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "fconfigure" command.
|
* This procedure is invoked to process the Tcl "fconfigure" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* May modify the behavior of an IO channel.
|
* May modify the behavior of an IO channel.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_FconfigureCmd(clientData, interp, argc, argv)
|
Tcl_FconfigureCmd(clientData, interp, argc, argv)
|
ClientData clientData; /* Not used. */
|
ClientData clientData; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to set a mode on. */
|
Tcl_Channel chan; /* The channel to set a mode on. */
|
int i; /* Iterate over arg-value pairs. */
|
int i; /* Iterate over arg-value pairs. */
|
Tcl_DString ds; /* DString to hold result of
|
Tcl_DString ds; /* DString to hold result of
|
* calling Tcl_GetChannelOption. */
|
* calling Tcl_GetChannelOption. */
|
|
|
if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) {
|
if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" channelId ?optionName? ?value? ?optionName value?...\"",
|
" channelId ?optionName? ?value? ?optionName value?...\"",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
chan = Tcl_GetChannel(interp, argv[1], NULL);
|
chan = Tcl_GetChannel(interp, argv[1], NULL);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (argc == 2) {
|
if (argc == 2) {
|
Tcl_DStringInit(&ds);
|
Tcl_DStringInit(&ds);
|
if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
|
if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
|
Tcl_DStringFree(&ds);
|
Tcl_DStringFree(&ds);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_DStringResult(interp, &ds);
|
Tcl_DStringResult(interp, &ds);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
if (argc == 3) {
|
if (argc == 3) {
|
Tcl_DStringInit(&ds);
|
Tcl_DStringInit(&ds);
|
if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) {
|
if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) {
|
Tcl_DStringFree(&ds);
|
Tcl_DStringFree(&ds);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_DStringResult(interp, &ds);
|
Tcl_DStringResult(interp, &ds);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
for (i = 3; i < argc; i += 2) {
|
for (i = 3; i < argc; i += 2) {
|
if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) {
|
if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_EofObjCmd --
|
* Tcl_EofObjCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "eof" command.
|
* This procedure is invoked to process the Tcl "eof" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Sets interp->result to "0" or "1" depending on whether the
|
* Sets interp->result to "0" or "1" depending on whether the
|
* specified channel has an EOF condition.
|
* specified channel has an EOF condition.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_EofObjCmd(unused, interp, objc, objv)
|
Tcl_EofObjCmd(unused, interp, objc, objv)
|
ClientData unused; /* Not used. */
|
ClientData unused; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to query for EOF. */
|
Tcl_Channel chan; /* The channel to query for EOF. */
|
int mode; /* Mode in which channel is opened. */
|
int mode; /* Mode in which channel is opened. */
|
char buf[40];
|
char buf[40];
|
char *arg;
|
char *arg;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0);
|
TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_ExecCmd --
|
* Tcl_ExecCmd --
|
*
|
*
|
* This procedure is invoked to process the "exec" Tcl command.
|
* This procedure is invoked to process the "exec" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_ExecCmd(dummy, interp, argc, argv)
|
Tcl_ExecCmd(dummy, interp, argc, argv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
#ifdef MAC_TCL
|
#ifdef MAC_TCL
|
Tcl_AppendResult(interp, "exec not implemented under Mac OS",
|
Tcl_AppendResult(interp, "exec not implemented under Mac OS",
|
(char *)NULL);
|
(char *)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
#else /* !MAC_TCL */
|
#else /* !MAC_TCL */
|
int keepNewline, firstWord, background, length, result;
|
int keepNewline, firstWord, background, length, result;
|
Tcl_Channel chan;
|
Tcl_Channel chan;
|
Tcl_DString ds;
|
Tcl_DString ds;
|
int readSoFar, readNow, bufSize;
|
int readSoFar, readNow, bufSize;
|
|
|
/*
|
/*
|
* Check for a leading "-keepnewline" argument.
|
* Check for a leading "-keepnewline" argument.
|
*/
|
*/
|
|
|
keepNewline = 0;
|
keepNewline = 0;
|
for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-');
|
for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-');
|
firstWord++) {
|
firstWord++) {
|
if (strcmp(argv[firstWord], "-keepnewline") == 0) {
|
if (strcmp(argv[firstWord], "-keepnewline") == 0) {
|
keepNewline = 1;
|
keepNewline = 1;
|
} else if (strcmp(argv[firstWord], "--") == 0) {
|
} else if (strcmp(argv[firstWord], "--") == 0) {
|
firstWord++;
|
firstWord++;
|
break;
|
break;
|
} else {
|
} else {
|
Tcl_AppendResult(interp, "bad switch \"", argv[firstWord],
|
Tcl_AppendResult(interp, "bad switch \"", argv[firstWord],
|
"\": must be -keepnewline or --", (char *) NULL);
|
"\": must be -keepnewline or --", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
if (argc <= firstWord) {
|
if (argc <= firstWord) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" ?switches? arg ?arg ...?\"", (char *) NULL);
|
" ?switches? arg ?arg ...?\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* See if the command is to be run in background.
|
* See if the command is to be run in background.
|
*/
|
*/
|
|
|
background = 0;
|
background = 0;
|
if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
|
if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
|
argc--;
|
argc--;
|
argv[argc] = NULL;
|
argv[argc] = NULL;
|
background = 1;
|
background = 1;
|
}
|
}
|
|
|
chan = Tcl_OpenCommandChannel(interp, argc-firstWord,
|
chan = Tcl_OpenCommandChannel(interp, argc-firstWord,
|
argv+firstWord,
|
argv+firstWord,
|
(background ? 0 : TCL_STDOUT | TCL_STDERR));
|
(background ? 0 : TCL_STDOUT | TCL_STDERR));
|
|
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (background) {
|
if (background) {
|
|
|
/*
|
/*
|
* Get the list of PIDs from the pipeline into interp->result and
|
* Get the list of PIDs from the pipeline into interp->result and
|
* detach the PIDs (instead of waiting for them).
|
* detach the PIDs (instead of waiting for them).
|
*/
|
*/
|
|
|
TclGetAndDetachPids(interp, chan);
|
TclGetAndDetachPids(interp, chan);
|
|
|
if (Tcl_Close(interp, chan) != TCL_OK) {
|
if (Tcl_Close(interp, chan) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
|
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
|
#define EXEC_BUFFER_SIZE 4096
|
#define EXEC_BUFFER_SIZE 4096
|
|
|
Tcl_DStringInit(&ds);
|
Tcl_DStringInit(&ds);
|
readSoFar = 0; bufSize = 0;
|
readSoFar = 0; bufSize = 0;
|
while (1) {
|
while (1) {
|
bufSize += EXEC_BUFFER_SIZE;
|
bufSize += EXEC_BUFFER_SIZE;
|
Tcl_DStringSetLength(&ds, bufSize);
|
Tcl_DStringSetLength(&ds, bufSize);
|
readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar,
|
readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar,
|
EXEC_BUFFER_SIZE);
|
EXEC_BUFFER_SIZE);
|
if (readNow < 0) {
|
if (readNow < 0) {
|
Tcl_DStringFree(&ds);
|
Tcl_DStringFree(&ds);
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"error reading output from command: ",
|
"error reading output from command: ",
|
Tcl_PosixError(interp), (char *) NULL);
|
Tcl_PosixError(interp), (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
readSoFar += readNow;
|
readSoFar += readNow;
|
if (readNow < EXEC_BUFFER_SIZE) {
|
if (readNow < EXEC_BUFFER_SIZE) {
|
break; /* Out of "while (1)" loop. */
|
break; /* Out of "while (1)" loop. */
|
}
|
}
|
}
|
}
|
Tcl_DStringSetLength(&ds, readSoFar);
|
Tcl_DStringSetLength(&ds, readSoFar);
|
Tcl_DStringResult(interp, &ds);
|
Tcl_DStringResult(interp, &ds);
|
}
|
}
|
|
|
result = Tcl_Close(interp, chan);
|
result = Tcl_Close(interp, chan);
|
|
|
/*
|
/*
|
* If the last character of interp->result is a newline, then remove
|
* If the last character of interp->result is a newline, then remove
|
* the newline character (the newline would just confuse things).
|
* the newline character (the newline would just confuse things).
|
* Special hack: must replace the old terminating null character
|
* Special hack: must replace the old terminating null character
|
* as a signal to Tcl_AppendResult et al. that we've mucked with
|
* as a signal to Tcl_AppendResult et al. that we've mucked with
|
* the string.
|
* the string.
|
*/
|
*/
|
|
|
length = strlen(interp->result);
|
length = strlen(interp->result);
|
if (!keepNewline && (length > 0) &&
|
if (!keepNewline && (length > 0) &&
|
(interp->result[length-1] == '\n')) {
|
(interp->result[length-1] == '\n')) {
|
interp->result[length-1] = '\0';
|
interp->result[length-1] = '\0';
|
interp->result[length] = 'x';
|
interp->result[length] = 'x';
|
}
|
}
|
|
|
return result;
|
return result;
|
#endif /* !MAC_TCL */
|
#endif /* !MAC_TCL */
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_FblockedObjCmd --
|
* Tcl_FblockedObjCmd --
|
*
|
*
|
* This procedure is invoked to process the Tcl "fblocked" command.
|
* This procedure is invoked to process the Tcl "fblocked" command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Sets interp->result to "0" or "1" depending on whether the
|
* Sets interp->result to "0" or "1" depending on whether the
|
* a preceding input operation on the channel would have blocked.
|
* a preceding input operation on the channel would have blocked.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_FblockedObjCmd(unused, interp, objc, objv)
|
Tcl_FblockedObjCmd(unused, interp, objc, objv)
|
ClientData unused; /* Not used. */
|
ClientData unused; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel chan; /* The channel to query for blocked. */
|
Tcl_Channel chan; /* The channel to query for blocked. */
|
int mode; /* Mode in which channel was opened. */
|
int mode; /* Mode in which channel was opened. */
|
char buf[40];
|
char buf[40];
|
char *arg;
|
char *arg;
|
|
|
if (objc != 2) {
|
if (objc != 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
chan = Tcl_GetChannel(interp, arg, &mode);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((mode & TCL_READABLE) == 0) {
|
if ((mode & TCL_READABLE) == 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
|
Tcl_GetStringFromObj(objv[1], NULL),
|
Tcl_GetStringFromObj(objv[1], NULL),
|
"\" wasn't opened for reading", (char *) NULL);
|
"\" wasn't opened for reading", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0);
|
TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
Tcl_SetResult(interp, buf, TCL_VOLATILE);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_OpenCmd --
|
* Tcl_OpenCmd --
|
*
|
*
|
* This procedure is invoked to process the "open" Tcl command.
|
* This procedure is invoked to process the "open" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* See the user documentation.
|
* See the user documentation.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
int
|
int
|
Tcl_OpenCmd(notUsed, interp, argc, argv)
|
Tcl_OpenCmd(notUsed, interp, argc, argv)
|
ClientData notUsed; /* Not used. */
|
ClientData notUsed; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
int pipeline, prot;
|
int pipeline, prot;
|
char *modeString;
|
char *modeString;
|
Tcl_Channel chan;
|
Tcl_Channel chan;
|
|
|
if ((argc < 2) || (argc > 4)) {
|
if ((argc < 2) || (argc > 4)) {
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
" fileName ?access? ?permissions?\"", (char *) NULL);
|
" fileName ?access? ?permissions?\"", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
prot = 0666;
|
prot = 0666;
|
if (argc == 2) {
|
if (argc == 2) {
|
modeString = "r";
|
modeString = "r";
|
} else {
|
} else {
|
modeString = argv[2];
|
modeString = argv[2];
|
if (argc == 4) {
|
if (argc == 4) {
|
if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) {
|
if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
pipeline = 0;
|
pipeline = 0;
|
if (argv[1][0] == '|') {
|
if (argv[1][0] == '|') {
|
pipeline = 1;
|
pipeline = 1;
|
}
|
}
|
|
|
/*
|
/*
|
* Open the file or create a process pipeline.
|
* Open the file or create a process pipeline.
|
*/
|
*/
|
|
|
if (!pipeline) {
|
if (!pipeline) {
|
chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot);
|
chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot);
|
} else {
|
} else {
|
#ifdef MAC_TCL
|
#ifdef MAC_TCL
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"command pipelines not supported on Macintosh OS",
|
"command pipelines not supported on Macintosh OS",
|
(char *)NULL);
|
(char *)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
#else
|
#else
|
int mode, seekFlag, cmdArgc;
|
int mode, seekFlag, cmdArgc;
|
char **cmdArgv;
|
char **cmdArgv;
|
|
|
if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
|
if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
mode = TclGetOpenMode(interp, modeString, &seekFlag);
|
mode = TclGetOpenMode(interp, modeString, &seekFlag);
|
if (mode == -1) {
|
if (mode == -1) {
|
chan = NULL;
|
chan = NULL;
|
} else {
|
} else {
|
int flags = TCL_STDERR | TCL_ENFORCE_MODE;
|
int flags = TCL_STDERR | TCL_ENFORCE_MODE;
|
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
|
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
|
case O_RDONLY:
|
case O_RDONLY:
|
flags |= TCL_STDOUT;
|
flags |= TCL_STDOUT;
|
break;
|
break;
|
case O_WRONLY:
|
case O_WRONLY:
|
flags |= TCL_STDIN;
|
flags |= TCL_STDIN;
|
break;
|
break;
|
case O_RDWR:
|
case O_RDWR:
|
flags |= (TCL_STDIN | TCL_STDOUT);
|
flags |= (TCL_STDIN | TCL_STDOUT);
|
break;
|
break;
|
default:
|
default:
|
panic("Tcl_OpenCmd: invalid mode value");
|
panic("Tcl_OpenCmd: invalid mode value");
|
break;
|
break;
|
}
|
}
|
chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags);
|
chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags);
|
}
|
}
|
ckfree((char *) cmdArgv);
|
ckfree((char *) cmdArgv);
|
#endif
|
#endif
|
}
|
}
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_RegisterChannel(interp, chan);
|
Tcl_RegisterChannel(interp, chan);
|
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
|
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TcpAcceptCallbacksDeleteProc --
|
* TcpAcceptCallbacksDeleteProc --
|
*
|
*
|
* Assocdata cleanup routine called when an interpreter is being
|
* Assocdata cleanup routine called when an interpreter is being
|
* deleted to set the interp field of all the accept callback records
|
* deleted to set the interp field of all the accept callback records
|
* registered with the interpreter to NULL. This will prevent the
|
* registered with the interpreter to NULL. This will prevent the
|
* interpreter from being used in the future to eval accept scripts.
|
* interpreter from being used in the future to eval accept scripts.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Deallocates memory and sets the interp field of all the accept
|
* Deallocates memory and sets the interp field of all the accept
|
* callback records to NULL to prevent this interpreter from being
|
* callback records to NULL to prevent this interpreter from being
|
* used subsequently to eval accept scripts.
|
* used subsequently to eval accept scripts.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static void
|
static void
|
TcpAcceptCallbacksDeleteProc(clientData, interp)
|
TcpAcceptCallbacksDeleteProc(clientData, interp)
|
ClientData clientData; /* Data which was passed when the assocdata
|
ClientData clientData; /* Data which was passed when the assocdata
|
* was registered. */
|
* was registered. */
|
Tcl_Interp *interp; /* Interpreter being deleted - not used. */
|
Tcl_Interp *interp; /* Interpreter being deleted - not used. */
|
{
|
{
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashSearch hSearch;
|
Tcl_HashSearch hSearch;
|
AcceptCallback *acceptCallbackPtr;
|
AcceptCallback *acceptCallbackPtr;
|
|
|
hTblPtr = (Tcl_HashTable *) clientData;
|
hTblPtr = (Tcl_HashTable *) clientData;
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr != (Tcl_HashEntry *) NULL;
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
hPtr = Tcl_NextHashEntry(&hSearch)) {
|
acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
|
acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr);
|
acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
|
acceptCallbackPtr->interp = (Tcl_Interp *) NULL;
|
}
|
}
|
Tcl_DeleteHashTable(hTblPtr);
|
Tcl_DeleteHashTable(hTblPtr);
|
ckfree((char *) hTblPtr);
|
ckfree((char *) hTblPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* RegisterTcpServerInterpCleanup --
|
* RegisterTcpServerInterpCleanup --
|
*
|
*
|
* Registers an accept callback record to have its interp
|
* Registers an accept callback record to have its interp
|
* field set to NULL when the interpreter is deleted.
|
* field set to NULL when the interpreter is deleted.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* When, in the future, the interpreter is deleted, the interp
|
* When, in the future, the interpreter is deleted, the interp
|
* field of the accept callback data structure will be set to
|
* field of the accept callback data structure will be set to
|
* NULL. This will prevent attempts to eval the accept script
|
* NULL. This will prevent attempts to eval the accept script
|
* in a deleted interpreter.
|
* in a deleted interpreter.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
|
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr)
|
Tcl_Interp *interp; /* Interpreter for which we want to be
|
Tcl_Interp *interp; /* Interpreter for which we want to be
|
* informed of deletion. */
|
* informed of deletion. */
|
AcceptCallback *acceptCallbackPtr;
|
AcceptCallback *acceptCallbackPtr;
|
/* The accept callback record whose
|
/* The accept callback record whose
|
* interp field we want set to NULL when
|
* interp field we want set to NULL when
|
* the interpreter is deleted. */
|
* the interpreter is deleted. */
|
{
|
{
|
Tcl_HashTable *hTblPtr; /* Hash table for accept callback
|
Tcl_HashTable *hTblPtr; /* Hash table for accept callback
|
* records to smash when the interpreter
|
* records to smash when the interpreter
|
* will be deleted. */
|
* will be deleted. */
|
Tcl_HashEntry *hPtr; /* Entry for this record. */
|
Tcl_HashEntry *hPtr; /* Entry for this record. */
|
int new; /* Is the entry new? */
|
int new; /* Is the entry new? */
|
|
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
|
"tclTCPAcceptCallbacks",
|
"tclTCPAcceptCallbacks",
|
NULL);
|
NULL);
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
|
hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
|
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
|
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
|
(void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
|
(void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
|
TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
|
TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr);
|
}
|
}
|
hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
|
hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new);
|
if (!new) {
|
if (!new) {
|
panic("RegisterTcpServerCleanup: damaged accept record table");
|
panic("RegisterTcpServerCleanup: damaged accept record table");
|
}
|
}
|
Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* UnregisterTcpServerInterpCleanupProc --
|
* UnregisterTcpServerInterpCleanupProc --
|
*
|
*
|
* Unregister a previously registered accept callback record. The
|
* Unregister a previously registered accept callback record. The
|
* interp field of this record will no longer be set to NULL in
|
* interp field of this record will no longer be set to NULL in
|
* the future when the interpreter is deleted.
|
* the future when the interpreter is deleted.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Prevents the interp field of the accept callback record from
|
* Prevents the interp field of the accept callback record from
|
* being set to NULL in the future when the interpreter is deleted.
|
* being set to NULL in the future when the interpreter is deleted.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
|
UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr)
|
Tcl_Interp *interp; /* Interpreter in which the accept callback
|
Tcl_Interp *interp; /* Interpreter in which the accept callback
|
* record was registered. */
|
* record was registered. */
|
AcceptCallback *acceptCallbackPtr;
|
AcceptCallback *acceptCallbackPtr;
|
/* The record for which to delete the
|
/* The record for which to delete the
|
* registration. */
|
* registration. */
|
{
|
{
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashTable *hTblPtr;
|
Tcl_HashEntry *hPtr;
|
Tcl_HashEntry *hPtr;
|
|
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
|
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
|
"tclTCPAcceptCallbacks", NULL);
|
"tclTCPAcceptCallbacks", NULL);
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
if (hTblPtr == (Tcl_HashTable *) NULL) {
|
return;
|
return;
|
}
|
}
|
hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
|
hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
if (hPtr == (Tcl_HashEntry *) NULL) {
|
return;
|
return;
|
}
|
}
|
Tcl_DeleteHashEntry(hPtr);
|
Tcl_DeleteHashEntry(hPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* AcceptCallbackProc --
|
* AcceptCallbackProc --
|
*
|
*
|
* This callback is invoked by the TCP channel driver when it
|
* This callback is invoked by the TCP channel driver when it
|
* accepts a new connection from a client on a server socket.
|
* accepts a new connection from a client on a server socket.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Whatever the script does.
|
* Whatever the script does.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
AcceptCallbackProc(callbackData, chan, address, port)
|
AcceptCallbackProc(callbackData, chan, address, port)
|
ClientData callbackData; /* The data stored when the callback
|
ClientData callbackData; /* The data stored when the callback
|
* was created in the call to
|
* was created in the call to
|
* Tcl_OpenTcpServer. */
|
* Tcl_OpenTcpServer. */
|
Tcl_Channel chan; /* Channel for the newly accepted
|
Tcl_Channel chan; /* Channel for the newly accepted
|
* connection. */
|
* connection. */
|
char *address; /* Address of client that was
|
char *address; /* Address of client that was
|
* accepted. */
|
* accepted. */
|
int port; /* Port of client that was accepted. */
|
int port; /* Port of client that was accepted. */
|
{
|
{
|
AcceptCallback *acceptCallbackPtr;
|
AcceptCallback *acceptCallbackPtr;
|
Tcl_Interp *interp;
|
Tcl_Interp *interp;
|
char *script;
|
char *script;
|
char portBuf[10];
|
char portBuf[10];
|
int result;
|
int result;
|
|
|
acceptCallbackPtr = (AcceptCallback *) callbackData;
|
acceptCallbackPtr = (AcceptCallback *) callbackData;
|
|
|
/*
|
/*
|
* Check if the callback is still valid; the interpreter may have gone
|
* Check if the callback is still valid; the interpreter may have gone
|
* away, this is signalled by setting the interp field of the callback
|
* away, this is signalled by setting the interp field of the callback
|
* data to NULL.
|
* data to NULL.
|
*/
|
*/
|
|
|
if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
|
if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
|
|
|
script = acceptCallbackPtr->script;
|
script = acceptCallbackPtr->script;
|
interp = acceptCallbackPtr->interp;
|
interp = acceptCallbackPtr->interp;
|
|
|
Tcl_Preserve((ClientData) script);
|
Tcl_Preserve((ClientData) script);
|
Tcl_Preserve((ClientData) interp);
|
Tcl_Preserve((ClientData) interp);
|
|
|
TclFormatInt(portBuf, port);
|
TclFormatInt(portBuf, port);
|
Tcl_RegisterChannel(interp, chan);
|
Tcl_RegisterChannel(interp, chan);
|
|
|
/*
|
/*
|
* Artificially bump the refcount to protect the channel from
|
* Artificially bump the refcount to protect the channel from
|
* being deleted while the script is being evaluated.
|
* being deleted while the script is being evaluated.
|
*/
|
*/
|
|
|
Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
|
Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
|
|
|
result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
|
result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
|
" ", address, " ", portBuf, (char *) NULL);
|
" ", address, " ", portBuf, (char *) NULL);
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
Tcl_BackgroundError(interp);
|
Tcl_BackgroundError(interp);
|
Tcl_UnregisterChannel(interp, chan);
|
Tcl_UnregisterChannel(interp, chan);
|
}
|
}
|
|
|
/*
|
/*
|
* Decrement the artificially bumped refcount. After this it is
|
* Decrement the artificially bumped refcount. After this it is
|
* not safe anymore to use "chan", because it may now be deleted.
|
* not safe anymore to use "chan", because it may now be deleted.
|
*/
|
*/
|
|
|
Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
|
Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
|
|
|
Tcl_Release((ClientData) interp);
|
Tcl_Release((ClientData) interp);
|
Tcl_Release((ClientData) script);
|
Tcl_Release((ClientData) script);
|
} else {
|
} else {
|
|
|
/*
|
/*
|
* The interpreter has been deleted, so there is no useful
|
* The interpreter has been deleted, so there is no useful
|
* way to utilize the client socket - just close it.
|
* way to utilize the client socket - just close it.
|
*/
|
*/
|
|
|
Tcl_Close((Tcl_Interp *) NULL, chan);
|
Tcl_Close((Tcl_Interp *) NULL, chan);
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* TcpServerCloseProc --
|
* TcpServerCloseProc --
|
*
|
*
|
* This callback is called when the TCP server channel for which it
|
* This callback is called when the TCP server channel for which it
|
* was registered is being closed. It informs the interpreter in
|
* was registered is being closed. It informs the interpreter in
|
* which the accept script is evaluated (if that interpreter still
|
* which the accept script is evaluated (if that interpreter still
|
* exists) that this channel no longer needs to be informed if the
|
* exists) that this channel no longer needs to be informed if the
|
* interpreter is deleted.
|
* interpreter is deleted.
|
*
|
*
|
* Results:
|
* Results:
|
* None.
|
* None.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* In the future, if the interpreter is deleted this channel will
|
* In the future, if the interpreter is deleted this channel will
|
* no longer be informed.
|
* no longer be informed.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
static void
|
static void
|
TcpServerCloseProc(callbackData)
|
TcpServerCloseProc(callbackData)
|
ClientData callbackData; /* The data passed in the call to
|
ClientData callbackData; /* The data passed in the call to
|
* Tcl_CreateCloseHandler. */
|
* Tcl_CreateCloseHandler. */
|
{
|
{
|
AcceptCallback *acceptCallbackPtr;
|
AcceptCallback *acceptCallbackPtr;
|
/* The actual data. */
|
/* The actual data. */
|
|
|
acceptCallbackPtr = (AcceptCallback *) callbackData;
|
acceptCallbackPtr = (AcceptCallback *) callbackData;
|
if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
|
if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) {
|
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
|
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
|
acceptCallbackPtr);
|
acceptCallbackPtr);
|
}
|
}
|
Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
|
Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC);
|
ckfree((char *) acceptCallbackPtr);
|
ckfree((char *) acceptCallbackPtr);
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_SocketCmd --
|
* Tcl_SocketCmd --
|
*
|
*
|
* This procedure is invoked to process the "socket" Tcl command.
|
* This procedure is invoked to process the "socket" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Creates a socket based channel.
|
* Creates a socket based channel.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_SocketCmd(notUsed, interp, argc, argv)
|
Tcl_SocketCmd(notUsed, interp, argc, argv)
|
ClientData notUsed; /* Not used. */
|
ClientData notUsed; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int argc; /* Number of arguments. */
|
int argc; /* Number of arguments. */
|
char **argv; /* Argument strings. */
|
char **argv; /* Argument strings. */
|
{
|
{
|
int a, server, port;
|
int a, server, port;
|
char *arg, *copyScript, *host, *script;
|
char *arg, *copyScript, *host, *script;
|
char *myaddr = NULL;
|
char *myaddr = NULL;
|
int myport = 0;
|
int myport = 0;
|
int async = 0;
|
int async = 0;
|
Tcl_Channel chan;
|
Tcl_Channel chan;
|
AcceptCallback *acceptCallbackPtr;
|
AcceptCallback *acceptCallbackPtr;
|
|
|
server = 0;
|
server = 0;
|
script = NULL;
|
script = NULL;
|
|
|
if (TclHasSockets(interp) != TCL_OK) {
|
if (TclHasSockets(interp) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
for (a = 1; a < argc; a++) {
|
for (a = 1; a < argc; a++) {
|
arg = argv[a];
|
arg = argv[a];
|
if (arg[0] == '-') {
|
if (arg[0] == '-') {
|
if (strcmp(arg, "-server") == 0) {
|
if (strcmp(arg, "-server") == 0) {
|
if (async == 1) {
|
if (async == 1) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"cannot set -async option for server sockets",
|
"cannot set -async option for server sockets",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
server = 1;
|
server = 1;
|
a++;
|
a++;
|
if (a >= argc) {
|
if (a >= argc) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"no argument given for -server option",
|
"no argument given for -server option",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
script = argv[a];
|
script = argv[a];
|
} else if (strcmp(arg, "-myaddr") == 0) {
|
} else if (strcmp(arg, "-myaddr") == 0) {
|
a++;
|
a++;
|
if (a >= argc) {
|
if (a >= argc) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"no argument given for -myaddr option",
|
"no argument given for -myaddr option",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
myaddr = argv[a];
|
myaddr = argv[a];
|
} else if (strcmp(arg, "-myport") == 0) {
|
} else if (strcmp(arg, "-myport") == 0) {
|
a++;
|
a++;
|
if (a >= argc) {
|
if (a >= argc) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"no argument given for -myport option",
|
"no argument given for -myport option",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (TclSockGetPort(interp, argv[a], "tcp", &myport)
|
if (TclSockGetPort(interp, argv[a], "tcp", &myport)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else if (strcmp(arg, "-async") == 0) {
|
} else if (strcmp(arg, "-async") == 0) {
|
if (server == 1) {
|
if (server == 1) {
|
Tcl_AppendResult(interp,
|
Tcl_AppendResult(interp,
|
"cannot set -async option for server sockets",
|
"cannot set -async option for server sockets",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
async = 1;
|
async = 1;
|
} else {
|
} else {
|
Tcl_AppendResult(interp, "bad option \"", arg,
|
Tcl_AppendResult(interp, "bad option \"", arg,
|
"\", must be -async, -myaddr, -myport, or -server",
|
"\", must be -async, -myaddr, -myport, or -server",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else {
|
} else {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
if (server) {
|
if (server) {
|
host = myaddr; /* NULL implies INADDR_ANY */
|
host = myaddr; /* NULL implies INADDR_ANY */
|
if (myport != 0) {
|
if (myport != 0) {
|
Tcl_AppendResult(interp, "Option -myport is not valid for servers",
|
Tcl_AppendResult(interp, "Option -myport is not valid for servers",
|
NULL);
|
NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else if (a < argc) {
|
} else if (a < argc) {
|
host = argv[a];
|
host = argv[a];
|
a++;
|
a++;
|
} else {
|
} else {
|
wrongNumArgs:
|
wrongNumArgs:
|
Tcl_AppendResult(interp, "wrong # args: should be either:\n",
|
Tcl_AppendResult(interp, "wrong # args: should be either:\n",
|
argv[0],
|
argv[0],
|
" ?-myaddr addr? ?-myport myport? ?-async? host port\n",
|
" ?-myaddr addr? ?-myport myport? ?-async? host port\n",
|
argv[0],
|
argv[0],
|
" -server command ?-myaddr addr? port",
|
" -server command ?-myaddr addr? port",
|
(char *) NULL);
|
(char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (a == argc-1) {
|
if (a == argc-1) {
|
if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) {
|
if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
} else {
|
} else {
|
goto wrongNumArgs;
|
goto wrongNumArgs;
|
}
|
}
|
|
|
if (server) {
|
if (server) {
|
acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
|
acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned)
|
sizeof(AcceptCallback));
|
sizeof(AcceptCallback));
|
copyScript = ckalloc((unsigned) strlen(script) + 1);
|
copyScript = ckalloc((unsigned) strlen(script) + 1);
|
strcpy(copyScript, script);
|
strcpy(copyScript, script);
|
acceptCallbackPtr->script = copyScript;
|
acceptCallbackPtr->script = copyScript;
|
acceptCallbackPtr->interp = interp;
|
acceptCallbackPtr->interp = interp;
|
chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
|
chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
|
(ClientData) acceptCallbackPtr);
|
(ClientData) acceptCallbackPtr);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
ckfree(copyScript);
|
ckfree(copyScript);
|
ckfree((char *) acceptCallbackPtr);
|
ckfree((char *) acceptCallbackPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Register with the interpreter to let us know when the
|
* Register with the interpreter to let us know when the
|
* interpreter is deleted (by having the callback set the
|
* interpreter is deleted (by having the callback set the
|
* acceptCallbackPtr->interp field to NULL). This is to
|
* acceptCallbackPtr->interp field to NULL). This is to
|
* avoid trying to eval the script in a deleted interpreter.
|
* avoid trying to eval the script in a deleted interpreter.
|
*/
|
*/
|
|
|
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
|
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
|
|
|
/*
|
/*
|
* Register a close callback. This callback will inform the
|
* Register a close callback. This callback will inform the
|
* interpreter (if it still exists) that this channel does not
|
* interpreter (if it still exists) that this channel does not
|
* need to be informed when the interpreter is deleted.
|
* need to be informed when the interpreter is deleted.
|
*/
|
*/
|
|
|
Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
|
Tcl_CreateCloseHandler(chan, TcpServerCloseProc,
|
(ClientData) acceptCallbackPtr);
|
(ClientData) acceptCallbackPtr);
|
} else {
|
} else {
|
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
|
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
|
if (chan == (Tcl_Channel) NULL) {
|
if (chan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
Tcl_RegisterChannel(interp, chan);
|
Tcl_RegisterChannel(interp, chan);
|
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
|
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*
|
*
|
* Tcl_FcopyObjCmd --
|
* Tcl_FcopyObjCmd --
|
*
|
*
|
* This procedure is invoked to process the "fcopy" Tcl command.
|
* This procedure is invoked to process the "fcopy" Tcl command.
|
* See the user documentation for details on what it does.
|
* See the user documentation for details on what it does.
|
*
|
*
|
* Results:
|
* Results:
|
* A standard Tcl result.
|
* A standard Tcl result.
|
*
|
*
|
* Side effects:
|
* Side effects:
|
* Moves data between two channels and possibly sets up a
|
* Moves data between two channels and possibly sets up a
|
* background copy handler.
|
* background copy handler.
|
*
|
*
|
*----------------------------------------------------------------------
|
*----------------------------------------------------------------------
|
*/
|
*/
|
|
|
int
|
int
|
Tcl_FcopyObjCmd(dummy, interp, objc, objv)
|
Tcl_FcopyObjCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* Not used. */
|
ClientData dummy; /* Not used. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
Tcl_Interp *interp; /* Current interpreter. */
|
int objc; /* Number of arguments. */
|
int objc; /* Number of arguments. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
Tcl_Obj *CONST objv[]; /* Argument objects. */
|
{
|
{
|
Tcl_Channel inChan, outChan;
|
Tcl_Channel inChan, outChan;
|
char *arg;
|
char *arg;
|
int mode, i;
|
int mode, i;
|
int toRead;
|
int toRead;
|
Tcl_Obj *cmdPtr;
|
Tcl_Obj *cmdPtr;
|
static char* switches[] = { "-size", "-command", NULL };
|
static char* switches[] = { "-size", "-command", NULL };
|
enum { FcopySize, FcopyCommand } index;
|
enum { FcopySize, FcopyCommand } index;
|
|
|
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
|
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
|
Tcl_WrongNumArgs(interp, 1, objv,
|
Tcl_WrongNumArgs(interp, 1, objv,
|
"input output ?-size size? ?-command callback?");
|
"input output ?-size size? ?-command callback?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Parse the channel arguments and verify that they are readable
|
* Parse the channel arguments and verify that they are readable
|
* or writable, as appropriate.
|
* or writable, as appropriate.
|
*/
|
*/
|
|
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
arg = Tcl_GetStringFromObj(objv[1], NULL);
|
inChan = Tcl_GetChannel(interp, arg, &mode);
|
inChan = Tcl_GetChannel(interp, arg, &mode);
|
if (inChan == (Tcl_Channel) NULL) {
|
if (inChan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((mode & TCL_READABLE) == 0) {
|
if ((mode & TCL_READABLE) == 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
|
Tcl_GetStringFromObj(objv[1], NULL),
|
Tcl_GetStringFromObj(objv[1], NULL),
|
"\" wasn't opened for reading", (char *) NULL);
|
"\" wasn't opened for reading", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
arg = Tcl_GetStringFromObj(objv[2], NULL);
|
arg = Tcl_GetStringFromObj(objv[2], NULL);
|
outChan = Tcl_GetChannel(interp, arg, &mode);
|
outChan = Tcl_GetChannel(interp, arg, &mode);
|
if (outChan == (Tcl_Channel) NULL) {
|
if (outChan == (Tcl_Channel) NULL) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if ((mode & TCL_WRITABLE) == 0) {
|
if ((mode & TCL_WRITABLE) == 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
|
Tcl_GetStringFromObj(objv[1], NULL),
|
Tcl_GetStringFromObj(objv[1], NULL),
|
"\" wasn't opened for writing", (char *) NULL);
|
"\" wasn't opened for writing", (char *) NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
toRead = -1;
|
toRead = -1;
|
cmdPtr = NULL;
|
cmdPtr = NULL;
|
for (i = 3; i < objc; i += 2) {
|
for (i = 3; i < objc; i += 2) {
|
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
|
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
|
(int *) &index) != TCL_OK) {
|
(int *) &index) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
switch (index) {
|
switch (index) {
|
case FcopySize:
|
case FcopySize:
|
if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
|
if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
break;
|
break;
|
case FcopyCommand:
|
case FcopyCommand:
|
cmdPtr = objv[i+1];
|
cmdPtr = objv[i+1];
|
break;
|
break;
|
}
|
}
|
}
|
}
|
|
|
return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
|
return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
|
}
|
}
|
|
|
