diff options
Diffstat (limited to 'generic/tclIOCmd.c')
| -rw-r--r-- | generic/tclIOCmd.c | 774 |
1 files changed, 285 insertions, 489 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 808ce97..db1150d 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -3,7 +3,7 @@ * * Contains the definitions of most of the Tcl commands relating to IO. * - * Copyright © 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,9 +15,9 @@ * Callback structure for accept callback in a TCP server. */ -typedef struct { - Tcl_Obj *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; /* @@ -25,7 +25,7 @@ typedef struct { * It must be per-thread because of std channel limitations. */ -typedef struct { +typedef struct ThreadSpecificData { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; @@ -36,15 +36,20 @@ static Tcl_ThreadDataKey dataKey; * Static functions for this file: */ -static Tcl_ExitProc FinalizeIOCmdTSD; -static Tcl_TcpAcceptProc AcceptCallbackProc; -static Tcl_ObjCmdProc ChanPendingObjCmd; -static Tcl_ObjCmdProc ChanTruncateObjCmd; -static void RegisterTcpServerInterpCleanup( - Tcl_Interp *interp, - AcceptCallback *acceptCallbackPtr); -static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc; -static void TcpServerCloseProc(void *callbackData); +static void FinalizeIOCmdTSD(ClientData clientData); +static void AcceptCallbackProc(ClientData callbackData, + Tcl_Channel chan, char *address, int port); +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, + Tcl_Interp *interp); +static void TcpServerCloseProc(ClientData callbackData); static void UnregisterTcpServerInterpCleanupProc( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); @@ -67,7 +72,7 @@ static void UnregisterTcpServerInterpCleanupProc( static void FinalizeIOCmdTSD( - TCL_UNUSED(void *)) + ClientData clientData) /* Not used. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -95,9 +100,10 @@ FinalizeIOCmdTSD( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_PutsObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -106,16 +112,17 @@ Tcl_PutsObjCmd( Tcl_Obj *string; /* String to write. */ Tcl_Obj *chanObjPtr = NULL; /* channel object. */ int newline; /* Add a newline at end? */ - Tcl_Size result; /* Result of puts operation. */ + 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; break; - case 3: /* [puts -nonewline $x] or [puts $chan $x] */ + case 3: /* [puts -nonewline $x] or [puts $chan $x] */ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { newline = 0; } else { @@ -125,14 +132,12 @@ Tcl_PutsObjCmd( string = objv[2]; break; - case 4: /* [puts -nonewline $chan $x] or - * [puts $chan $x nonewline] */ + 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]; break; -#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old @@ -144,17 +149,16 @@ Tcl_PutsObjCmd( chanObjPtr = objv[1]; string = objv[2]; break; -#endif } /* Fall through */ - default: /* [puts] or - * [puts some bad number of arguments...] */ + default: + /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } if (chanObjPtr == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; @@ -167,21 +171,20 @@ Tcl_PutsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(chanObjPtr))); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for writing", NULL); return TCL_ERROR; } TclChannelPreserve(chan); result = Tcl_WriteObj(chan, string); - if (result == TCL_INDEX_NONE) { + if (result < 0) { goto error; } if (newline != 0) { result = Tcl_WriteChars(chan, "\n", 1); - if (result == TCL_INDEX_NONE) { + if (result < 0) { goto error; } } @@ -197,8 +200,9 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error writing \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); return TCL_ERROR; @@ -221,9 +225,10 @@ Tcl_PutsObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FlushObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -240,10 +245,9 @@ Tcl_FlushObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(chanObjPtr))); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for writing", NULL); return TCL_ERROR; } @@ -257,9 +261,9 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error flushing \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error flushing \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); return TCL_ERROR; @@ -285,15 +289,16 @@ Tcl_FlushObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_GetsObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ - Tcl_Size lineLen; /* Length of line just read. */ + int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; int code = TCL_OK; @@ -306,36 +311,36 @@ Tcl_GetsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(chanObjPtr))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } TclChannelPreserve(chan); - TclNewObj(linePtr); + linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); - if (lineLen == TCL_IO_FAILURE) { + if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); /* - * TIP #219. - * Capture error messages put by the driver into the bypass area - * and put them into the regular interpreter result. Fall back to - * the regular message if nothing was found in the bypass. + * TIP #219. Capture error messages put by the driver into the + * bypass area 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_SetObjResult(interp, Tcl_ObjPrintf( - "error reading \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } code = TCL_ERROR; goto done; } - lineLen = TCL_IO_FAILURE; + lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, @@ -343,9 +348,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - Tcl_Obj *lineLenObj; - TclNewIndexObj(lineLenObj, lineLen); - Tcl_SetObjResult(interp, lineLenObj); + Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); } else { Tcl_SetObjResult(interp, linePtr); } @@ -371,9 +374,10 @@ Tcl_GetsObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ReadObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -381,7 +385,7 @@ Tcl_ReadObjCmd( Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ int toRead; /* How many bytes to read? */ - Tcl_Size charactersRead; /* How many characters were read? */ + int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; @@ -399,6 +403,7 @@ Tcl_ReadObjCmd( iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } @@ -417,13 +422,12 @@ Tcl_ReadObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(chanObjPtr))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } - i++; /* Consumed channel name. */ + i++; /* Consumed channel name. */ /* * Compute how many bytes to read. @@ -431,9 +435,7 @@ Tcl_ReadObjCmd( toRead = -1; if (i < objc) { - if ((TclGetIntFromObj(NULL, objv[i], &toRead) != TCL_OK) - || (toRead < 0)) { -#if !defined(TCL_NO_DEPRECATED) + if (TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -442,31 +444,23 @@ Tcl_ReadObjCmd( */ 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", (void *)NULL); - return TCL_ERROR; -#if !defined(TCL_NO_DEPRECATED) + return TCL_ERROR; } newline = 1; -#endif + } else if (toRead < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected non-negative integer but got \"", + TclGetString(objv[i]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); + return TCL_ERROR; } } - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(resultPtr); TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); - if (charactersRead == TCL_IO_FAILURE) { - Tcl_Obj *returnOptsPtr = NULL; - if (TclChannelGetBlockingMode(chan)) { - returnOptsPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-data", -1), - resultPtr); - } else { - Tcl_DecrRefCount(resultPtr); - } + if (charactersRead < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and @@ -475,14 +469,13 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error reading \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", + TclGetString(chanObjPtr), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); - if (returnOptsPtr) { - Tcl_SetReturnOptions(interp, returnOptsPtr); - } + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -491,8 +484,8 @@ Tcl_ReadObjCmd( */ if ((charactersRead > 0) && (newline != 0)) { - const char *result; - Tcl_Size length; + char *result; + int length; result = TclGetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { @@ -501,6 +494,7 @@ Tcl_ReadObjCmd( } Tcl_SetObjResult(interp, resultPtr); TclChannelRelease(chan); + Tcl_DecrRefCount(resultPtr); return TCL_OK; } @@ -522,9 +516,10 @@ Tcl_ReadObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_SeekObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -534,10 +529,10 @@ Tcl_SeekObjCmd( int mode; /* How to seek? */ Tcl_WideInt result; /* Of calling Tcl_Seek. */ int optionIndex; - static const char *const originOptions[] = { + static const char *originOptions[] = { "start", "current", "end", NULL }; - static const 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?"); @@ -560,18 +555,17 @@ Tcl_SeekObjCmd( TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); - if (result == -1) { + if (result == Tcl_LongAsWide(-1)) { /* * TIP #219. * Capture error messages put by the driver into the bypass area 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_SetObjResult(interp, Tcl_ObjPrintf( - "error during seek on \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error during seek on \"", + TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); } TclChannelRelease(chan); return TCL_ERROR; @@ -597,9 +591,10 @@ Tcl_SeekObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_TellObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -659,21 +654,18 @@ Tcl_TellObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_CloseObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; /* The channel to close. */ - static const char *const dirOptions[] = { - "read", "write", NULL - }; - static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } @@ -681,45 +673,6 @@ Tcl_CloseObjCmd( 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 supported 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 @@ -733,8 +686,8 @@ Tcl_CloseObjCmd( */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); - const char *string; - Tcl_Size len; + char *string; + int len; if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); @@ -767,19 +720,21 @@ Tcl_CloseObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FconfigureObjCmd( - TCL_UNUSED(void *), + ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *optionName, *valueName; + 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 ?-option value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, + "channelId ?optionName? ?value? ?optionName value?..."); return TCL_ERROR; } @@ -842,9 +797,10 @@ Tcl_FconfigureObjCmd( *--------------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_EofObjCmd( - TCL_UNUSED(void *), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -881,24 +837,30 @@ Tcl_EofObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_ExecObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ 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. + */ + Tcl_Obj *resultPtr; - const char **argv; /* An array for the string arguments. Stored - * on the _Tcl_ stack. */ - const char *string; + const char **argv; + char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, ignoreStderr; - Tcl_Size length; - static const char *const options[] = { + int argc, background, i, index, keepNewline, result, skip, length; + int ignoreStderr; + static const char *options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; - enum execOptionsEnum { + enum options { EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST }; @@ -913,7 +875,7 @@ Tcl_ExecObjCmd( if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } @@ -927,7 +889,7 @@ Tcl_ExecObjCmd( } } if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); return TCL_ERROR; } @@ -948,7 +910,8 @@ Tcl_ExecObjCmd( */ argc = objc - skip; - argv = (const char **)TclStackAlloc(interp, (argc + 1) * sizeof(char *)); + argv = (const char **) + TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the @@ -960,13 +923,13 @@ Tcl_ExecObjCmd( } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : - ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)); + (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR))); /* * Free the argv array. */ - TclStackFree(interp, (void *) argv); + TclStackFree(interp, (void *)argv); if (chan == NULL) { return TCL_ERROR; @@ -985,9 +948,9 @@ Tcl_ExecObjCmd( return TCL_OK; } - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { - if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { /* * TIP #219. * Capture error messages put by the driver into the bypass area @@ -996,9 +959,9 @@ Tcl_ExecObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error reading output from command: %s", - Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), NULL); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -1043,14 +1006,15 @@ Tcl_ExecObjCmd( * * Side effects: * Sets interp's result to boolean true or false depending on whether the - * preceding input operation on the channel would have blocked. + * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_FblockedObjCmd( - TCL_UNUSED(void *), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1066,10 +1030,9 @@ Tcl_FblockedObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(objv[1]))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } @@ -1094,9 +1057,10 @@ Tcl_FblockedObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ int Tcl_OpenObjCmd( - TCL_UNUSED(void *), + ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1115,17 +1079,15 @@ Tcl_OpenObjCmd( } else { modeString = TclGetString(objv[2]); if (objc == 4) { - const char *permString = TclGetString(objv[3]); + char *permString = TclGetString(objv[3]); int code = TCL_ERROR; int scanned = TclParseAllWhiteSpace(permString, -1); - /* - * Support legacy octal numbers. - */ - + /* Support legacy octal numbers */ if ((permString[scanned] == '0') && (permString[scanned+1] >= '0') && (permString[scanned+1] <= '7')) { + Tcl_Obj *permObj; TclNewLiteralStringObj(permObj, "0o"); @@ -1154,8 +1116,7 @@ Tcl_OpenObjCmd( if (!pipeline) { chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { - int mode, seekFlag, binary; - Tcl_Size cmdObjc; + int mode, seekFlag, cmdObjc, binary; const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { @@ -1187,13 +1148,13 @@ Tcl_OpenObjCmd( Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree(cmdArgv); + ckfree((char *) cmdArgv); } if (chan == NULL) { return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); return TCL_OK; } @@ -1218,24 +1179,25 @@ Tcl_OpenObjCmd( *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void TcpAcceptCallbacksDeleteProc( - void *clientData, /* Data which was passed when the assocdata + ClientData clientData, /* Data which was passed when the assocdata * was registered. */ - TCL_UNUSED(Tcl_Interp *)) + Tcl_Interp *interp) /* Interpreter being deleted - not used. */ { - Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData; + Tcl_HashTable *hTblPtr = clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_GetHashValue(hPtr); + AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - ckfree(hTblPtr); + ckfree((char *) hTblPtr); } /* @@ -1272,16 +1234,17 @@ RegisterTcpServerInterpCleanup( Tcl_HashEntry *hPtr; /* Entry for this record. */ int isNew; /* Is the entry new? */ - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = (Tcl_HashTable *) + Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); } - hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew); + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew); if (!isNew) { Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } @@ -1318,12 +1281,13 @@ UnregisterTcpServerInterpCleanupProc( Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { return; } - hPtr = Tcl_FindHashEntry(hTblPtr, (char *)acceptCallbackPtr); + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } @@ -1348,7 +1312,7 @@ UnregisterTcpServerInterpCleanupProc( static void AcceptCallbackProc( - void *callbackData, /* The data stored when the callback was + ClientData callbackData, /* The data stored when the callback was * created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan, /* Channel for the newly accepted @@ -1356,7 +1320,7 @@ AcceptCallbackProc( char *address, /* Address of client that was accepted. */ int port) /* Port of client that was accepted. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; + AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; /* * Check if the callback is still valid; the interpreter may have gone @@ -1365,22 +1329,15 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { + char portBuf[TCL_INTEGER_SPACE]; + char *script = acceptCallbackPtr->script; 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_NewWideIntObj(port)); - - script = Tcl_ConcatObj(2, objv); - Tcl_IncrRefCount(script); - Tcl_DecrRefCount(objv[1]); + int result; + Tcl_Preserve(script); Tcl_Preserve(interp); + + TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* @@ -1390,11 +1347,10 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(script); - + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, NULL); if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); + TclBackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); } @@ -1406,10 +1362,11 @@ AcceptCallbackProc( Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); + Tcl_Release(script); } else { /* - * The interpreter has been deleted, so there is no useful way to use - * the client socket - just close it. + * The interpreter has been deleted, so there is no useful way to + * utilize the client socket - just close it. */ Tcl_Close(NULL, chan); @@ -1439,18 +1396,18 @@ AcceptCallbackProc( static void TcpServerCloseProc( - void *callbackData) /* The data passed in the call to + ClientData callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; + AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; /* The actual data. */ if (acceptCallbackPtr->interp != NULL) { UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_DecrRefCount(acceptCallbackPtr->script); - ckfree(acceptCallbackPtr); + Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); } /* @@ -1472,30 +1429,27 @@ TcpServerCloseProc( int Tcl_SocketObjCmd( - TCL_UNUSED(void *), + ClientData notUsed, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const socketOptions[] = { - "-async", "-backlog", "-myaddr", "-myport", "-reuseaddr", - "-reuseport", "-server", NULL + static const char *socketOptions[] = { + "-async", "-myaddr", "-myport","-server", NULL }; - enum socketOptionsEnum { - SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, - SKT_REUSEPORT, SKT_SERVER + enum socketOptions { + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; - int a, server = 0, myport = 0, async = 0, reusep = -1, optionIndex, - reusea = -1, backlog = -1; - unsigned int flags = 0; - const char *host, *port, *myaddr = NULL; - Tcl_Obj *script = NULL; + int optionIndex, a, server = 0, port, myport = 0, async = 0; + char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; - TclInitSockets(); + if (TclpHasSockets(interp) != TCL_OK) { + return TCL_ERROR; + } for (a = 1; a < objc; a++) { - const char *arg = TclGetString(objv[a]); + const char *arg = Tcl_GetString(objv[a]); if (arg[0] != '-') { break; @@ -1504,11 +1458,11 @@ Tcl_SocketObjCmd( TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum socketOptionsEnum) optionIndex) { + switch ((enum socketOptions) optionIndex) { case SKT_ASYNC: if (server == 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot set -async option for server sockets", -1)); + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", NULL); return TCL_ERROR; } async = 1; @@ -1516,19 +1470,19 @@ Tcl_SocketObjCmd( case SKT_MYADDR: a++; if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -myaddr option", -1)); + Tcl_AppendResult(interp, + "no argument given for -myaddr option", NULL); return TCL_ERROR; } myaddr = TclGetString(objv[a]); break; case SKT_MYPORT: { - const char *myPortName; + char *myPortName; a++; if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -myport option", -1)); + Tcl_AppendResult(interp, + "no argument given for -myport option", NULL); return TCL_ERROR; } myPortName = TclGetString(objv[a]); @@ -1539,51 +1493,18 @@ Tcl_SocketObjCmd( } case SKT_SERVER: if (async == 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot set -async option for server sockets", -1)); + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", NULL); return TCL_ERROR; } server = 1; a++; if (a >= objc) { - 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) { + Tcl_AppendResult(interp, + "no argument given for -server option", NULL); return TCL_ERROR; } + script = TclGetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1592,8 +1513,8 @@ Tcl_SocketObjCmd( if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "option -myport is not valid for servers", -1)); + Tcl_AppendResult(interp, "option -myport is not valid for servers", + NULL); return TCL_ERROR; } } else if (a < objc) { @@ -1605,67 +1526,37 @@ Tcl_SocketObjCmd( wrongNumArgs: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, - "?-async? ?-myaddr addr? ?-myport myport? host port"); + "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-backlog count? ?-myaddr addr? " - "?-reuseaddr boolean? ?-reuseport boolean? port"); + "-server command ?-myaddr addr? port"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; return TCL_ERROR; } - 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) { + if (a == objc-1) { + if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", + &port) != TCL_OK) { + return TCL_ERROR; + } + } else { goto wrongNumArgs; } - port = TclGetString(objv[a]); - if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = (AcceptCallback *) + ckalloc((unsigned) sizeof(AcceptCallback)); + unsigned len = strlen(script) + 1; + char *copyScript = ckalloc(len); - Tcl_IncrRefCount(script); - acceptCallbackPtr->script = script; + memcpy(copyScript, script, len); + acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; - - chan = Tcl_OpenTcpServerEx(interp, port, host, flags, backlog, - AcceptCallbackProc, acceptCallbackPtr); + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + acceptCallbackPtr); if (chan == NULL) { - Tcl_DecrRefCount(script); - ckfree(acceptCallbackPtr); + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); return TCL_ERROR; } @@ -1686,20 +1577,14 @@ Tcl_SocketObjCmd( Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - int portNum; - - if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { - return TCL_ERROR; - } - - chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } } - Tcl_RegisterChannel(interp, chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + return TCL_OK; } @@ -1723,16 +1608,15 @@ Tcl_SocketObjCmd( int Tcl_FcopyObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel inChan, outChan; - int mode, i, index; - Tcl_WideInt toRead; + int mode, i, toRead, index; Tcl_Obj *cmdPtr; - static const char *const switches[] = { "-size", "-command", NULL }; + static const char* switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { @@ -1749,42 +1633,39 @@ Tcl_FcopyObjCmd( if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(objv[1]))); + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), + "\" wasn't opened for reading", NULL); return TCL_ERROR; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(objv[2]))); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), + "\" wasn't opened for writing", NULL); return TCL_ERROR; } toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case FcopySize: - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { return TCL_ERROR; } - if (toRead < 0) { + 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; @@ -1816,17 +1697,18 @@ Tcl_FcopyObjCmd( *--------------------------------------------------------------------------- */ + /* ARGSUSED */ static int ChanPendingObjCmd( - TCL_UNUSED(void *), + ClientData unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Channel chan; - static const char *const options[] = {"input", "output", NULL}; - enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; - int mode, index; + int index, mode; + static const char *options[] = {"input", "output", NULL}; + enum options {PENDING_INPUT, PENDING_OUTPUT}; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); @@ -1842,19 +1724,19 @@ ChanPendingObjCmd( return TCL_ERROR; } - switch ((enum pendingOptionsEnum) index) { + switch ((enum options) index) { case PENDING_INPUT: - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); + if ((mode & TCL_READABLE) == 0) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_InputBuffered(chan))); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); } break; case PENDING_OUTPUT: - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); + if ((mode & TCL_WRITABLE) == 0) { + Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan))); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); } break; } @@ -1880,7 +1762,7 @@ ChanPendingObjCmd( static int ChanTruncateObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1905,8 +1787,8 @@ ChanTruncateObjCmd( return TCL_ERROR; } if (length < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot truncate to negative length of file", -1)); + Tcl_AppendResult(interp, + "cannot truncate to negative length of file", NULL); return TCL_ERROR; } } else { @@ -1915,111 +1797,28 @@ ChanTruncateObjCmd( */ length = Tcl_Tell(chan); - if (length == -1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not determine current location in \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); + if (length == Tcl_WideAsLong(-1)) { + Tcl_AppendResult(interp, + "could not determine current location in \"", + TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); return TCL_ERROR; } } if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error during truncate on \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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( - TCL_UNUSED(void *), - 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) { + Tcl_AppendResult(interp, "error during truncate on \"", + TclGetString(objv[1]), "\": ", + Tcl_PosixError(interp), NULL); return TCL_ERROR; } - channelNames[0] = Tcl_GetChannelName(rchan); - channelNames[1] = Tcl_GetChannelName(wchan); - - TclNewObj(resultPtr); - 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( - TCL_UNUSED(void *), - 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 @@ -2046,29 +1845,26 @@ TclInitChanCmd( * 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} + {"blocked", Tcl_FblockedObjCmd, NULL}, + {"close", Tcl_CloseObjCmd, NULL}, + {"copy", Tcl_FcopyObjCmd, NULL}, + {"create", TclChanCreateObjCmd, NULL}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL}, + {"event", Tcl_FileEventObjCmd, NULL}, + {"flush", Tcl_FlushObjCmd, NULL}, + {"gets", Tcl_GetsObjCmd, NULL}, + {"pending", ChanPendingObjCmd, NULL}, /* TIP #287 */ + {"postevent", TclChanPostEventObjCmd, NULL}, /* TIP #219 */ + {"puts", Tcl_PutsObjCmd, NULL}, + {"read", Tcl_ReadObjCmd, NULL}, + {"seek", Tcl_SeekObjCmd, NULL}, + {"tell", Tcl_TellObjCmd, NULL}, + {"truncate", ChanTruncateObjCmd, NULL}, /* TIP #208 */ + {NULL,NULL, NULL} }; static const char *const extras[] = { "configure", "::fconfigure", + "names", "::file channels", NULL }; Tcl_Command ensemble; |