diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIOCmd.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIOCmd.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,1554 @@ +/* + * tclIOCmd.c -- + * + * Contains the definitions of most of the Tcl commands relating to IO. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclIOCmd.c,v 1.15.2.2 2004/07/16 22:38:37 andreas_kupries Exp $ + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Callback structure for accept callback in a TCP server. + */ + +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ +} AcceptCallback; + +/* + * Static functions for this file: + */ + +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr)); +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutsObjCmd -- + * + * 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 +Tcl_PutsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to puts on. */ + Tcl_Obj *string; /* String to write. */ + int newline; /* Add a newline at end? */ + char *channelId; /* Name of channel for puts. */ + int result; /* Result of puts operation. */ + int mode; /* Mode in which channel is opened. */ + + switch (objc) { + case 2: /* puts $x */ + string = objv[1]; + newline = 1; + channelId = "stdout"; + break; + + case 3: /* puts -nonewline $x or puts $chan $x */ + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + newline = 0; + channelId = "stdout"; + } else { + newline = 1; + channelId = Tcl_GetString(objv[1]); + } + string = objv[2]; + break; + + case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */ + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + channelId = Tcl_GetString(objv[2]); + string = objv[3]; + } else { + /* + * The code below provides backwards compatibility with an + * old form of the command that is no longer recommended + * or documented. + */ + + char *arg; + int length; + + arg = Tcl_GetStringFromObj(objv[3], &length); + if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": should be \"nonewline\"", + (char *) NULL); + return TCL_ERROR; + } + channelId = Tcl_GetString(objv[1]); + string = objv[2]; + } + newline = 0; + break; + + default: /* puts or puts some bad number of arguments... */ + Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); + return TCL_ERROR; + } + + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_WriteObj(chan, string); + if (result < 0) { + goto error; + } + if (newline != 0) { + result = Tcl_WriteChars(chan, "\n", 1); + if (result < 0) { + goto error; + } + } + return TCL_OK; + + error: + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushObjCmd -- + * + * 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 +Tcl_FlushObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to flush on. */ + char *channelId; + int mode; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + channelId = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + if (Tcl_Flush(chan) != TCL_OK) { + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsObjCmd -- + * + * 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 +Tcl_GetsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int lineLen; /* Length of line just read. */ + int mode; /* Mode in which channel is opened. */ + char *name; + Tcl_Obj *resultPtr, *linePtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); + return TCL_ERROR; + } + name = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, name, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + linePtr = Tcl_NewObj(); + + lineLen = Tcl_GetsObj(chan, linePtr); + if (lineLen < 0) { + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + Tcl_DecrRefCount(linePtr); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + lineLen = -1; + } + if (objc == 3) { + if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(linePtr); + return TCL_ERROR; + } + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetIntObj(resultPtr, lineLen); + return TCL_OK; + } else { + Tcl_SetObjResult(interp, linePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadObjCmd -- + * + * 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 +Tcl_ReadObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int charactersRead; /* How many characters were read? */ + int mode; /* Mode in which channel is opened. */ + char *name; + Tcl_Obj *resultPtr; + + if ((objc != 2) && (objc != 3)) { + argerror: + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); + Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]), + " ?-nonewline? channelId\"", (char *) NULL); + return TCL_ERROR; + } + + i = 1; + newline = 0; + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + newline = 1; + i++; + } + + if (i == objc) { + goto argerror; + } + + name = Tcl_GetString(objv[i]); + chan = Tcl_GetChannel(interp, name, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", name, + "\" 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. + */ + + toRead = -1; + if (i < objc) { + char *arg; + + arg = Tcl_GetString(objv[i]); + if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ + if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(arg, "nonewline") == 0) { + newline = 1; + } else { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + + resultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(resultPtr); + charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); + if (charactersRead < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + + /* + * If requested, remove the last newline in the channel if at EOF. + */ + + if ((charactersRead > 0) && (newline != 0)) { + char *result; + int length; + + result = Tcl_GetStringFromObj(resultPtr, &length); + if (result[length - 1] == '\n') { + Tcl_SetObjLength(resultPtr, length - 1); + } + } + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekObjCmd -- + * + * 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 +Tcl_SeekObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + Tcl_WideInt offset; /* Where to seek? */ + int mode; /* How to seek? */ + Tcl_WideInt result; /* Of calling Tcl_Seek. */ + char *chanName; + int optionIndex; + static CONST char *originOptions[] = { + "start", "current", "end", (char *) NULL + }; + static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); + return TCL_ERROR; + } + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (objc == 4) { + if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + mode = modeArray[optionIndex]; + } + + result = Tcl_Seek(chan, offset, mode); + if (result == Tcl_LongAsWide(-1)) { + Tcl_AppendResult(interp, "error during seek on \"", + chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellObjCmd -- + * + * 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 +Tcl_TellObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + char *chanName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + /* + * Try to find a channel with the right name and permissions in + * the IO channel table of this interpreter. + */ + + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseObjCmd -- + * + * 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 +Tcl_CloseObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; /* The channel to close. */ + char *arg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { + /* + * 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's 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. + */ + + Tcl_Obj *resultPtr; + char *string; + int len; + + resultPtr = Tcl_GetObjResult(interp); + string = Tcl_GetStringFromObj(resultPtr, &len); + if ((len > 0) && (string[len - 1] == '\n')) { + Tcl_SetObjLength(resultPtr, len - 1); + } + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FconfigureObjCmd -- + * + * 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 +Tcl_FconfigureObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *chanName, *optionName, *valueName; + Tcl_Channel chan; /* The channel to set a mode on. */ + int i; /* Iterate over arg-value pairs. */ + Tcl_DString ds; /* DString to hold result of + * calling Tcl_GetChannelOption. */ + + if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { + Tcl_WrongNumArgs(interp, 1, objv, + "channelId ?optionName? ?value? ?optionName value?..."); + return TCL_ERROR; + } + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (objc == 2) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } + if (objc == 3) { + Tcl_DStringInit(&ds); + optionName = Tcl_GetString(objv[2]); + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } + for (i = 3; i < objc; i += 2) { + optionName = Tcl_GetString(objv[i-1]); + valueName = Tcl_GetString(objv[i]); + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_EofObjCmd -- + * + * 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's result to boolean true or false depending on whether + * the specified channel has an EOF condition. + * + *--------------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EofObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; + int dummy; + char *arg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, &dummy); + if (chan == NULL) { + return TCL_ERROR; + } + + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExecObjCmd -- + * + * 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 +Tcl_ExecObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ +#ifdef MAC_TCL + + Tcl_AppendResult(interp, "exec not implemented under Mac OS", + (char *)NULL); + return TCL_ERROR; + +#else /* !MAC_TCL */ + + /* + * This procedure generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *resultPtr; + CONST char **argv; + char *string; + Tcl_Channel chan; + CONST char *argStorage[NUM_ARGS]; + int argc, background, i, index, keepNewline, result, skip, length; + static CONST char *options[] = { + "-keepnewline", "--", NULL + }; + enum options { + EXEC_KEEPNEWLINE, EXEC_LAST + }; + + /* + * Check for a leading "-keepnewline" argument. + */ + + keepNewline = 0; + for (skip = 1; skip < objc; skip++) { + string = Tcl_GetString(objv[skip]); + if (string[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == EXEC_KEEPNEWLINE) { + keepNewline = 1; + } else { + skip++; + break; + } + } + if (objc <= skip) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); + return TCL_ERROR; + } + + /* + * See if the command is to be run in background. + */ + + background = 0; + string = Tcl_GetString(objv[objc - 1]); + if ((string[0] == '&') && (string[1] == '\0')) { + objc--; + background = 1; + } + + /* + * Create the string argument array "argv". Make sure argv is large + * enough to hold the argc arguments plus 1 extra for the zero + * end-of-argv word. + */ + + argv = argStorage; + argc = objc - skip; + if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) { + argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); + } + + /* + * Copy the string conversions of each (post option) object into the + * argument vector. + */ + + for (i = 0; i < argc; i++) { + argv[i] = Tcl_GetString(objv[i + skip]); + } + argv[argc] = NULL; + chan = Tcl_OpenCommandChannel(interp, argc, argv, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + /* + * Free the argv array if malloc'ed storage was used. + */ + + if (argv != argStorage) { + ckfree((char *)argv); + } + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (background) { + /* + * Store the list of PIDs from the pipeline in interp's result and + * detach the PIDs (instead of waiting for them). + */ + + TclGetAndDetachPids(interp, chan); + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + + resultPtr = Tcl_NewObj(); + if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + } + /* + * If the process produced anything on stderr, it will have been + * returned in the interpreter result. It needs to be appended to + * the result string. + */ + + result = Tcl_Close(interp, chan); + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + Tcl_AppendToObj(resultPtr, string, length); + + /* + * If the last character of the result is a newline, then remove + * the newline character. + */ + + if (keepNewline == 0) { + string = Tcl_GetStringFromObj(resultPtr, &length); + if ((length > 0) && (string[length - 1] == '\n')) { + Tcl_SetObjLength(resultPtr, length - 1); + } + } + Tcl_SetObjResult(interp, resultPtr); + + return result; +#endif /* !MAC_TCL */ +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FblockedObjCmd -- + * + * 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's result to boolean true or false depending on whether + * the preceeding input operation on the channel would have blocked. + * + *--------------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FblockedObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel chan; + int mode; + char *arg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + return TCL_ERROR; + } + + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + arg, "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenObjCmd -- + * + * 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 +Tcl_OpenObjCmd(notUsed, interp, objc, objv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int pipeline, prot; + char *modeString, *what; + Tcl_Channel chan; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); + return TCL_ERROR; + } + prot = 0666; + if (objc == 2) { + modeString = "r"; + } else { + modeString = Tcl_GetString(objv[2]); + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + pipeline = 0; + what = Tcl_GetString(objv[1]); + if (what[0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); + } else { +#ifdef MAC_TCL + Tcl_AppendResult(interp, + "command pipelines not supported on Macintosh OS", + (char *)NULL); + return TCL_ERROR; +#else + int mode, seekFlag, cmdObjc; + CONST char **cmdArgv; + + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + chan = NULL; + } else { + int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + panic("Tcl_OpenCmd: invalid mode value"); + break; + } + chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); + } + ckfree((char *) cmdArgv); +#endif + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 +TcpAcceptCallbacksDeleteProc(clientData, interp) + ClientData clientData; /* Data which was passed when the assocdata + * was registered. */ + Tcl_Interp *interp; /* Interpreter being deleted - not used. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + AcceptCallback *acceptCallbackPtr; + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * 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 +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter for which we want to be + * informed of deletion. */ + AcceptCallback *acceptCallbackPtr; + /* The accept callback record whose + * interp field we want set to NULL when + * the interpreter is deleted. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback + * records to smash when the interpreter + * will be deleted. */ + Tcl_HashEntry *hPtr; /* Entry for this record. */ + int new; /* Is the entry new? */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); + if (!new) { + panic("RegisterTcpServerCleanup: damaged accept record table"); + } + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * 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 +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter in which the accept callback + * record was registered. */ + AcceptCallback *acceptCallbackPtr; + /* The record for which to delete the + * registration. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * 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 +AcceptCallbackProc(callbackData, chan, address, port) + ClientData callbackData; /* The data stored when the callback + * was created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan; /* Channel for the newly accepted + * connection. */ + char *address; /* Address of client that was + * accepted. */ + int port; /* Port of client that was accepted. */ +{ + AcceptCallback *acceptCallbackPtr; + Tcl_Interp *interp; + char *script; + char portBuf[TCL_INTEGER_SPACE]; + int result; + + acceptCallbackPtr = (AcceptCallback *) callbackData; + + /* + * Check if the callback is still valid; the interpreter may have gone + * away, this is signalled by setting the interp field of the callback + * data to NULL. + */ + + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + + TclFormatInt(portBuf, port); + Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from + * being deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + Tcl_UnregisterChannel(interp, chan); + } + + /* + * Decrement the artificially bumped refcount. After this it is + * not safe anymore to use "chan", because it may now be deleted. + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); + } else { + + /* + * The interpreter has been deleted, so there is no useful + * way to utilize the client socket - just close it. + */ + + Tcl_Close((Tcl_Interp *) NULL, chan); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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 +TcpServerCloseProc(callbackData) + ClientData callbackData; /* The data passed in the call to + * Tcl_CreateCloseHandler. */ +{ + AcceptCallback *acceptCallbackPtr; + /* The actual data. */ + + acceptCallbackPtr = (AcceptCallback *) callbackData; + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); + } + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SocketObjCmd -- + * + * 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 +Tcl_SocketObjCmd(notUsed, interp, objc, objv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static CONST char *socketOptions[] = { + "-async", "-myaddr", "-myport","-server", (char *) NULL + }; + enum socketOptions { + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + }; + int optionIndex, a, server, port; + char *arg, *copyScript, *host, *script; + char *myaddr = NULL; + int myport = 0; + int async = 0; + Tcl_Channel chan; + AcceptCallback *acceptCallbackPtr; + + server = 0; + script = NULL; + + if (TclpHasSockets(interp) != TCL_OK) { + return TCL_ERROR; + } + + for (a = 1; a < objc; a++) { + arg = Tcl_GetString(objv[a]); + if (arg[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, + "option", TCL_EXACT, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum socketOptions) optionIndex) { + case SKT_ASYNC: { + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + break; + } + case SKT_MYADDR: { + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", + (char *) NULL); + return TCL_ERROR; + } + myaddr = Tcl_GetString(objv[a]); + break; + } + case SKT_MYPORT: { + char *myPortName; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", + (char *) NULL); + return TCL_ERROR; + } + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) + != TCL_OK) { + return TCL_ERROR; + } + break; + } + case SKT_SERVER: { + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = Tcl_GetString(objv[a]); + break; + } + default: { + panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); + } + } + } + if (server) { + host = myaddr; /* NULL implies INADDR_ANY */ + if (myport != 0) { + Tcl_AppendResult(interp, "Option -myport is not valid for servers", + NULL); + return TCL_ERROR; + } + } else if (a < objc) { + host = Tcl_GetString(objv[a]); + a++; + } else { +wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be either:\n", + Tcl_GetString(objv[0]), + " ?-myaddr addr? ?-myport myport? ?-async? host port\n", + Tcl_GetString(objv[0]), + " -server command ?-myaddr addr? port", + (char *) NULL); + return TCL_ERROR; + } + + if (a == objc-1) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), + "tcp", &port) != TCL_OK) { + return TCL_ERROR; + } + } else { + goto wrongNumArgs; + } + + if (server) { + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the + * interpreter is deleted (by having the callback set the + * acceptCallbackPtr->interp field to NULL). This is to + * avoid trying to eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not + * need to be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); + } else { + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FcopyObjCmd -- + * + * This procedure is invoked to process the "fcopy" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves data between two channels and possibly sets up a + * background copy handler. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FcopyObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Channel inChan, outChan; + char *arg; + int mode, i; + int toRead, index; + Tcl_Obj *cmdPtr; + static CONST char* switches[] = { "-size", "-command", NULL }; + enum { FcopySize, FcopyCommand }; + + if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { + Tcl_WrongNumArgs(interp, 1, objv, + "input output ?-size size? ?-command callback?"); + return TCL_ERROR; + } + + /* + * Parse the channel arguments and verify that they are readable + * or writable, as appropriate. + */ + + arg = Tcl_GetString(objv[1]); + inChan = Tcl_GetChannel(interp, arg, &mode); + if (inChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + arg = Tcl_GetString(objv[2]); + outChan = Tcl_GetChannel(interp, arg, &mode); + if (outChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + arg, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + toRead = -1; + cmdPtr = NULL; + for (i = 3; i < objc; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, + (int *) &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case FcopySize: + if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + return TCL_ERROR; + } + break; + case FcopyCommand: + cmdPtr = objv[i+1]; + break; + } + } + + return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); +}