diff options
Diffstat (limited to 'generic/tclIOCmd.c')
| -rw-r--r-- | generic/tclIOCmd.c | 1060 |
1 files changed, 727 insertions, 333 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 276ccf5..94a74cd 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -7,8 +7,6 @@ * * 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.33 2005/11/04 22:38:38 msofer Exp $ */ #include "tclInt.h" @@ -18,16 +16,34 @@ */ typedef struct AcceptCallback { - char *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ + Tcl_Obj *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; /* + * Thread local storage used to maintain a per-thread stdout channel obj. + * It must be per-thread because of std channel limitations. + */ + +typedef struct ThreadSpecificData { + int initialized; /* Set to 1 when the module is initialized. */ + Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* * Static functions for this file: */ -static void AcceptCallbackProc(ClientData callbackData, - Tcl_Channel chan, char *address, int port); +static void FinalizeIOCmdTSD(ClientData clientData); +static Tcl_TcpAcceptProc AcceptCallbackProc; +static int ChanPendingObjCmd(ClientData unused, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ChanTruncateObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static void RegisterTcpServerInterpCleanup(Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); static void TcpAcceptCallbacksDeleteProc(ClientData clientData, @@ -40,6 +56,35 @@ static void UnregisterTcpServerInterpCleanupProc( /* *---------------------------------------------------------------------- * + * FinalizeIOCmdTSD -- + * + * Release the storage associated with the per-thread cache. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FinalizeIOCmdTSD( + ClientData clientData) /* Not used. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->stdoutObjPtr != NULL) { + Tcl_DecrRefCount(tsdPtr->stdoutObjPtr); + tsdPtr->stdoutObjPtr = NULL; + } + tsdPtr->initialized = 0; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_PutsObjCmd -- * * This function is invoked to process the "puts" Tcl command. See the @@ -60,76 +105,82 @@ Tcl_PutsObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to puts on. */ Tcl_Obj *string; /* String to write. */ + Tcl_Obj *chanObjPtr = NULL; /* channel object. */ 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. */ + ThreadSpecificData *tsdPtr; switch (objc) { - case 2: /* [puts $x] */ + 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) { + case 3: /* [puts -nonewline $x] or [puts $chan $x] */ + if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 0; - channelId = "stdout"; } else { newline = 1; - channelId = Tcl_GetString(objv[1]); + chanObjPtr = 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]); + case 4: /* [puts -nonewline $chan $x] or + * [puts $chan $x nonewline] */ + newline = 0; + if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { + chanObjPtr = objv[2]; string = objv[3]; - } else { + break; +#if TCL_MAJOR_VERSION < 9 + } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or - * documented. + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. */ - 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\"", NULL); - return TCL_ERROR; - } - channelId = Tcl_GetString(objv[1]); + chanObjPtr = objv[1]; string = objv[2]; + break; +#endif } - newline = 0; - break; - - default: - /* [puts] or [puts some bad number of arguments...] */ + /* Fall through */ + 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) { + if (chanObjPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!tsdPtr->initialized) { + tsdPtr->initialized = 1; + TclNewLiteralStringObj(tsdPtr->stdoutObjPtr, "stdout"); + Tcl_IncrRefCount(tsdPtr->stdoutObjPtr); + Tcl_CreateThreadExitHandler(FinalizeIOCmdTSD, NULL); + } + chanObjPtr = tsdPtr->stdoutObjPtr; + } + if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } + TclChannelPreserve(chan); result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; @@ -140,6 +191,7 @@ Tcl_PutsObjCmd( goto error; } } + TclChannelRelease(chan); return TCL_OK; /* @@ -151,9 +203,10 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + TclChannelRelease(chan); return TCL_ERROR; } @@ -180,27 +233,28 @@ Tcl_FlushObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Obj *chanObjPtr; 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) { + chanObjPtr = objv[1]; + if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(chanObjPtr))); return TCL_ERROR; } + TclChannelPreserve(chan); if (Tcl_Flush(chan) != TCL_OK) { /* * TIP #219. @@ -210,11 +264,14 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error flushing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + TclChannelRelease(chan); return TCL_ERROR; } + TclChannelRelease(chan); return TCL_OK; } @@ -241,31 +298,31 @@ Tcl_GetsObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ - char *name; - Tcl_Obj *linePtr; + Tcl_Obj *linePtr, *chanObjPtr; + int code = TCL_OK; 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) { + chanObjPtr = objv[1]; + if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } + TclChannelPreserve(chan); linePtr = Tcl_NewObj(); - lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { @@ -277,26 +334,30 @@ Tcl_GetsObjCmd( * and put them into the regular interpreter result. Fall back to * the regular message if nothing was found in the bypass. */ + if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } - return TCL_ERROR; + code = TCL_ERROR; + goto done; } lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } - return TCL_OK; + done: + TclChannelRelease(chan); + return code; } /* @@ -322,15 +383,14 @@ Tcl_ReadObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ 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; + Tcl_Obj *resultPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; @@ -346,13 +406,12 @@ Tcl_ReadObjCmd( iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); - iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } i = 1; newline = 0; - if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } @@ -361,43 +420,51 @@ Tcl_ReadObjCmd( goto argerror; } - name = Tcl_GetString(objv[i]); - chan = Tcl_GetChannel(interp, name, &mode); - if (chan == (Tcl_Channel) NULL) { + chanObjPtr = objv[i]; + if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(chanObjPtr))); return TCL_ERROR; } - i++; /* Consumed channel name. */ + i++; /* Consumed channel name. */ /* - * Compute how many bytes to read, and see whether the final newline - * should be dropped. + * Compute how many bytes to read. */ toRead = -1; if (i < objc) { - char *arg; + if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) + || (toRead < 0)) { +#if TCL_MAJOR_VERSION < 9 + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ - arg = Tcl_GetString(objv[i]); - if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ - if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { +#endif + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected non-negative integer but got \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; +#if TCL_MAJOR_VERSION < 9 } - } else if (strcmp(arg, "nonewline") == 0) { newline = 1; - } else { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", NULL); - return TCL_ERROR; +#endif } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); + TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* @@ -408,11 +475,12 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), NULL); - Tcl_DecrRefCount(resultPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + TclChannelRelease(chan); + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -421,15 +489,16 @@ Tcl_ReadObjCmd( */ if ((charactersRead > 0) && (newline != 0)) { - char *result; + const char *result; int length; - result = Tcl_GetStringFromObj(resultPtr, &length); + result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } } Tcl_SetObjResult(interp, resultPtr); + TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); return TCL_OK; } @@ -458,26 +527,23 @@ Tcl_SeekObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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[] = { + static const char *const originOptions[] = { "start", "current", "end", NULL }; - static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; + static const 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) { + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { @@ -492,6 +558,7 @@ Tcl_SeekObjCmd( mode = modeArray[optionIndex]; } + TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* @@ -500,12 +567,16 @@ Tcl_SeekObjCmd( * put them into the regular interpreter result. Fall back to the * regular message if nothing was found in the bypass. */ + if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error during seek on \"", chanName, - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during seek on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); } + TclChannelRelease(chan); return TCL_ERROR; } + TclChannelRelease(chan); return TCL_OK; } @@ -532,11 +603,11 @@ Tcl_TellObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ - char *chanName; Tcl_WideInt newLoc; + int code; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -548,12 +619,11 @@ Tcl_TellObjCmd( * channel table of this interpreter. */ - chanName = Tcl_GetString(objv[1]); - chan = Tcl_GetChannel(interp, chanName, NULL); - if (chan == (Tcl_Channel) NULL) { + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } + TclChannelPreserve(chan); newLoc = Tcl_Tell(chan); /* @@ -562,7 +632,10 @@ Tcl_TellObjCmd( * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass(interp, chan)) { + + code = TclChanCaughtErrorBypass(interp, chan); + TclChannelRelease(chan); + if (code) { return TCL_ERROR; } @@ -593,22 +666,62 @@ Tcl_CloseObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to close. */ - char *arg; + static const char *const dirOptions[] = { + "read", "write", NULL + }; + static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId"); + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); return TCL_ERROR; } - arg = Tcl_GetString(objv[1]); - chan = Tcl_GetChannel(interp, arg, NULL); - if (chan == (Tcl_Channel) NULL) { + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } + if (objc == 3) { + int index, dir; + + /* + * Get direction requested to close, and check syntax. + */ + + if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + dir = dirArray[index]; + + /* + * Check direction against channel mode. It is an error if we try to + * close a direction not supported by the channel (already closed, or + * never opened for that direction). + */ + + if (!(dir & Tcl_GetChannelMode(chan))) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened" + " or already closed", dirOptions[index])); + return TCL_ERROR; + } + + /* + * Special handling is needed if and only if the channel mode supports + * more than the direction to close. Because if the close the last + * direction suppported we can and will go through the regular + * process. + */ + + if ((Tcl_GetChannelMode(chan) & + (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) { + return Tcl_CloseEx(interp, chan, dir); + } + } + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { /* * If there is an error message and it ends with a newline, remove the @@ -621,16 +734,15 @@ Tcl_CloseObjCmd( * a terminating newline. */ - Tcl_Obj *resultPtr; - char *string; + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + const char *string; int len; - resultPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } - string = Tcl_GetStringFromObj(resultPtr, &len); + string = TclGetStringFromObj(resultPtr, &len); if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); } @@ -663,21 +775,18 @@ Tcl_FconfigureObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *chanName, *optionName, *valueName; + const char *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { - Tcl_WrongNumArgs(interp, 1, objv, - "channelId ?optionName? ?value? ?optionName value?..."); + Tcl_WrongNumArgs(interp, 1, objv, "channelId ?-option value ...?"); return TCL_ERROR; } - chanName = Tcl_GetString(objv[1]); - chan = Tcl_GetChannel(interp, chanName, NULL); - if (chan == (Tcl_Channel) NULL) { + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } @@ -697,7 +806,7 @@ Tcl_FconfigureObjCmd( * Tcl_GetChannelOption. */ Tcl_DStringInit(&ds); - optionName = Tcl_GetString(objv[2]); + optionName = TclGetString(objv[2]); if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; @@ -707,8 +816,8 @@ Tcl_FconfigureObjCmd( } for (i = 3; i < objc; i += 2) { - optionName = Tcl_GetString(objv[i-1]); - valueName = Tcl_GetString(objv[i]); + optionName = TclGetString(objv[i-1]); + valueName = TclGetString(objv[i]); if (Tcl_SetChannelOption(interp, chan, optionName, valueName) != TCL_OK) { return TCL_ERROR; @@ -742,20 +851,16 @@ Tcl_EofObjCmd( ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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) { + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } @@ -786,51 +891,48 @@ Tcl_ExecObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - /* - * This function 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; + const char **argv; /* An array for the string arguments. Stored + * on the _Tcl_ stack. */ + const 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 + int ignoreStderr; + static const char *const options[] = { + "-ignorestderr", "-keepnewline", "--", NULL }; enum options { - EXEC_KEEPNEWLINE, EXEC_LAST + EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST }; /* - * Check for a leading "-keepnewline" argument. + * Check for any leading option arguments. */ keepNewline = 0; + ignoreStderr = 0; for (skip = 1; skip < objc; skip++) { - string = Tcl_GetString(objv[skip]); + string = TclGetString(objv[skip]); if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } if (index == EXEC_KEEPNEWLINE) { keepNewline = 1; + } else if (index == EXEC_IGNORESTDERR) { + ignoreStderr = 1; } else { skip++; break; } } if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); return TCL_ERROR; } @@ -839,7 +941,7 @@ Tcl_ExecObjCmd( */ background = 0; - string = Tcl_GetString(objv[objc - 1]); + string = TclGetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; background = 1; @@ -850,11 +952,8 @@ Tcl_ExecObjCmd( * 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 *)); - } + argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the @@ -862,21 +961,19 @@ Tcl_ExecObjCmd( */ for (i = 0; i < argc; i++) { - argv[i] = Tcl_GetString(objv[i + skip]); + argv[i] = TclGetString(objv[i + skip]); } argv[argc] = NULL; - chan = Tcl_OpenCommandChannel(interp, argc, argv, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); + chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : + ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)); /* - * Free the argv array if malloc'ed storage was used. + * Free the argv array. */ - if (argv != argStorage) { - ckfree((char *)argv); - } + TclStackFree(interp, (void *) argv); - if (chan == (Tcl_Channel) NULL) { + if (chan == NULL) { return TCL_ERROR; } @@ -903,10 +1000,10 @@ Tcl_ExecObjCmd( * the regular message if nothing was found in the bypass. */ - if (!TclChanCaughtErrorBypass (interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), NULL); + if (!TclChanCaughtErrorBypass(interp, chan)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading output from command: %s", + Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -928,7 +1025,7 @@ Tcl_ExecObjCmd( */ if (keepNewline == 0) { - string = Tcl_GetStringFromObj(resultPtr, &length); + string = TclGetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { Tcl_SetObjLength(resultPtr, length - 1); } @@ -962,25 +1059,23 @@ Tcl_FblockedObjCmd( ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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) { + if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } @@ -1011,10 +1106,10 @@ Tcl_OpenObjCmd( ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int pipeline, prot; - char *modeString, *what; + const char *modeString, *what; Tcl_Channel chan; if ((objc < 2) || (objc > 4)) { @@ -1025,16 +1120,36 @@ Tcl_OpenObjCmd( if (objc == 2) { modeString = "r"; } else { - modeString = Tcl_GetString(objv[2]); + modeString = TclGetString(objv[2]); if (objc == 4) { - if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) { + const char *permString = TclGetString(objv[3]); + int code = TCL_ERROR; + int scanned = TclParseAllWhiteSpace(permString, -1); + + /* + * Support legacy octal numbers. + */ + + if ((permString[scanned] == '0') + && (permString[scanned+1] >= '0') + && (permString[scanned+1] <= '7')) { + Tcl_Obj *permObj; + + TclNewLiteralStringObj(permObj, "0o"); + Tcl_AppendToObj(permObj, permString+scanned+1, -1); + code = TclGetIntFromObj(NULL, permObj, &prot); + Tcl_DecrRefCount(permObj); + } + + if ((code == TCL_ERROR) + && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } pipeline = 0; - what = Tcl_GetString(objv[1]); + what = TclGetString(objv[1]); if (what[0] == '|') { pipeline = 1; } @@ -1047,7 +1162,7 @@ Tcl_OpenObjCmd( chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { int mode, seekFlag, cmdObjc, binary; - CONST char **cmdArgv; + const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; @@ -1074,17 +1189,17 @@ Tcl_OpenObjCmd( break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); - if (binary) { + if (binary && chan) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree((char *) cmdArgv); + ckfree(cmdArgv); } - if (chan == (Tcl_Channel) NULL) { + if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1116,19 +1231,18 @@ TcpAcceptCallbacksDeleteProc( * was registered. */ Tcl_Interp *interp) /* Interpreter being deleted - not used. */ { - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hTblPtr = clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; - AcceptCallback *acceptCallbackPtr; - hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); + ckfree(hTblPtr); } /* @@ -1163,23 +1277,22 @@ RegisterTcpServerInterpCleanup( * smash when the interpreter will be * deleted. */ Tcl_HashEntry *hPtr; /* Entry for this record. */ - int new; /* Is the entry new? */ + int isNew; /* Is the entry new? */ - hTblPtr = (Tcl_HashTable *) - Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + hTblPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", - TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, hTblPtr); } - hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); - if (!new) { + hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew); + if (!isNew) { Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } - Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); + Tcl_SetHashValue(hPtr, acceptCallbackPtr); } /* @@ -1212,8 +1325,7 @@ UnregisterTcpServerInterpCleanupProc( Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); + hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { return; } @@ -1251,13 +1363,7 @@ AcceptCallbackProc( 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; + AcceptCallback *acceptCallbackPtr = callbackData; /* * Check if the callback is still valid; the interpreter may have gone @@ -1266,14 +1372,22 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { - - script = acceptCallbackPtr->script; - interp = acceptCallbackPtr->interp; - - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) interp); - - TclFormatInt(portBuf, port); + Tcl_Interp *interp = acceptCallbackPtr->interp; + Tcl_Obj *script, *objv[2]; + int result = TCL_OK; + + objv[0] = acceptCallbackPtr->script; + objv[1] = Tcl_NewListObj(3, NULL); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( + Tcl_GetChannelName(chan), -1)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); + + script = Tcl_ConcatObj(2, objv); + Tcl_IncrRefCount(script); + Tcl_DecrRefCount(objv[1]); + + Tcl_Preserve(interp); Tcl_RegisterChannel(interp, chan); /* @@ -1283,10 +1397,11 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, NULL); + result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(script); + if (result != TCL_OK) { - Tcl_BackgroundError(interp); + Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } @@ -1297,13 +1412,11 @@ AcceptCallbackProc( Tcl_UnregisterChannel(NULL, chan); - Tcl_Release((ClientData) interp); - Tcl_Release((ClientData) script); - + Tcl_Release(interp); } else { /* - * The interpreter has been deleted, so there is no useful way to - * utilize the client socket - just close it. + * The interpreter has been deleted, so there is no useful way to use + * the client socket - just close it. */ Tcl_Close(NULL, chan); @@ -1336,16 +1449,15 @@ TcpServerCloseProc( ClientData callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { - AcceptCallback *acceptCallbackPtr; + AcceptCallback *acceptCallbackPtr = callbackData; /* The actual data. */ - acceptCallbackPtr = (AcceptCallback *) callbackData; if (acceptCallbackPtr->interp != NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); - ckfree((char *) acceptCallbackPtr); + Tcl_DecrRefCount(acceptCallbackPtr->script); + ckfree(acceptCallbackPtr); } /* @@ -1370,31 +1482,30 @@ Tcl_SocketObjCmd( ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - static CONST char *socketOptions[] = { - "-async", "-myaddr", "-myport","-server", NULL + static const char *const socketOptions[] = { + "-async", "-backlog", "-myaddr", "-myport", "-reuseaddr", + "-reuseport", "-server", NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, + SKT_REUSEPORT, SKT_SERVER }; - int optionIndex, a, server, port; - char *arg, *copyScript, *host, *script; - char *myaddr = NULL; - int myport = 0; - int async = 0; + int optionIndex, a, server = 0, async = 0, reusep = -1, + reusea = -1, backlog = -1; + unsigned int flags = 0; + const char *host, *port, *myaddr = NULL, *myport = NULL; + Tcl_Obj *script = NULL; 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]); + const char *arg = Tcl_GetString(objv[a]); + if (arg[0] != '-') { break; } @@ -1405,8 +1516,8 @@ Tcl_SocketObjCmd( switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } async = 1; @@ -1414,41 +1525,69 @@ Tcl_SocketObjCmd( case SKT_MYADDR: a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myaddr option", -1)); return TCL_ERROR; } - myaddr = Tcl_GetString(objv[a]); + myaddr = TclGetString(objv[a]); break; case SKT_MYPORT: { - char *myPortName; - a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", NULL); - return TCL_ERROR; - } - myPortName = Tcl_GetString(objv[a]); - if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myport option", -1)); return TCL_ERROR; } + myport = TclGetString(objv[a]); break; } case SKT_SERVER: if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot set -async option for server sockets", -1)); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -server option", -1)); + return TCL_ERROR; + } + script = objv[a]; + break; + case SKT_REUSEADDR: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseaddr option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { + return TCL_ERROR; + } + break; + case SKT_REUSEPORT: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseport option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { + return TCL_ERROR; + } + break; + case SKT_BACKLOG: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -backlog option", -1)); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[a], &backlog) != TCL_OK) { return TCL_ERROR; } - script = Tcl_GetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1457,12 +1596,12 @@ Tcl_SocketObjCmd( if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "option -myport is not valid for servers", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "option -myport is not valid for servers", -1)); return TCL_ERROR; } } else if (a < objc) { - host = Tcl_GetString(objv[a]); + host = TclGetString(objv[a]); a++; } else { Interp *iPtr; @@ -1473,32 +1612,64 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-myaddr addr? port"); - iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; + "-server command ?-reuseaddr boolean? ?-reuseport boolean? " + "?-myaddr addr? ?-backlog count? port"); return TCL_ERROR; } - if (a == objc-1) { - if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { + if (!server && (reusea != -1 || reusep != -1 || backlog != -1)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "options -backlog, -reuseaddr and -reuseport are only valid " + "for servers", -1)); + return TCL_ERROR; + } + + /* + * Set the options to their default value if the user didn't override + * their value. + */ + + if (reusep == -1) { + reusep = 0; + } + if (reusea == -1) { + reusea = 1; + } + + /* + * Build the bitset with the flags values. + */ + + if (reusea) { + flags |= TCL_TCPSERVER_REUSEADDR; + } + if (reusep) { + flags |= TCL_TCPSERVER_REUSEPORT; + } + + /* + * All the arguments should have been parsed by now, 'a' points to the + * last one, the port number. + */ + + if (a != objc-1) { goto wrongNumArgs; } + port = TclGetString(objv[a]); + if (server) { - acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) - sizeof(AcceptCallback)); - copyScript = ckalloc((unsigned) strlen(script) + 1); - strcpy(copyScript, script); - acceptCallbackPtr->script = copyScript; + AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); + + Tcl_IncrRefCount(script); + acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - (ClientData) acceptCallbackPtr); - if (chan == (Tcl_Channel) NULL) { - ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); + + chan = Tcl_OpenTcpServerEx(interp, port, host, flags, backlog, + AcceptCallbackProc, acceptCallbackPtr); + if (chan == NULL) { + Tcl_DecrRefCount(script); + ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1517,17 +1688,16 @@ Tcl_SocketObjCmd( * be informed when the interpreter is deleted. */ - Tcl_CreateCloseHandler(chan, TcpServerCloseProc, - (ClientData) acceptCallbackPtr); + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == (Tcl_Channel) NULL) { + chan = Tcl_OpenTcpClientEx(interp, port, host, myaddr, myport, async); + if (chan == NULL) { return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_RegisterChannel(interp, chan); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); return TCL_OK; } @@ -1554,14 +1724,13 @@ Tcl_FcopyObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel inChan, outChan; - char *arg; - int mode, i; - int toRead, index; + int mode, i, index; + Tcl_WideInt toRead; Tcl_Obj *cmdPtr; - static CONST char* switches[] = { "-size", "-command", NULL }; + static const char *const switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { @@ -1575,39 +1744,47 @@ Tcl_FcopyObjCmd( * writable, as appropriate. */ - arg = Tcl_GetString(objv[1]); - inChan = Tcl_GetChannel(interp, arg, &mode); - if (inChan == (Tcl_Channel) NULL) { + if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", NULL); + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for reading", + TclGetString(objv[1]))); return TCL_ERROR; } - arg = Tcl_GetString(objv[2]); - outChan = Tcl_GetChannel(interp, arg, &mode); - if (outChan == (Tcl_Channel) NULL) { + if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for writing", NULL); + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "channel \"%s\" wasn't opened for writing", + TclGetString(objv[2]))); 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) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: - if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } + if (toRead < 0) { + /* + * Handle all negative sizes like -1, meaning 'copy all'. By + * resetting toRead we avoid changes in the core copying + * functions (which explicitly check for -1 and crash on any + * other negative value). + */ + + toRead = -1; + } break; case FcopyCommand: cmdPtr = objv[i+1]; @@ -1619,9 +1796,74 @@ Tcl_FcopyObjCmd( } /* + *--------------------------------------------------------------------------- + * + * ChanPendingObjCmd -- + * + * This function is invoked to process the Tcl "chan pending" command + * (TIP #287). See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp's result to the number of bytes of buffered input or + * output (depending on whether the first argument is "input" or + * "output"), or -1 if the channel wasn't opened for that mode. + * + *--------------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ChanPendingObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Channel chan; + int index, mode; + static const char *const options[] = {"input", "output", NULL}; + enum options {PENDING_INPUT, PENDING_OUTPUT}; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case PENDING_INPUT: + if (!(mode & TCL_READABLE)) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); + } + break; + case PENDING_OUTPUT: + if (!(mode & TCL_WRITABLE)) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); + } + break; + } + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * - * Tcl_ChanTruncateObjCmd -- + * ChanTruncateObjCmd -- * * This function is invoked to process the "chan truncate" Tcl command. * See the user documentation for details on what it does. @@ -1635,25 +1877,21 @@ Tcl_FcopyObjCmd( *---------------------------------------------------------------------- */ -int -TclChanTruncateObjCmd( +static int +ChanTruncateObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; - int mode; Tcl_WideInt length; - char *chanName; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?"); return TCL_ERROR; } - chanName = TclGetString(objv[1]); - chan = Tcl_GetChannel(interp, chanName, &mode); - if (chan == NULL) { + if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { return TCL_ERROR; } @@ -1666,8 +1904,8 @@ TclChanTruncateObjCmd( return TCL_ERROR; } if (length < 0) { - Tcl_AppendResult(interp, - "cannot truncate to negative length of file", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot truncate to negative length of file", -1)); return TCL_ERROR; } } else { @@ -1677,16 +1915,17 @@ TclChanTruncateObjCmd( length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { - Tcl_AppendResult(interp, - "could not determine current location in \"", chanName, - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not determine current location in \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_AppendResult(interp, "error during truncate on \"", chanName, - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during truncate on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1694,10 +1933,165 @@ TclChanTruncateObjCmd( } /* + *---------------------------------------------------------------------- + * + * ChanPipeObjCmd -- + * + * This function is invoked to process the "chan pipe" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a pair of Tcl channels wrapping both ends of a new + * anonymous pipe. + * + *---------------------------------------------------------------------- + */ + +static int +ChanPipeObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Channel rchan, wchan; + const char *channelNames[2]; + Tcl_Obj *resultPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) { + return TCL_ERROR; + } + + channelNames[0] = Tcl_GetChannelName(rchan); + channelNames[1] = Tcl_GetChannelName(wchan); + + resultPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(channelNames[0], -1)); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(channelNames[1], -1)); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclChannelNamesCmd -- + * + * This function is invoked to process the "chan names" and "file + * channels" Tcl commands. See the user documentation for details on + * what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclChannelNamesCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 1) ? NULL : TclGetString(objv[1]))); +} + +/* + *---------------------------------------------------------------------- + * + * TclInitChanCmd -- + * + * This function is invoked to create the "chan" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A Tcl command handle. + * + * Side effects: + * None (since nothing is byte-compiled). + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitChanCmd( + Tcl_Interp *interp) +{ + /* + * Most commands are plugged directly together, but some are done via + * alias-like rewriting; [chan configure] is this way for security reasons + * (want overwriting of [fconfigure] to control that nicely), and [chan + * names] because the functionality isn't available as a separate command + * function at the moment. + */ + static const EnsembleImplMap initMap[] = { + {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */ + {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */ + {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, + {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */ + {NULL, NULL, NULL, NULL, NULL, 0} + }; + static const char *const extras[] = { + "configure", "::fconfigure", + NULL + }; + Tcl_Command ensemble; + Tcl_Obj *mapObj; + int i; + + ensemble = TclMakeEnsemble(interp, "chan", initMap); + Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); + for (i=0 ; extras[i] ; i+=2) { + /* + * Can assume that reference counts are all incremented. + */ + + Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1), + Tcl_NewStringObj(extras[i+1], -1)); + } + Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj); + return ensemble; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ - |