diff options
Diffstat (limited to 'generic/tclIOCmd.c')
| -rw-r--r-- | generic/tclIOCmd.c | 1712 |
1 files changed, 692 insertions, 1020 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 21dcd71..635490c 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1,15 +1,16 @@ -/* +/* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" +#include "tclPort.h" /* * Callback structure for accept callback in a TCP server. @@ -21,75 +22,26 @@ typedef struct AcceptCallback { } 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 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); - -/* - *---------------------------------------------------------------------- - * - * 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; -} +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr)); +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); /* *---------------------------------------------------------------------- * * Tcl_PutsObjCmd -- * - * This function is invoked to process the "puts" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "puts" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -102,106 +54,94 @@ FinalizeIOCmdTSD( /* ARGSUSED */ int -Tcl_PutsObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_PutsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to puts on. */ - Tcl_Obj *string; /* String to write. */ - Tcl_Obj *chanObjPtr = NULL; /* channel object. */ - int newline; /* Add a newline at end? */ - int result; /* Result of puts operation. */ - int mode; /* Mode in which channel is opened. */ - ThreadSpecificData *tsdPtr; + Tcl_Channel chan; /* The channel to puts on. */ + Tcl_Obj *string; /* String to write. */ + int newline; /* Add a newline at end? */ + char *channelId; /* Name of channel for puts. */ + int result; /* Result of puts operation. */ + int mode; /* Mode in which channel is opened. */ switch (objc) { - case 2: /* [puts $x] */ + case 2: /* puts $x */ string = objv[1]; newline = 1; + channelId = "stdout"; break; - case 3: /* [puts -nonewline $x] or [puts $chan $x] */ - if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { + case 3: /* puts -nonewline $x or puts $chan $x */ + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 0; + channelId = "stdout"; } else { newline = 1; - chanObjPtr = objv[1]; + channelId = Tcl_GetString(objv[1]); } string = objv[2]; break; - case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */ - newline = 0; - if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { - chanObjPtr = objv[2]; + case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */ + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + channelId = Tcl_GetString(objv[2]); string = objv[3]; - break; - } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { + } else { /* - * 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. + * The code below provides backwards compatibility with an + * old form of the command that is no longer recommended + * or documented. */ - chanObjPtr = objv[1]; + char *arg; + int length; + + arg = Tcl_GetStringFromObj(objv[3], &length); + if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": should be \"nonewline\"", + (char *) NULL); + return TCL_ERROR; + } + channelId = Tcl_GetString(objv[1]); string = objv[2]; - break; } - /* Fall through */ - default: - /* [puts] or [puts some bad number of arguments...] */ + newline = 0; + break; + + default: /* puts or puts some bad number of arguments... */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } - 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; + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } result = Tcl_WriteObj(chan, string); if (result < 0) { - goto error; + goto error; } if (newline != 0) { - result = Tcl_WriteChars(chan, "\n", 1); - if (result < 0) { - goto error; - } + result = Tcl_WriteChars(chan, "\n", 1); + if (result < 0) { + goto error; + } } return TCL_OK; - /* - * 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. - */ - - error: - if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_AppendResult(interp, "error writing \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); - } + error: + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -210,8 +150,8 @@ Tcl_PutsObjCmd( * * Tcl_FlushObjCmd -- * - * This function is called to process the Tcl "flush" command. See the - * user documentation for details on what it does. + * This procedure is called to process the Tcl "flush" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -224,43 +164,34 @@ Tcl_PutsObjCmd( /* ARGSUSED */ int -Tcl_FlushObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_FlushObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *chanObjPtr; - Tcl_Channel chan; /* The channel to flush on. */ + Tcl_Channel chan; /* The channel to flush on. */ + char *channelId; int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - chanObjPtr = objv[1]; - if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { + channelId = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for writing", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } - + if (Tcl_Flush(chan) != TCL_OK) { - /* - * 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_AppendResult(interp, "error flushing \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); - } + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -271,8 +202,8 @@ Tcl_FlushObjCmd( * * Tcl_GetsObjCmd -- * - * This function is called to process the Tcl "gets" command. See the - * user documentation for details on what it does. + * This procedure is called to process the Tcl "gets" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -285,61 +216,54 @@ Tcl_FlushObjCmd( /* ARGSUSED */ int -Tcl_GetsObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_GetsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to read from. */ - int lineLen; /* Length of line just read. */ - int mode; /* Mode in which channel is opened. */ - Tcl_Obj *linePtr, *chanObjPtr; + 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; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); return TCL_ERROR; } - chanObjPtr = objv[1]; - if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { + name = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, name, &mode); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } linePtr = Tcl_NewObj(); + lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { - if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + 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. - */ - - if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", - TclGetString(chanObjPtr), "\": ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; - } - lineLen = -1; + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } + Tcl_DecrRefCount(linePtr); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; + return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } @@ -351,8 +275,8 @@ Tcl_GetsObjCmd( * * Tcl_ReadObjCmd -- * - * This function is invoked to process the Tcl "read" command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the Tcl "read" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -365,116 +289,94 @@ Tcl_GetsObjCmd( /* ARGSUSED */ int -Tcl_ReadObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_ReadObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ - Tcl_Obj *resultPtr, *chanObjPtr; + char *name; + Tcl_Obj *resultPtr; if ((objc != 2) && (objc != 3)) { - Interp *iPtr; - - argerror: - iPtr = (Interp *) interp; + argerror: Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); - - /* - * Do not append directly; that makes ensembles using this command as - * a subcommand produce the wrong message. - */ - - iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; - Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); - iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; + Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]), + " ?-nonewline? channelId\"", (char *) NULL); return TCL_ERROR; } i = 1; newline = 0; - if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } if (i == objc) { - goto argerror; + goto argerror; } - chanObjPtr = objv[i]; - if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { + name = Tcl_GetString(objv[i]); + chan = Tcl_GetChannel(interp, name, &mode); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(chanObjPtr), - "\" wasn't opened for reading", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } i++; /* Consumed channel name. */ /* - * Compute how many bytes to read. + * Compute how many bytes to read, and see whether the final + * newline should be dropped. */ toRead = -1; if (i < objc) { - 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 - * documented. See also [Bug #3151675]. Will be removed in Tcl 9, - * maybe even earlier. - */ - - if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { - return TCL_ERROR; + char *arg; + + arg = Tcl_GetString(objv[i]); + if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ + if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { + return TCL_ERROR; } + } else if (strcmp(arg, "nonewline") == 0) { newline = 1; - } else 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); + } else { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; - } + } } resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { - /* - * 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_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } - + /* * If requested, remove the last newline in the channel if at EOF. */ - + if ((charactersRead > 0) && (newline != 0)) { char *result; int length; - result = TclGetStringFromObj(resultPtr, &length); + result = Tcl_GetStringFromObj(resultPtr, &length); if (result[length - 1] == '\n') { Tcl_SetObjLength(resultPtr, length - 1); } @@ -489,34 +391,35 @@ Tcl_ReadObjCmd( * * Tcl_SeekObjCmd -- * - * This function is invoked to process the Tcl "seek" command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the Tcl "seek" command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Moves the position of the access point on the specified channel. May - * flush queued output. + * Moves the position of the access point on the specified channel. + * May flush queued output. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int -Tcl_SeekObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_SeekObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to tell on. */ - Tcl_WideInt offset; /* Where to seek? */ - int mode; /* How to seek? */ - Tcl_WideInt result; /* Of calling Tcl_Seek. */ + Tcl_Channel chan; /* The channel to tell on. */ + Tcl_WideInt offset; /* Where to seek? */ + int mode; /* How to seek? */ + Tcl_WideInt result; /* Of calling Tcl_Seek. */ + char *chanName; int optionIndex; - static const char *originOptions[] = { - "start", "current", "end", NULL + static CONST char *originOptions[] = { + "start", "current", "end", (char *) NULL }; static CONST int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; @@ -524,7 +427,9 @@ Tcl_SeekObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); return TCL_ERROR; } - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { @@ -541,18 +446,9 @@ Tcl_SeekObjCmd( result = Tcl_Seek(chan, offset, mode); 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_AppendResult(interp, "error during seek on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + Tcl_AppendResult(interp, "error during seek on \"", + chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } return TCL_OK; } @@ -562,8 +458,8 @@ Tcl_SeekObjCmd( * * Tcl_TellObjCmd -- * - * This function is invoked to process the Tcl "tell" command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the Tcl "tell" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -576,42 +472,30 @@ Tcl_SeekObjCmd( /* ARGSUSED */ int -Tcl_TellObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_TellObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to tell on. */ - Tcl_WideInt newLoc; + Tcl_Channel chan; /* The channel to tell on. */ + char *chanName; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - - /* - * Try to find a channel with the right name and permissions in the IO - * channel table of this interpreter. - */ - - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - return TCL_ERROR; - } - - newLoc = Tcl_Tell(chan); - /* - * TIP #219. - * Capture error messages put by the driver into the bypass area and put - * them into the regular interpreter result. + * Try to find a channel with the right name and permissions in + * the IO channel table of this interpreter. */ - - if (TclChanCaughtErrorBypass(interp, chan)) { + + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc)); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); return TCL_OK; } @@ -620,8 +504,8 @@ Tcl_TellObjCmd( * * Tcl_CloseObjCmd -- * - * This function is invoked to process the Tcl "close" command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the Tcl "close" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -634,48 +518,48 @@ Tcl_TellObjCmd( /* ARGSUSED */ int -Tcl_CloseObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_CloseObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to close. */ + Tcl_Channel chan; /* The channel to close. */ + char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, NULL); + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { - /* - * If there is an error message and it ends with a newline, remove the - * newline. This is done for command pipeline channels where the error - * output from the subprocesses is stored in interp's result. - * - * NOTE: This is likely to not have any effect on regular error - * messages produced by drivers during the closing of a channel, - * because the Tcl convention is that such error messages do not have - * a terminating newline. - */ - - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + /* + * If there is an error message and it ends with a newline, remove + * the newline. This is done for command pipeline channels where the + * error output from the subprocesses is stored in interp's result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not + * have a terminating newline. + */ + + Tcl_Obj *resultPtr; char *string; int len; - - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - string = TclGetStringFromObj(resultPtr, &len); - if ((len > 0) && (string[len - 1] == '\n')) { + + resultPtr = Tcl_GetObjResult(interp); + string = Tcl_GetStringFromObj(resultPtr, &len); + if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); - } - return TCL_ERROR; + } + return TCL_ERROR; } return TCL_OK; @@ -686,8 +570,8 @@ Tcl_CloseObjCmd( * * Tcl_FconfigureObjCmd -- * - * This function is invoked to process the Tcl "fconfigure" command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "fconfigure" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -700,60 +584,55 @@ Tcl_CloseObjCmd( /* ARGSUSED */ int -Tcl_FconfigureObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_FconfigureObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *optionName, *valueName; - Tcl_Channel chan; /* The channel to set a mode on. */ - int i; /* Iterate over arg-value pairs. */ + char *chanName, *optionName, *valueName; + Tcl_Channel chan; /* The channel to set a mode on. */ + int i; /* Iterate over arg-value pairs. */ + Tcl_DString ds; /* DString to hold result of + * calling Tcl_GetChannelOption. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?optionName? ?value? ?optionName value?..."); - return TCL_ERROR; + return TCL_ERROR; } - - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - return TCL_ERROR; + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; } - if (objc == 2) { - Tcl_DString ds; /* DString to hold result of calling - * Tcl_GetChannelOption. */ - - Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, NULL, &ds) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - return TCL_OK; - } else if (objc == 3) { - Tcl_DString ds; /* DString to hold result of calling - * Tcl_GetChannelOption. */ - - Tcl_DStringInit(&ds); - optionName = TclGetString(objv[2]); - if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - return TCL_OK; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } + if (objc == 3) { + Tcl_DStringInit(&ds); + optionName = Tcl_GetString(objv[2]); + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; } - for (i = 3; i < objc; i += 2) { - optionName = TclGetString(objv[i-1]); - valueName = TclGetString(objv[i]); - if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + optionName = Tcl_GetString(objv[i-1]); + valueName = Tcl_GetString(objv[i]); + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) != TCL_OK) { - return TCL_ERROR; - } + return TCL_ERROR; + } } - return TCL_OK; } @@ -762,39 +641,43 @@ Tcl_FconfigureObjCmd( * * Tcl_EofObjCmd -- * - * This function is invoked to process the Tcl "eof" command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the Tcl "eof" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Sets interp's result to boolean true or false depending on whether the - * specified channel has an EOF condition. + * Sets interp's result to boolean true or false depending on whether + * the specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ int -Tcl_EofObjCmd( - ClientData unused, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_EofObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; + int dummy; + char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, &dummy); + if (chan == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan))); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan)); return TCL_OK; } @@ -803,8 +686,8 @@ Tcl_EofObjCmd( * * Tcl_ExecObjCmd -- * - * This function is invoked to process the "exec" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "exec" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -817,39 +700,39 @@ Tcl_EofObjCmd( /* ARGSUSED */ int -Tcl_ExecObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_ExecObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { /* - * This function generates an argv array for the string arguments. It + * This procedure generates an argv array for the string arguments. It * starts out with stack-allocated space but uses dynamically-allocated * storage if needed. */ +#define NUM_ARGS 20 Tcl_Obj *resultPtr; - const char **argv; + CONST char **argv; char *string; Tcl_Channel chan; + CONST char *argStorage[NUM_ARGS]; int argc, background, i, index, keepNewline, result, skip, length; - int ignoreStderr; - static const char *options[] = { - "-ignorestderr", "-keepnewline", "--", NULL + static CONST char *options[] = { + "-keepnewline", "--", NULL }; enum options { - EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST + EXEC_KEEPNEWLINE, EXEC_LAST }; /* - * Check for any leading option arguments. + * Check for a leading "-keepnewline" argument. */ keepNewline = 0; - ignoreStderr = 0; for (skip = 1; skip < objc; skip++) { - string = TclGetString(objv[skip]); + string = Tcl_GetString(objv[skip]); if (string[0] != '-') { break; } @@ -859,8 +742,6 @@ Tcl_ExecObjCmd( } if (index == EXEC_KEEPNEWLINE) { keepNewline = 1; - } else if (index == EXEC_IGNORESTDERR) { - ignoreStderr = 1; } else { skip++; break; @@ -876,20 +757,23 @@ Tcl_ExecObjCmd( */ background = 0; - string = TclGetString(objv[objc - 1]); + string = Tcl_GetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; - background = 1; + background = 1; } /* - * Create the string argument array "argv". Make sure argv is large enough - * to hold the argc arguments plus 1 extra for the zero end-of-argv word. + * Create the string argument array "argv". Make sure argv is large + * enough to hold the argc arguments plus 1 extra for the zero + * end-of-argv word. */ + argv = argStorage; argc = objc - skip; - argv = (const char **) - TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); + if ((argc + 1) > (int)(sizeof(argv) / sizeof(argv[0]))) { + argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); + } /* * Copy the string conversions of each (post option) object into the @@ -897,71 +781,64 @@ Tcl_ExecObjCmd( */ for (i = 0; i < argc; i++) { - argv[i] = TclGetString(objv[i + skip]); + argv[i] = Tcl_GetString(objv[i + skip]); } argv[argc] = NULL; - chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : - (ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR))); + chan = Tcl_OpenCommandChannel(interp, argc, argv, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); /* - * Free the argv array. + * Free the argv array if malloc'ed storage was used. */ - TclStackFree(interp, (void *)argv); + if (argv != argStorage) { + ckfree((char *)argv); + } - if (chan == NULL) { + if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if (background) { - /* + /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ - TclGetAndDetachPids(interp, chan); - if (Tcl_Close(interp, chan) != TCL_OK) { + TclGetAndDetachPids(interp, chan); + if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; - } + } return TCL_OK; } resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { - /* - * 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 output from command: ", - Tcl_PosixError(interp), NULL); - Tcl_DecrRefCount(resultPtr); - } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } } - /* - * If the process produced anything on stderr, it will have been returned - * in the interpreter result. It needs to be appended to the result - * string. + * If the process produced anything on stderr, it will have been + * returned in the interpreter result. It needs to be appended to + * the result string. */ result = Tcl_Close(interp, chan); - Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + Tcl_AppendToObj(resultPtr, string, length); /* - * If the last character of the result is a newline, then remove the - * newline character. + * If the last character of the result is a newline, then remove + * the newline character. */ - + if (keepNewline == 0) { - string = TclGetStringFromObj(resultPtr, &length); + string = Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { Tcl_SetObjLength(resultPtr, length - 1); } @@ -976,45 +853,48 @@ Tcl_ExecObjCmd( * * Tcl_FblockedObjCmd -- * - * This function is invoked to process the Tcl "fblocked" command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "fblocked" command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Sets interp's result to boolean true or false depending on whether the - * preceeding input operation on the channel would have blocked. + * Sets interp's result to boolean true or false depending on whether + * the preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ /* ARGSUSED */ int -Tcl_FblockedObjCmd( - ClientData unused, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_FblockedObjCmd(unused, interp, objc, objv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; int mode; + char *arg; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } - if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { - return TCL_ERROR; + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, &mode); + if (chan == NULL) { + return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]), - "\" wasn't opened for reading", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + arg, "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); + + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan)); return TCL_OK; } @@ -1023,8 +903,8 @@ Tcl_FblockedObjCmd( * * Tcl_OpenObjCmd -- * - * This function is invoked to process the "open" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "open" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1037,14 +917,14 @@ Tcl_FblockedObjCmd( /* ARGSUSED */ int -Tcl_OpenObjCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_OpenObjCmd(notUsed, interp, objc, objv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int pipeline, prot; - const char *modeString, *what; + char *modeString, *what; Tcl_Channel chan; if ((objc < 2) || (objc > 4)) { @@ -1055,34 +935,16 @@ Tcl_OpenObjCmd( if (objc == 2) { modeString = "r"; } else { - modeString = TclGetString(objv[2]); + modeString = Tcl_GetString(objv[2]); if (objc == 4) { - 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) { + if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } pipeline = 0; - what = TclGetString(objv[1]); + what = Tcl_GetString(objv[1]); if (what[0] == '|') { pipeline = 1; } @@ -1092,47 +954,43 @@ Tcl_OpenObjCmd( */ if (!pipeline) { - chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { - int mode, seekFlag, cmdObjc, binary; - const char **cmdArgv; + int mode, seekFlag, cmdObjc; + CONST char **cmdArgv; - if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } - mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); - if (mode == -1) { + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { chan = NULL; - } else { + } else { int flags = TCL_STDERR | TCL_ENFORCE_MODE; - switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - flags |= TCL_STDOUT; - break; - case O_WRONLY: - flags |= TCL_STDIN; - break; - case O_RDWR: - flags |= (TCL_STDIN | TCL_STDOUT); - break; - default: - Tcl_Panic("Tcl_OpenCmd: invalid mode value"); - break; + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + panic("Tcl_OpenCmd: invalid mode value"); + break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); - if (binary && chan) { - Tcl_SetChannelOption(interp, chan, "-translation", "binary"); - } } - ckfree((char *) cmdArgv); + ckfree((char *) cmdArgv); } - if (chan == NULL) { - return TCL_ERROR; + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); return TCL_OK; } @@ -1141,38 +999,40 @@ Tcl_OpenObjCmd( * * TcpAcceptCallbacksDeleteProc -- * - * Assocdata cleanup routine called when an interpreter is being deleted - * to set the interp field of all the accept callback records registered - * with the interpreter to NULL. This will prevent the interpreter from - * being used in the future to eval accept scripts. + * Assocdata cleanup routine called when an interpreter is being + * deleted to set the interp field of all the accept callback records + * registered with the interpreter to NULL. This will prevent the + * interpreter from being used in the future to eval accept scripts. * * Results: * None. * * Side effects: * Deallocates memory and sets the interp field of all the accept - * callback records to NULL to prevent this interpreter from being used - * subsequently to eval accept scripts. + * callback records to NULL to prevent this interpreter from being + * used subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void -TcpAcceptCallbacksDeleteProc( - ClientData clientData, /* Data which was passed when the assocdata - * was registered. */ - Tcl_Interp *interp) /* Interpreter being deleted - not used. */ +TcpAcceptCallbacksDeleteProc(clientData, interp) + ClientData clientData; /* Data which was passed when the assocdata + * was registered. */ + Tcl_Interp *interp; /* Interpreter being deleted - not used. */ { - Tcl_HashTable *hTblPtr = clientData; + Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; + AcceptCallback *acceptCallbackPtr; + hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); - - acceptCallbackPtr->interp = NULL; + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; } Tcl_DeleteHashTable(hTblPtr); ckfree((char *) hTblPtr); @@ -1183,50 +1043,50 @@ TcpAcceptCallbacksDeleteProc( * * RegisterTcpServerInterpCleanup -- * - * Registers an accept callback record to have its interp field set to - * NULL when the interpreter is deleted. + * Registers an accept callback record to have its interp + * field set to NULL when the interpreter is deleted. * * Results: * None. * * Side effects: - * When, in the future, the interpreter is deleted, the interp field of - * the accept callback data structure will be set to NULL. This will - * prevent attempts to eval the accept script in a deleted interpreter. + * When, in the future, the interpreter is deleted, the interp + * field of the accept callback data structure will be set to + * NULL. This will prevent attempts to eval the accept script + * in a deleted interpreter. * *---------------------------------------------------------------------- */ static void -RegisterTcpServerInterpCleanup( - Tcl_Interp *interp, /* Interpreter for which we want to be - * informed of deletion. */ - AcceptCallback *acceptCallbackPtr) - /* The accept callback record whose interp - * field we want set to NULL when the - * interpreter is deleted. */ +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter for which we want to be + * informed of deletion. */ + AcceptCallback *acceptCallbackPtr; + /* The accept callback record whose + * interp field we want set to NULL when + * the interpreter is deleted. */ { - Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to - * smash when the interpreter will be - * deleted. */ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback + * records to smash when the interpreter + * will be deleted. */ Tcl_HashEntry *hPtr; /* Entry for this record. */ - int isNew; /* Is the entry new? */ - - hTblPtr = (Tcl_HashTable *) - Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); - - if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", - TcpAcceptCallbacksDeleteProc, hTblPtr); - } + int new; /* Is the entry new? */ - hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &isNew); - if (!isNew) { - Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); - } - Tcl_SetHashValue(hPtr, acceptCallbackPtr); + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); + if (!new) { + panic("RegisterTcpServerCleanup: damaged accept record table"); + } + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); } /* @@ -1234,41 +1094,41 @@ RegisterTcpServerInterpCleanup( * * UnregisterTcpServerInterpCleanupProc -- * - * Unregister a previously registered accept callback record. The interp - * field of this record will no longer be set to NULL in the future when - * the interpreter is deleted. + * Unregister a previously registered accept callback record. The + * interp field of this record will no longer be set to NULL in + * the future when the interpreter is deleted. * * Results: * None. * * Side effects: - * Prevents the interp field of the accept callback record from being set - * to NULL in the future when the interpreter is deleted. + * Prevents the interp field of the accept callback record from + * being set to NULL in the future when the interpreter is deleted. * *---------------------------------------------------------------------- */ static void -UnregisterTcpServerInterpCleanupProc( - Tcl_Interp *interp, /* Interpreter in which the accept callback - * record was registered. */ - AcceptCallback *acceptCallbackPtr) - /* The record for which to delete the - * registration. */ +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter in which the accept callback + * record was registered. */ + AcceptCallback *acceptCallbackPtr; + /* The record for which to delete the + * registration. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); - if (hTblPtr == NULL) { - return; + "tclTCPAcceptCallbacks", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return; } - hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; } + Tcl_DeleteHashEntry(hPtr); } /* @@ -1276,8 +1136,8 @@ UnregisterTcpServerInterpCleanupProc( * * AcceptCallbackProc -- * - * This callback is invoked by the TCP channel driver when it accepts a - * new connection from a client on a server socket. + * This callback is invoked by the TCP channel driver when it + * accepts a new connection from a client on a server socket. * * Results: * None. @@ -1289,65 +1149,72 @@ UnregisterTcpServerInterpCleanupProc( */ static void -AcceptCallbackProc( - ClientData callbackData, /* The data stored when the callback was - * created in the call to - * Tcl_OpenTcpServer. */ - Tcl_Channel chan, /* Channel for the newly accepted - * connection. */ - char *address, /* Address of client that was accepted. */ - int port) /* Port of client that was accepted. */ +AcceptCallbackProc(callbackData, chan, address, port) + ClientData callbackData; /* The data stored when the callback + * was created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan; /* Channel for the newly accepted + * connection. */ + char *address; /* Address of client that was + * accepted. */ + int port; /* Port of client that was accepted. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; + AcceptCallback *acceptCallbackPtr; + Tcl_Interp *interp; + char *script; + char portBuf[TCL_INTEGER_SPACE]; + int result; + + acceptCallbackPtr = (AcceptCallback *) callbackData; /* * Check if the callback is still valid; the interpreter may have gone * away, this is signalled by setting the interp field of the callback * data to NULL. */ + + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - if (acceptCallbackPtr->interp != NULL) { - char portBuf[TCL_INTEGER_SPACE]; - char *script = acceptCallbackPtr->script; - Tcl_Interp *interp = acceptCallbackPtr->interp; - int result; - - Tcl_Preserve(script); - Tcl_Preserve(interp); + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); TclFormatInt(portBuf, port); - Tcl_RegisterChannel(interp, chan); - - /* - * Artificially bump the refcount to protect the channel from being - * deleted while the script is being evaluated. - */ - - Tcl_RegisterChannel(NULL, chan); - - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, NULL); - if (result != TCL_OK) { - TclBackgroundException(interp, result); + Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from + * being deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); - } + } - /* - * Decrement the artificially bumped refcount. After this it is not - * safe anymore to use "chan", because it may now be deleted. - */ + /* + * Decrement the artificially bumped refcount. After this it is + * not safe anymore to use "chan", because it may now be deleted. + */ - Tcl_UnregisterChannel(NULL, chan); - - Tcl_Release(interp); - Tcl_Release(script); + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); } else { - /* - * The interpreter has been deleted, so there is no useful way to - * utilize the client socket - just close it. - */ - Tcl_Close(NULL, chan); + /* + * The interpreter has been deleted, so there is no useful + * way to utilize the client socket - just close it. + */ + + Tcl_Close((Tcl_Interp *) NULL, chan); } } @@ -1356,35 +1223,36 @@ AcceptCallbackProc( * * TcpServerCloseProc -- * - * This callback is called when the TCP server channel for which it was - * registered is being closed. It informs the interpreter in which the - * accept script is evaluated (if that interpreter still exists) that - * this channel no longer needs to be informed if the interpreter is - * deleted. + * This callback is called when the TCP server channel for which it + * was registered is being closed. It informs the interpreter in + * which the accept script is evaluated (if that interpreter still + * exists) that this channel no longer needs to be informed if the + * interpreter is deleted. * * Results: * None. * * Side effects: - * In the future, if the interpreter is deleted this channel will no - * longer be informed. + * In the future, if the interpreter is deleted this channel will + * no longer be informed. * *---------------------------------------------------------------------- */ static void -TcpServerCloseProc( - ClientData callbackData) /* The data passed in the call to - * Tcl_CreateCloseHandler. */ +TcpServerCloseProc(callbackData) + ClientData callbackData; /* The data passed in the call to + * Tcl_CreateCloseHandler. */ { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) callbackData; - /* The actual data. */ + AcceptCallback *acceptCallbackPtr; + /* The actual data. */ - if (acceptCallbackPtr->interp != NULL) { - UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, - acceptCallbackPtr); + acceptCallbackPtr = (AcceptCallback *) callbackData; + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); } - Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); ckfree((char *) acceptCallbackPtr); } @@ -1393,8 +1261,8 @@ TcpServerCloseProc( * * Tcl_SocketObjCmd -- * - * This function is invoked to process the "socket" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "socket" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1406,115 +1274,127 @@ TcpServerCloseProc( */ int -Tcl_SocketObjCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_SocketObjCmd(notUsed, interp, objc, objv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - static const char *socketOptions[] = { - "-async", "-myaddr", "-myport","-server", NULL + static CONST char *socketOptions[] = { + "-async", "-myaddr", "-myport","-server", (char *) NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; - char *host, *script = NULL, *myaddr = NULL; + int optionIndex, a, server, port; + char *arg, *copyScript, *host, *script; + char *myaddr = NULL; + int myport = 0; + int async = 0; Tcl_Channel chan; + AcceptCallback *acceptCallbackPtr; + + server = 0; + script = NULL; if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } for (a = 1; a < objc; a++) { - const char *arg = Tcl_GetString(objv[a]); - + arg = Tcl_GetString(objv[a]); if (arg[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option", - TCL_EXACT, &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, + "option", TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { - case SKT_ASYNC: - if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); - return TCL_ERROR; - } - async = 1; - break; - case SKT_MYADDR: - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", NULL); - return TCL_ERROR; + case SKT_ASYNC: { + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + break; } - 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; + case SKT_MYADDR: { + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", + (char *) NULL); + return TCL_ERROR; + } + myaddr = Tcl_GetString(objv[a]); + break; } - myPortName = TclGetString(objv[a]); - if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { - return TCL_ERROR; + case SKT_MYPORT: { + char *myPortName; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", + (char *) NULL); + return TCL_ERROR; + } + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) + != TCL_OK) { + return TCL_ERROR; + } + break; } - break; - } - case SKT_SERVER: - if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", NULL); - return TCL_ERROR; + case SKT_SERVER: { + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = Tcl_GetString(objv[a]); + break; } - server = 1; - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", NULL); - return TCL_ERROR; + default: { + panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } - script = TclGetString(objv[a]); - break; - default: - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } if (server) { - host = myaddr; /* NULL implies INADDR_ANY */ + host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { - Tcl_AppendResult(interp, "option -myport is not valid for servers", + Tcl_AppendResult(interp, "Option -myport is not valid for servers", NULL); return TCL_ERROR; } } else if (a < objc) { - host = TclGetString(objv[a]); + host = Tcl_GetString(objv[a]); a++; } else { - Interp *iPtr; - - wrongNumArgs: - iPtr = (Interp *) interp; - Tcl_WrongNumArgs(interp, 1, objv, - "?-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; - return TCL_ERROR; +wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be either:\n", + Tcl_GetString(objv[0]), + " ?-myaddr addr? ?-myport myport? ?-async? host port\n", + Tcl_GetString(objv[0]), + " -server command ?-myaddr addr? port", + (char *) NULL); + return TCL_ERROR; } if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), + "tcp", &port) != TCL_OK) { return TCL_ERROR; } } else { @@ -1522,47 +1402,46 @@ Tcl_SocketObjCmd( } if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *) - ckalloc((unsigned) sizeof(AcceptCallback)); - unsigned len = strlen(script) + 1; - char *copyScript = ckalloc(len); - - memcpy(copyScript, script, len); - acceptCallbackPtr->script = copyScript; - acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - acceptCallbackPtr); - if (chan == NULL) { - ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); - return TCL_ERROR; - } - - /* - * Register with the interpreter to let us know when the interpreter - * is deleted (by having the callback set the interp field of the - * acceptCallbackPtr's structure to NULL). This is to avoid trying to - * eval the script in a deleted interpreter. - */ - - RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); - - /* - * Register a close callback. This callback will inform the - * interpreter (if it still exists) that this channel does not need to - * be informed when the interpreter is deleted. - */ - - Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the + * interpreter is deleted (by having the callback set the + * acceptCallbackPtr->interp field to NULL). This is to + * avoid trying to eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not + * need to be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == NULL) { - return TCL_ERROR; - } - } - Tcl_RegisterChannel(interp, chan); - Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL); - + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + return TCL_OK; } @@ -1571,30 +1450,32 @@ Tcl_SocketObjCmd( * * Tcl_FcopyObjCmd -- * - * This function is invoked to process the "fcopy" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "fcopy" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Moves data between two channels and possibly sets up a background copy - * handler. + * Moves data between two channels and possibly sets up a + * background copy handler. * *---------------------------------------------------------------------- */ int -Tcl_FcopyObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_FcopyObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel inChan, outChan; - int mode, i, toRead, index; + char *arg; + int mode, i; + int toRead, index; Tcl_Obj *cmdPtr; - static const char* switches[] = { "-size", "-command", NULL }; + static CONST char* switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { @@ -1604,269 +1485,60 @@ Tcl_FcopyObjCmd( } /* - * Parse the channel arguments and verify that they are readable or - * writable, as appropriate. + * Parse the channel arguments and verify that they are readable + * or writable, as appropriate. */ - if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { + arg = Tcl_GetString(objv[1]); + inChan = Tcl_GetChannel(interp, arg, &mode); + if (inChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_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) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + arg = Tcl_GetString(objv[2]); + outChan = Tcl_GetChannel(interp, arg, &mode); + if (outChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]), - "\" wasn't opened for writing", NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", + arg, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, - &index) != TCL_OK) { + (int *) &index) != TCL_OK) { return TCL_ERROR; } switch (index) { - case FcopySize: - if (TclGetIntFromObj(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]; - break; + case FcopySize: + if (Tcl_GetIntFromObj(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]; + break; } } return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } - -/* - *--------------------------------------------------------------------------- - * - * 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 *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) == 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); - } - break; - case PENDING_OUTPUT: - if ((mode & TCL_WRITABLE) == 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); - } - break; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ChanTruncateObjCmd -- - * - * This function is invoked to process the "chan truncate" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Truncates a channel (or rather a file underlying a channel). - * - *---------------------------------------------------------------------- - */ - -static int -ChanTruncateObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Channel chan; - Tcl_WideInt length; - - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId ?length?"); - return TCL_ERROR; - } - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - return TCL_ERROR; - } - - if (objc == 3) { - /* - * User is supplying an explicit length. - */ - - if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { - return TCL_ERROR; - } - if (length < 0) { - Tcl_AppendResult(interp, - "cannot truncate to negative length of file", NULL); - return TCL_ERROR; - } - } else { - /* - * User wants to truncate to the current file position. - */ - - 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); - return TCL_ERROR; - } - } - - if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_AppendResult(interp, "error during truncate on \"", - TclGetString(objv[1]), "\": ", - Tcl_PosixError(interp), NULL); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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}, - {"close", Tcl_CloseObjCmd}, - {"copy", Tcl_FcopyObjCmd}, - {"create", TclChanCreateObjCmd}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd}, - {"event", Tcl_FileEventObjCmd}, - {"flush", Tcl_FlushObjCmd}, - {"gets", Tcl_GetsObjCmd}, - {"pending", ChanPendingObjCmd}, /* TIP #287 */ - {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ - {"puts", Tcl_PutsObjCmd}, - {"read", Tcl_ReadObjCmd}, - {"seek", Tcl_SeekObjCmd}, - {"tell", Tcl_TellObjCmd}, - {"truncate", ChanTruncateObjCmd}, /* TIP #208 */ - {NULL} - }; - static const char *extras[] = { - "configure", "::fconfigure", - "names", "::file channels", - 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: - */ |