/*
* tclIOCmd.c --
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclIOCmd.c 1.100 96/11/06 16:41:52
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* Return at most this number of bytes in one call to Tcl_Read:
*/
/*
* Callback structure for accept callback in a TCP server.
*/
typedef struct AcceptCallback {
/*
* Static functions for this file:
*/
static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
/*
*----------------------------------------------------------------------
*
* Tcl_PutsCmd --
*
* This procedure is invoked to process the "puts" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Produces output on a channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int i; /* Counter. */
i = 1;
newline = 1;
newline = 0;
i++;
}
" ?-nonewline? ?channelId? string\"", (char *) NULL);
return TCL_ERROR;
}
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or documented.
*/
if (i == (argc-3)) {
"\": should be \"nonewline\"", (char *) NULL);
return TCL_ERROR;
}
newline = 0;
}
if (i == (argc-1)) {
channelId = "stdout";
} else {
i++;
}
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
if (result < 0) {
goto error;
}
if (newline != 0) {
if (result < 0) {
goto error;
}
}
return TCL_OK;
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FlushCmd --
*
* This procedure is called to process the Tcl "flush" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May cause output to appear on the specified channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
* level function. */
if (argc != 2) {
" channelId\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetsCmd --
*
* This procedure is called to process the Tcl "gets" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
* representation of how long
* a line was read. */
* buffer for the line just read. */
" channelId ?varName?\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
if (argc != 3) {
} else {
}
if (lineLen < 0) {
(char *) NULL);
return TCL_ERROR;
}
lineLen = -1;
}
} else {
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ReadCmd --
*
* This procedure is invoked to process the Tcl "read" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
* read in the current iteration? */
* in this iteration? */
* read by Tcl_Read. */
* in what chunk sizes to read from
* the channel. */
" channelId ?numBytes?\" or \"", argv[0],
" ?-nonewline? channelId\"", (char *) NULL);
return TCL_ERROR;
}
i = 1;
newline = 0;
newline = 1;
i++;
}
if (i == argc) {
goto argerror;
}
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
i++; /* Consumed channel name. */
/*
* Compute how many bytes to read, and see whether the final
* newline should be dropped.
*/
if (i < argc) {
return TCL_ERROR;
}
newline = 1;
} else {
"\": should be \"nonewline\"", (char *) NULL);
return TCL_ERROR;
}
}
}
if (charactersReadNow < 0) {
return TCL_ERROR;
}
/*
* If we had a short read it means that we have either EOF
* or BLOCKED on the channel, so break out.
*/
if (charactersReadNow < toReadNow) {
break; /* Out of "for" loop. */
}
}
/*
* Tcl_Read does not put a NULL at the end of the string, so we must
* do it here.
*/
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline) &&
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclUnsupported0Cmd --
*
* This procedure is invoked to process the Tcl "unsupported0" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May copy a chunk from one channel to another.
*
*----------------------------------------------------------------------
*/
int
* are defined. */
int argc; /* How many arguments? */
char **argv; /* The argument strings. */
{
int requested;
char *bufPtr;
/*
* Assume we want to copy the entire channel.
*/
return TCL_ERROR;
}
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
if (argc == 4) {
return TCL_ERROR;
}
if (requested < 0) {
}
}
for (totalRead = 0;
requested > 0;
if (toReadNow > TCL_READ_CHUNK_SIZE) {
}
if (actuallyRead < 0) {
return TCL_ERROR;
}
if (actuallyRead == 0) {
return TCL_OK;
}
if (actuallyWritten < 0) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SeekCmd --
*
* This procedure is invoked to process the Tcl "seek" command. See
* the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Moves the position of the access point on the specified channel.
* May flush queued output.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
" channelId offset ?origin?\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
return TCL_ERROR;
}
if (argc == 4) {
int c;
c = argv[3][0];
} else {
"\": should be start, current, or end", (char *) NULL);
return TCL_ERROR;
}
}
if (result == -1) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TellCmd --
*
* This procedure is invoked to process the Tcl "tell" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 2) {
" channelId\"", (char *) NULL);
return TCL_ERROR;
}
/*
* Try to find a channel with the right name and permissions in
* the IO channel table of this interpreter.
*/
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CloseCmd --
*
* This procedure is invoked to process the Tcl "close" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May discard queued input; may flush queued output.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 2) {
" channelId\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
/*
* If there is an error message and it ends with a newline, remove
* the newline. This is done for command pipeline channels where the
* error output from the subprocesses is stored in interp->result.
*
* NOTE: This is likely to not have any effect on regular error
* messages produced by drivers during the closing of a channel,
* because the Tcl convention is that such error messages do not
* have a terminating newline.
*/
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FconfigureCmd --
*
* This procedure is invoked to process the Tcl "fconfigure" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May modify the behavior of an IO channel.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int i; /* Iterate over arg-value pairs. */
* calling Tcl_GetChannelOption. */
" channelId ?optionName? ?value? ?optionName value?...\"",
(char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
if (argc == 2) {
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
if (argc == 3) {
"\": must be -blocking, -buffering, -buffersize, ",
"-eofchar, -translation, ",
"or a channel type specific option", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EofCmd --
*
* This procedure is invoked to process the Tcl "eof" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets interp->result to "0" or "1" depending on whether the
* specified channel has an EOF condition.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 2) {
" channelId\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
return TCL_OK;
}
#if 0
/*
*----------------------------------------------------------------------
*
* Tcl_ExecCmd --
*
* This procedure is invoked to process the "exec" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
#ifdef MAC_TCL
(char *)NULL);
return TCL_ERROR;
#else /* !MAC_TCL */
/*
* Check for a leading "-keepnewline" argument.
*/
keepNewline = 0;
firstWord++) {
keepNewline = 1;
firstWord++;
break;
} else {
"\": must be -keepnewline or --", (char *) NULL);
return TCL_ERROR;
}
}
" ?switches? arg ?arg ...?\"", (char *) NULL);
return TCL_ERROR;
}
/*
* See if the command is to be run in background.
*/
background = 0;
argc--;
background = 1;
}
return TCL_ERROR;
}
if (background) {
/*
* Get the list of PIDs from the pipeline into interp->result and
* detach the PIDs (instead of waiting for them).
*/
return TCL_ERROR;
}
return TCL_OK;
}
#define EXEC_BUFFER_SIZE 4096
while (1) {
if (readNow < 0) {
"error reading output from command: ",
return TCL_ERROR;
}
if (readNow < EXEC_BUFFER_SIZE) {
break; /* Out of "while (1)" loop. */
}
}
}
/*
* If the last character of interp->result is a newline, then remove
* the newline character (the newline would just confuse things).
* Special hack: must replace the old terminating null character
* as a signal to Tcl_AppendResult et al. that we've mucked with
* the string.
*/
if (!keepNewline && (length > 0) &&
}
return result;
#endif /* !MAC_TCL */
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_FblockedCmd --
*
* This procedure is invoked to process the Tcl "fblocked" command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets interp->result to "0" or "1" depending on whether the
* a preceding input operation on the channel would have blocked.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 2) {
" channelId\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_OpenCmd --
*
* This procedure is invoked to process the "open" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
char *modeString;
" fileName ?access? ?permissions?\"", (char *) NULL);
return TCL_ERROR;
}
prot = 0666;
if (argc == 2) {
modeString = "r";
} else {
if (argc == 4) {
return TCL_ERROR;
}
}
}
pipeline = 0;
pipeline = 1;
}
/*
* Open the file or create a process pipeline.
*/
if (!pipeline) {
} else {
char **cmdArgv;
return TCL_ERROR;
}
if (mode == -1) {
} else {
case O_RDONLY:
flags |= TCL_STDOUT;
break;
case O_WRONLY:
break;
case O_RDWR:
break;
default:
panic("Tcl_OpenCmd: invalid mode value");
break;
}
}
}
return TCL_ERROR;
}
return TCL_OK;
}
#if 0
/*
*----------------------------------------------------------------------
*
* TcpAcceptCallbacksDeleteProc --
*
* Assocdata cleanup routine called when an interpreter is being
* deleted to set the interp field of all the accept callback records
* registered with the interpreter to NULL. This will prevent the
* interpreter from being used in the future to eval accept scripts.
*
* Results:
* None.
*
* Side effects:
* Deallocates memory and sets the interp field of all the accept
* callback records to NULL to prevent this interpreter from being
* used subsequently to eval accept scripts.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static void
* was registered. */
{
}
}
/*
*----------------------------------------------------------------------
*
* RegisterTcpServerInterpCleanup --
*
* Registers an accept callback record to have its interp
* field set to NULL when the interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* When, in the future, the interpreter is deleted, the interp
* field of the accept callback data structure will be set to
* NULL. This will prevent attempts to eval the accept script
* in a deleted interpreter.
*
*----------------------------------------------------------------------
*/
static void
* informed of deletion. */
/* The accept callback record whose
* interp field we want set to NULL when
* the interpreter is deleted. */
{
* records to smash when the interpreter
* will be deleted. */
int new; /* Is the entry new? */
"tclTCPAcceptCallbacks",
NULL);
}
if (!new) {
panic("RegisterTcpServerCleanup: damaged accept record table");
}
}
/*
*----------------------------------------------------------------------
*
* UnregisterTcpServerInterpCleanupProc --
*
* Unregister a previously registered accept callback record. The
* interp field of this record will no longer be set to NULL in
* the future when the interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* Prevents the interp field of the accept callback record from
* being set to NULL in the future when the interpreter is deleted.
*
*----------------------------------------------------------------------
*/
static void
* record was registered. */
/* The record for which to delete the
* registration. */
{
"tclTCPAcceptCallbacks", NULL);
return;
}
return;
}
}
/*
*----------------------------------------------------------------------
*
* AcceptCallbackProc --
*
* This callback is invoked by the TCP channel driver when it
* accepts a new connection from a client on a server socket.
*
* Results:
* None.
*
* Side effects:
* Whatever the script does.
*
*----------------------------------------------------------------------
*/
static void
* was created in the call to
* Tcl_OpenTcpServer. */
* connection. */
char *address; /* Address of client that was
* accepted. */
int port; /* Port of client that was accepted. */
{
char *script;
char portBuf[10];
int result;
/*
* Check if the callback is still valid; the interpreter may have gone
* away, this is signalled by setting the interp field of the callback
* data to NULL.
*/
}
} else {
/*
* The interpreter has been deleted, so there is no useful
* way to utilize the client socket - just close it.
*/
}
}
/*
*----------------------------------------------------------------------
*
* TcpServerCloseProc --
*
* This callback is called when the TCP server channel for which it
* was registered is being closed. It informs the interpreter in
* which the accept script is evaluated (if that interpreter still
* exists) that this channel no longer needs to be informed if the
* interpreter is deleted.
*
* Results:
* None.
*
* Side effects:
* In the future, if the interpreter is deleted this channel will
* no longer be informed.
*
*----------------------------------------------------------------------
*/
static void
* Tcl_CreateCloseHandler. */
{
/* The actual data. */
}
ckfree((char *) acceptCallbackPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SocketCmd --
*
* This procedure is invoked to process the "socket" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates a socket based channel.
*
*----------------------------------------------------------------------
*/
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int myport = 0;
int async = 0;
server = 0;
return TCL_ERROR;
}
for (a = 1; a < argc; a++) {
if (arg[0] == '-') {
if (async == 1) {
"cannot set -async option for server sockets",
(char *) NULL);
return TCL_ERROR;
}
server = 1;
a++;
if (a >= argc) {
"no argument given for -server option",
(char *) NULL);
return TCL_ERROR;
}
a++;
if (a >= argc) {
"no argument given for -myaddr option",
(char *) NULL);
return TCL_ERROR;
}
a++;
if (a >= argc) {
"no argument given for -myport option",
(char *) NULL);
return TCL_ERROR;
}
!= TCL_OK) {
return TCL_ERROR;
}
if (server == 1) {
"cannot set -async option for server sockets",
(char *) NULL);
return TCL_ERROR;
}
async = 1;
} else {
"\", must be -async, -myaddr, -myport, or -server",
(char *) NULL);
return TCL_ERROR;
}
} else {
break;
}
}
if (server) {
if (myport != 0) {
NULL);
return TCL_ERROR;
}
} else if (a < argc) {
a++;
} else {
argv[0],
" ?-myaddr addr? ?-myport myport? ?-async? host port\n",
argv[0],
" -server command ?-myaddr addr? port",
(char *) NULL);
return TCL_ERROR;
}
if (a == argc-1) {
return TCL_ERROR;
}
} else {
goto wrongNumArgs;
}
if (server) {
sizeof(AcceptCallback));
ckfree((char *) acceptCallbackPtr);
return TCL_ERROR;
}
/*
* Register with the interpreter to let us know when the
* interpreter is deleted (by having the callback set the
* acceptCallbackPtr->interp field to NULL). This is to
* avoid trying to eval the script in a deleted interpreter.
*/
/*
* Register a close callback. This callback will inform the
* interpreter (if it still exists) that this channel does not
* need to be informed when the interpreter is deleted.
*/
} else {
return TCL_ERROR;
}
}
return TCL_OK;
}
#endif