diff options
Diffstat (limited to 'generic/tclIOCmd.c')
| -rw-r--r-- | generic/tclIOCmd.c | 782 |
1 files changed, 396 insertions, 386 deletions
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index f33bde5..7403310 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1,14 +1,14 @@ -/* +/* * 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. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.27 2005/06/07 10:05:00 dkf Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.28 2005/07/17 21:17:41 dkf Exp $ */ #include "tclInt.h" @@ -27,9 +27,9 @@ typedef struct AcceptCallback { */ static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, - Tcl_Channel chan, char *address, int port)); + Tcl_Channel chan, char *address, int port)); static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, - AcceptCallback *acceptCallbackPtr)); + AcceptCallback *acceptCallbackPtr)); static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); @@ -41,8 +41,8 @@ static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( * * Tcl_PutsObjCmd -- * - * This procedure 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. @@ -61,21 +61,21 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) 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. */ - 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. */ + 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 */ + case 3: /* [puts -nonewline $x] or [puts $chan $x] */ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 0; channelId = "stdout"; @@ -86,15 +86,15 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) 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] */ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { channelId = Tcl_GetString(objv[2]); string = objv[3]; } else { /* - * The code below provides backwards compatibility with an - * old form of the command that is no longer recommended - * or documented. + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. */ char *arg; @@ -103,8 +103,7 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) 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); + "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } channelId = Tcl_GetString(objv[1]); @@ -113,34 +112,35 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) newline = 0; break; - default: /* puts or puts some bad number of arguments... */ + default: + /* [puts] or [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); return TCL_ERROR; } chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + "\" 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; - error: + error: Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; @@ -151,8 +151,8 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) * * Tcl_FlushObjCmd -- * - * This procedure 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. @@ -171,7 +171,7 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to flush on. */ + Tcl_Channel chan; /* The channel to flush on. */ char *channelId; int mode; @@ -187,9 +187,9 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendResult(interp, "channel \"", channelId, "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } - + if (Tcl_Flush(chan) != TCL_OK) { Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", Tcl_PosixError(interp), (char *) NULL); @@ -203,8 +203,8 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) * * Tcl_GetsObjCmd -- * - * This procedure 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. @@ -223,9 +223,9 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) 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_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; @@ -241,30 +241,30 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) if ((mode & TCL_READABLE) == 0) { Tcl_AppendResult(interp, "channel \"", name, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + 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); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - lineLen = -1; + return TCL_ERROR; + } + lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linePtr); - return TCL_ERROR; - } + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; + return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } @@ -276,8 +276,8 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) * * Tcl_ReadObjCmd -- * - * This procedure 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. @@ -307,13 +307,15 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) if ((objc != 2) && (objc != 3)) { Interp *iPtr; - argerror: + argerror: iPtr = (Interp *) interp; Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?"); + /* - * Do not append directly; that makes ensembles using this - * command as a subcommand produce the wrong message. + * 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; @@ -328,7 +330,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) } if (i == objc) { - goto argerror; + goto argerror; } name = Tcl_GetString(objv[i]); @@ -337,25 +339,25 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", (char *) 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, and see whether the final - * newline should be dropped. + * Compute how many bytes to read, and see whether the final newline + * should be dropped. */ toRead = -1; if (i < objc) { 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; + return TCL_ERROR; } } else if (strcmp(arg, "nonewline") == 0) { newline = 1; @@ -363,7 +365,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; - } + } } resultPtr = Tcl_NewObj(); @@ -376,11 +378,11 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) 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; @@ -400,15 +402,15 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) * * Tcl_SeekObjCmd -- * - * This procedure 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. * *---------------------------------------------------------------------- */ @@ -455,9 +457,9 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { - Tcl_AppendResult(interp, "error during seek on \"", + Tcl_AppendResult(interp, "error during seek on \"", chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } return TCL_OK; } @@ -467,8 +469,8 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) * * Tcl_TellObjCmd -- * - * This procedure 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. @@ -494,11 +496,12 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) 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. + * Try to find a channel with the right name and permissions in the IO + * channel table of this interpreter. */ - + chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { @@ -513,8 +516,8 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) * * Tcl_CloseObjCmd -- * - * This procedure 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. @@ -548,31 +551,31 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) } 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. - */ + /* + * 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; - + resultPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } string = Tcl_GetStringFromObj(resultPtr, &len); - if ((len > 0) && (string[len - 1] == '\n')) { + if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); - } - return TCL_ERROR; + } + return TCL_ERROR; } return TCL_OK; @@ -606,46 +609,49 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) 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. */ + 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; } + chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } + if (objc == 2) { - Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &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; - } - if (objc == 3) { - Tcl_DStringInit(&ds); + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } else 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; + 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 = Tcl_GetString(objv[i-1]); valueName = Tcl_GetString(objv[i]); - if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) != TCL_OK) { - return TCL_ERROR; - } + return TCL_ERROR; + } } + return TCL_OK; } @@ -654,15 +660,15 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) * * Tcl_EofObjCmd -- * - * This procedure 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. * *--------------------------------------------------------------------------- */ @@ -681,7 +687,7 @@ Tcl_EofObjCmd(unused, interp, objc, objv) if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } arg = Tcl_GetString(objv[1]); @@ -699,8 +705,8 @@ Tcl_EofObjCmd(unused, interp, objc, objv) * * Tcl_ExecObjCmd -- * - * This procedure 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. @@ -773,13 +779,12 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) 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; @@ -798,7 +803,7 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); + (background ? 0 : TCL_STDOUT | TCL_STDERR)); /* * Free the argv array if malloc'ed storage was used. @@ -813,15 +818,15 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) } 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; } @@ -835,20 +840,21 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) 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)); /* - * 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 = Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { @@ -865,15 +871,15 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) * * Tcl_FblockedObjCmd -- * - * This procedure 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. * *--------------------------------------------------------------------------- */ @@ -892,20 +898,20 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &mode); if (chan == NULL) { - return TCL_ERROR; + return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", - arg, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } - + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); return TCL_OK; } @@ -915,8 +921,8 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) * * Tcl_OpenObjCmd -- * - * This procedure 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. @@ -966,43 +972,44 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) */ 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; - 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 = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); + 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: + Tcl_Panic("Tcl_OpenCmd: invalid mode value"); + break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree((char *) cmdArgv); + ckfree((char *) cmdArgv); } if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); @@ -1014,18 +1021,18 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) * * 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. * *---------------------------------------------------------------------- */ @@ -1034,7 +1041,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) static void TcpAcceptCallbacksDeleteProc(clientData, interp) ClientData clientData; /* Data which was passed when the assocdata - * was registered. */ + * was registered. */ Tcl_Interp *interp; /* Interpreter being deleted - not used. */ { Tcl_HashTable *hTblPtr; @@ -1044,10 +1051,10 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); - acceptCallbackPtr->interp = (Tcl_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); @@ -1058,17 +1065,16 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) * * 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. * *---------------------------------------------------------------------- */ @@ -1076,30 +1082,29 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) static void RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter for which we want to be - * informed of deletion. */ + * informed of deletion. */ AcceptCallback *acceptCallbackPtr; - /* The accept callback record whose - * interp field we want set to NULL when - * the interpreter is deleted. */ + /* 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 new; /* Is the entry new? */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", - NULL); + "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); + 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) { - Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); + Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); } @@ -1109,16 +1114,16 @@ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) * * 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. * *---------------------------------------------------------------------- */ @@ -1126,22 +1131,22 @@ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) static void UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter in which the accept callback - * record was registered. */ + * record was registered. */ AcceptCallback *acceptCallbackPtr; - /* The record for which to delete the - * registration. */ + /* The record for which to delete the + * registration. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { - return; + return; } hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); if (hPtr == (Tcl_HashEntry *) NULL) { - return; + return; } Tcl_DeleteHashEntry(hPtr); } @@ -1151,8 +1156,8 @@ UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) * * 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. @@ -1166,12 +1171,12 @@ UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) static void AcceptCallbackProc(callbackData, chan, address, port) ClientData callbackData; /* The data stored when the callback - * was created in the call to - * Tcl_OpenTcpServer. */ + * was created in the call to + * Tcl_OpenTcpServer. */ Tcl_Channel chan; /* Channel for the newly accepted - * connection. */ + * connection. */ char *address; /* Address of client that was - * accepted. */ + * accepted. */ int port; /* Port of client that was accepted. */ { AcceptCallback *acceptCallbackPtr; @@ -1187,49 +1192,49 @@ AcceptCallbackProc(callbackData, chan, address, port) * away, this is signalled by setting the interp field of the callback * data to NULL. */ - + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - script = acceptCallbackPtr->script; - interp = acceptCallbackPtr->interp; - - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) 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((Tcl_Interp *) NULL, chan); - - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, (char *) NULL); - if (result != TCL_OK) { - Tcl_BackgroundError(interp); + 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((Tcl_Interp *) NULL, chan); - - Tcl_Release((ClientData) interp); - Tcl_Release((ClientData) 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. - */ + /* + * 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); + Tcl_Close((Tcl_Interp *) NULL, chan); } } @@ -1238,18 +1243,18 @@ AcceptCallbackProc(callbackData, chan, address, port) * * 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. * *---------------------------------------------------------------------- */ @@ -1257,15 +1262,15 @@ AcceptCallbackProc(callbackData, chan, address, port) static void TcpServerCloseProc(callbackData) ClientData callbackData; /* The data passed in the call to - * Tcl_CreateCloseHandler. */ + * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr; - /* The actual data. */ + /* The actual data. */ acceptCallbackPtr = (AcceptCallback *) callbackData; if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, - acceptCallbackPtr); + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); } Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); ckfree((char *) acceptCallbackPtr); @@ -1276,8 +1281,8 @@ TcpServerCloseProc(callbackData) * * Tcl_SocketObjCmd -- * - * This procedure 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. @@ -1299,7 +1304,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) "-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, port; char *arg, *copyScript, *host, *script; @@ -1308,7 +1313,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) int async = 0; Tcl_Channel chan; AcceptCallback *acceptCallbackPtr; - + server = 0; script = NULL; @@ -1326,68 +1331,61 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { - case SKT_ASYNC: { - if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - async = 1; - break; + case SKT_ASYNC: + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) 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; + async = 1; + break; + case SKT_MYADDR: + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", (char *) NULL); + 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; + myaddr = Tcl_GetString(objv[a]); + break; + case SKT_MYPORT: { + char *myPortName; + + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", (char *) 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; + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { + return TCL_ERROR; } - default: { - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); + break; + } + 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; + 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", NULL); @@ -1397,19 +1395,21 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) host = Tcl_GetString(objv[a]); a++; } else { -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; + Interp *iPtr; + + wrongNumArgs: + 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; } if (a == objc-1) { - if (TclSockGetPort(interp, Tcl_GetString(objv[a]), - "tcp", &port) != TCL_OK) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp", + &port) != TCL_OK) { return TCL_ERROR; } } else { @@ -1417,46 +1417,46 @@ wrongNumArgs: } if (server) { - 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); + 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 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, + (ClientData) acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } } - Tcl_RegisterChannel(interp, chan); + Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); - + return TCL_OK; } @@ -1465,15 +1465,15 @@ wrongNumArgs: * * Tcl_FcopyObjCmd -- * - * This procedure 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. * *---------------------------------------------------------------------- */ @@ -1500,8 +1500,8 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) } /* - * 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. */ arg = Tcl_GetString(objv[1]); @@ -1510,9 +1510,9 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } arg = Tcl_GetString(objv[2]); outChan = Tcl_GetChannel(interp, arg, &mode); @@ -1520,9 +1520,9 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } toRead = -1; @@ -1533,14 +1533,14 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch (index) { - case FcopySize: - if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { - return TCL_ERROR; - } - break; - case FcopyCommand: - cmdPtr = objv[i+1]; - break; + case FcopySize: + if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + return TCL_ERROR; + } + break; + case FcopyCommand: + cmdPtr = objv[i+1]; + break; } } @@ -1590,6 +1590,7 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) /* * User is supplying an explicit length. */ + if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } @@ -1602,6 +1603,7 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) /* * User wants to truncate to the current file position. */ + length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { Tcl_AppendResult(interp, @@ -1619,3 +1621,11 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |