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