diff options
Diffstat (limited to 'generic/tclIOCmd.c')
| -rw-r--r-- | generic/tclIOCmd.c | 368 |
1 files changed, 198 insertions, 170 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 696b3ac..005713d 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.69 2010/08/22 18:53:26 nijtmans Exp $ */ #include "tclInt.h" @@ -18,8 +16,8 @@ */ typedef struct AcceptCallback { - char *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; /* @@ -119,12 +117,12 @@ Tcl_PutsObjCmd( 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 { @@ -134,35 +132,30 @@ 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]; - } 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. */ - const char *arg; - int length; - - arg = TclGetStringFromObj(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; - } 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; } @@ -181,9 +174,10 @@ Tcl_PutsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" 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; } @@ -208,9 +202,8 @@ Tcl_PutsObjCmd( error: if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -252,9 +245,10 @@ Tcl_FlushObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" 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; } @@ -267,9 +261,9 @@ Tcl_FlushObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error flushing \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error flushing \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -314,9 +308,10 @@ Tcl_GetsObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" 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; } @@ -327,17 +322,16 @@ Tcl_GetsObjCmd( 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_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -349,7 +343,6 @@ Tcl_GetsObjCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } @@ -420,33 +413,41 @@ Tcl_ReadObjCmd( if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" 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) { - const 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 = TclGetString(objv[i]); - if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ - if (TclGetIntFromObj(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 } } @@ -462,10 +463,9 @@ Tcl_ReadObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading \"%s\": %s", + TclGetString(chanObjPtr), Tcl_PosixError(interp))); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; @@ -523,7 +523,7 @@ Tcl_SeekObjCmd( 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?"); @@ -552,10 +552,11 @@ 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 \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during seek on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -646,6 +647,10 @@ Tcl_CloseObjCmd( 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?"); @@ -657,21 +662,17 @@ Tcl_CloseObjCmd( } if (objc == 3) { - int optionIndex, dir; - static const char *const dirOptions[] = { - "read", "write", NULL - }; - static int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; + int index, dir; /* * Get direction requested to close, and check syntax. */ if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0, - &optionIndex) != TCL_OK) { + &index) != TCL_OK) { return TCL_ERROR; } - dir = dirArray[optionIndex]; + dir = dirArray[index]; /* * Check direction against channel mode. It is an error if we try to @@ -680,10 +681,9 @@ Tcl_CloseObjCmd( */ if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_AppendResult(interp, "Half-close of ", - dirOptions[optionIndex], - "-side not possible, side not opened or already closed", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Half-close of %s-side not possible, side not opened" + " or already closed", dirOptions[index])); return TCL_ERROR; } @@ -760,8 +760,7 @@ Tcl_FconfigureObjCmd( 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 ?-option value ...?"); return TCL_ERROR; } @@ -872,14 +871,9 @@ Tcl_ExecObjCmd( 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; + const char **argv; /* An array for the string arguments. Stored + * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; int argc, background, i, index, keepNewline, result, skip, length; @@ -937,8 +931,7 @@ Tcl_ExecObjCmd( */ argc = objc - skip; - argv = (const char **) - TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); + argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the @@ -950,7 +943,7 @@ 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. @@ -986,9 +979,9 @@ Tcl_ExecObjCmd( */ if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error reading output from command: %s", + Tcl_PosixError(interp))); Tcl_DecrRefCount(resultPtr); } return TCL_ERROR; @@ -1057,9 +1050,10 @@ Tcl_FblockedObjCmd( if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" 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; } @@ -1110,11 +1104,13 @@ Tcl_OpenObjCmd( 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"); @@ -1175,13 +1171,13 @@ Tcl_OpenObjCmd( Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree((char *) cmdArgv); + ckfree(cmdArgv); } 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; } @@ -1224,7 +1220,7 @@ TcpAcceptCallbacksDeleteProc( acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) hTblPtr); + ckfree(hTblPtr); } /* @@ -1261,13 +1257,12 @@ RegisterTcpServerInterpCleanup( Tcl_HashEntry *hPtr; /* Entry for this record. */ 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", + Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); } @@ -1308,8 +1303,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; } @@ -1347,7 +1341,7 @@ AcceptCallbackProc( char *address, /* Address of client that was accepted. */ int port) /* Port of client that was accepted. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; + AcceptCallback *acceptCallbackPtr = callbackData; /* * Check if the callback is still valid; the interpreter may have gone @@ -1392,8 +1386,8 @@ AcceptCallbackProc( Tcl_Release(script); } 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); @@ -1426,7 +1420,7 @@ TcpServerCloseProc( ClientData callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; + AcceptCallback *acceptCallbackPtr = callbackData; /* The actual data. */ if (acceptCallbackPtr->interp != NULL) { @@ -1434,7 +1428,7 @@ TcpServerCloseProc( acceptCallbackPtr); } Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); - ckfree((char *) acceptCallbackPtr); + ckfree(acceptCallbackPtr); } /* @@ -1488,8 +1482,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; @@ -1497,8 +1491,8 @@ 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 = TclGetString(objv[a]); @@ -1508,8 +1502,8 @@ Tcl_SocketObjCmd( a++; if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -myport option", -1)); return TCL_ERROR; } myPortName = TclGetString(objv[a]); @@ -1520,15 +1514,15 @@ Tcl_SocketObjCmd( } 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 = TclGetString(objv[a]); @@ -1540,8 +1534,8 @@ 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) { @@ -1570,8 +1564,8 @@ Tcl_SocketObjCmd( } if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) - ckalloc((unsigned) sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = + ckalloc(sizeof(AcceptCallback)); unsigned len = strlen(script) + 1; char *copyScript = ckalloc(len); @@ -1582,7 +1576,7 @@ Tcl_SocketObjCmd( acceptCallbackPtr); if (chan == NULL) { ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); + ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1608,9 +1602,9 @@ Tcl_SocketObjCmd( 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; } @@ -1660,17 +1654,19 @@ Tcl_FcopyObjCmd( if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" 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; } if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { return TCL_ERROR; } - if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), - "\" 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; } @@ -1754,14 +1750,14 @@ ChanPendingObjCmd( switch ((enum options) index) { case PENDING_INPUT: - if ((mode & TCL_READABLE) == 0) { + 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) == 0) { + if (!(mode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); @@ -1815,8 +1811,8 @@ ChanTruncateObjCmd( 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 { @@ -1826,18 +1822,17 @@ ChanTruncateObjCmd( length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { - Tcl_AppendResult(interp, - "could not determine current location in \"", - TclGetString(objv[1]), "\": ", - 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 \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error during truncate on \"%s\": %s", + TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1898,6 +1893,39 @@ ChanPipeObjCmd( /* *---------------------------------------------------------------------- * + * 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 @@ -1924,29 +1952,29 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL}, - {"close", Tcl_CloseObjCmd, NULL, NULL, NULL}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL}, - {"create", TclChanCreateObjCmd, NULL, NULL, NULL}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, NULL, NULL, NULL}, - {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL}, - {"pending", ChanPendingObjCmd, NULL, NULL, NULL}, /* TIP #287 */ - {"pop", TclChanPopObjCmd, NULL, NULL, NULL}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL}, /* TIP #219 */ - {"push", TclChanPushObjCmd, NULL, NULL, NULL}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL}, - {"pipe", ChanPipeObjCmd, NULL, NULL, NULL}, /* TIP #304 */ - {"tell", Tcl_TellObjCmd, NULL, NULL, NULL}, - {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL}, /* TIP #208 */ - {NULL, NULL, NULL, NULL, NULL} + {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */ + {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0}, + {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */ + {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */ + {NULL, NULL, NULL, NULL, NULL, 0} }; static const char *const extras[] = { "configure", "::fconfigure", - "names", "::file channels", NULL }; Tcl_Command ensemble; |