diff options
Diffstat (limited to 'tcl8.6/generic/tclIOCmd.c')
| -rw-r--r-- | tcl8.6/generic/tclIOCmd.c | 2027 |
1 files changed, 0 insertions, 2027 deletions
diff --git a/tcl8.6/generic/tclIOCmd.c b/tcl8.6/generic/tclIOCmd.c deleted file mode 100644 index 834f225..0000000 --- a/tcl8.6/generic/tclIOCmd.c +++ /dev/null @@ -1,2027 +0,0 @@ -/* - * 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. - */ - -#include "tclInt.h" - -/* - * Callback structure for accept callback in a TCP server. - */ - -typedef struct AcceptCallback { - char *script; /* Script to invoke. */ - Tcl_Interp *interp; /* Interpreter in which to run it. */ -} AcceptCallback; - -/* - * Thread local storage used to maintain a per-thread stdout channel obj. - * It must be per-thread because of std channel limitations. - */ - -typedef struct ThreadSpecificData { - int initialized; /* Set to 1 when the module is initialized. */ - Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * Static functions for this file: - */ - -static void 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; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_PutsObjCmd -- - * - * This function is invoked to process the "puts" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Produces output on a channel. - * - *---------------------------------------------------------------------- - */ - - /* 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_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; - - switch (objc) { - case 2: /* [puts $x] */ - string = objv[1]; - newline = 1; - break; - - case 3: /* [puts -nonewline $x] or [puts $chan $x] */ - if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { - newline = 0; - } else { - newline = 1; - chanObjPtr = 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]; - string = objv[3]; - break; -#if TCL_MAJOR_VERSION < 9 - } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { - /* - * The code below provides backwards compatibility with an old - * form of the command that is no longer recommended or - * documented. See also [Bug #3151675]. Will be removed in Tcl 9, - * maybe even earlier. - */ - - chanObjPtr = objv[1]; - string = objv[2]; - break; -#endif - } - /* Fall through */ - 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; - } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(chanObjPtr))); - return TCL_ERROR; - } - - TclChannelPreserve(chan); - result = Tcl_WriteObj(chan, string); - if (result < 0) { - goto error; - } - if (newline != 0) { - result = Tcl_WriteChars(chan, "\n", 1); - if (result < 0) { - goto error; - } - } - TclChannelRelease(chan); - 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_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); - } - TclChannelRelease(chan); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FlushObjCmd -- - * - * This function is called to process the Tcl "flush" command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May cause output to appear on the specified channel. - * - *---------------------------------------------------------------------- - */ - - /* 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_Obj *chanObjPtr; - Tcl_Channel chan; /* The channel to flush on. */ - 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) { - return TCL_ERROR; - } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(chanObjPtr))); - return TCL_ERROR; - } - - TclChannelPreserve(chan); - if (Tcl_Flush(chan) != TCL_OK) { - /* - * TIP #219. - * Capture error messages put by the driver into the bypass area and - * put them into the regular interpreter result. Fall back to the - * regular message if nothing was found in the bypass. - */ - - if (!TclChanCaughtErrorBypass(interp, chan)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error flushing \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); - } - TclChannelRelease(chan); - return TCL_ERROR; - } - TclChannelRelease(chan); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetsObjCmd -- - * - * This function is called to process the Tcl "gets" command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May consume input from channel. - * - *---------------------------------------------------------------------- - */ - - /* 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_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; - int code = TCL_OK; - - 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) { - return TCL_ERROR; - } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(chanObjPtr))); - return TCL_ERROR; - } - - TclChannelPreserve(chan); - linePtr = Tcl_NewObj(); - lineLen = Tcl_GetsObj(chan, linePtr); - if (lineLen < 0) { - if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - 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_SetObjResult(interp, Tcl_ObjPrintf( - "error reading \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); - } - code = TCL_ERROR; - goto done; - } - lineLen = -1; - } - if (objc == 3) { - if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, - TCL_LEAVE_ERR_MSG) == NULL) { - code = TCL_ERROR; - goto done; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - } else { - Tcl_SetObjResult(interp, linePtr); - } - done: - TclChannelRelease(chan); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ReadObjCmd -- - * - * This function is invoked to process the Tcl "read" command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May consume input from channel. - * - *---------------------------------------------------------------------- - */ - - /* 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_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; - - if ((objc != 2) && (objc != 3)) { - Interp *iPtr; - - 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. - */ - - iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; - Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); - return TCL_ERROR; - } - - i = 1; - newline = 0; - if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { - newline = 1; - i++; - } - - if (i == objc) { - goto argerror; - } - - chanObjPtr = objv[i]; - if (TclGetChannelFromObj(interp, chanObjPtr, &chan, &mode, 0) != TCL_OK) { - return TCL_ERROR; - } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(chanObjPtr))); - return TCL_ERROR; - } - i++; /* Consumed channel name. */ - - /* - * Compute how many bytes to read. - */ - - toRead = -1; - if (i < objc) { - if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) - || (toRead < 0)) { -#if TCL_MAJOR_VERSION < 9 - /* - * The code below provides backwards compatibility with an old - * form of the command that is no longer recommended or - * documented. See also [Bug #3151675]. Will be removed in Tcl 9, - * maybe even earlier. - */ - - if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { -#endif - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected non-negative integer but got \"%s\"", - TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); - return TCL_ERROR; -#if TCL_MAJOR_VERSION < 9 - } - newline = 1; -#endif - } - } - - resultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(resultPtr); - TclChannelPreserve(chan); - 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_SetObjResult(interp, Tcl_ObjPrintf( - "error reading \"%s\": %s", - TclGetString(chanObjPtr), Tcl_PosixError(interp))); - } - TclChannelRelease(chan); - Tcl_DecrRefCount(resultPtr); - return TCL_ERROR; - } - - /* - * If requested, remove the last newline in the channel if at EOF. - */ - - if ((charactersRead > 0) && (newline != 0)) { - const char *result; - int length; - - result = TclGetStringFromObj(resultPtr, &length); - if (result[length - 1] == '\n') { - Tcl_SetObjLength(resultPtr, length - 1); - } - } - Tcl_SetObjResult(interp, resultPtr); - TclChannelRelease(chan); - Tcl_DecrRefCount(resultPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SeekObjCmd -- - * - * This function 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. - * - *---------------------------------------------------------------------- - */ - - /* 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_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. */ - int optionIndex; - static const char *const originOptions[] = { - "start", "current", "end", NULL - }; - static const int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); - return TCL_ERROR; - } - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - return TCL_ERROR; - } - if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { - return TCL_ERROR; - } - mode = SEEK_SET; - if (objc == 4) { - if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0, - &optionIndex) != TCL_OK) { - return TCL_ERROR; - } - mode = modeArray[optionIndex]; - } - - TclChannelPreserve(chan); - 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_SetObjResult(interp, Tcl_ObjPrintf( - "error during seek on \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); - } - TclChannelRelease(chan); - return TCL_ERROR; - } - TclChannelRelease(chan); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_TellObjCmd -- - * - * This function is invoked to process the Tcl "tell" command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* 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_Channel chan; /* The channel to tell on. */ - Tcl_WideInt newLoc; - int code; - - 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; - } - - TclChannelPreserve(chan); - 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. - */ - - - code = TclChanCaughtErrorBypass(interp, chan); - TclChannelRelease(chan); - if (code) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CloseObjCmd -- - * - * This function is invoked to process the Tcl "close" command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May discard queued input; may flush queued output. - * - *---------------------------------------------------------------------- - */ - - /* 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_Channel chan; /* The channel to close. */ - static const char *const dirOptions[] = { - "read", "write", NULL - }; - static const int dirArray[] = {TCL_CLOSE_READ, TCL_CLOSE_WRITE}; - - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId ?direction?"); - return TCL_ERROR; - } - - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - return TCL_ERROR; - } - - if (objc == 3) { - int index, dir; - - /* - * Get direction requested to close, and check syntax. - */ - - if (Tcl_GetIndexFromObj(interp, objv[2], dirOptions, "direction", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - dir = dirArray[index]; - - /* - * Check direction against channel mode. It is an error if we try to - * close a direction not supported by the channel (already closed, or - * never opened for that direction). - */ - - if (!(dir & Tcl_GetChannelMode(chan))) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Half-close of %s-side not possible, side not opened" - " or already closed", dirOptions[index])); - return TCL_ERROR; - } - - /* - * Special handling is needed if and only if the channel mode supports - * more than the direction to close. Because if the close the last - * direction suppported we can and will go through the regular - * process. - */ - - if ((Tcl_GetChannelMode(chan) & - (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) { - return Tcl_CloseEx(interp, chan, dir); - } - } - - if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { - /* - * If there is an error message and it ends with a newline, remove the - * 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); - const 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')) { - Tcl_SetObjLength(resultPtr, len - 1); - } - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FconfigureObjCmd -- - * - * This function is invoked to process the Tcl "fconfigure" command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May modify the behavior of an IO channel. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_FconfigureObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - const char *optionName, *valueName; - Tcl_Channel chan; /* The channel to set a mode on. */ - int i; /* Iterate over arg-value pairs. */ - - if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId ?-option value ...?"); - return TCL_ERROR; - } - - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - 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_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) - != TCL_OK) { - return TCL_ERROR; - } - } - - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_EofObjCmd -- - * - * This function 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. - * - *--------------------------------------------------------------------------- - */ - - /* 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_Channel chan; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; - } - - if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) { - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_Eof(chan))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ExecObjCmd -- - * - * This function is invoked to process the "exec" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* 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_Obj *resultPtr; - const char **argv; /* An array for the string arguments. Stored - * on the _Tcl_ stack. */ - const char *string; - Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, length; - int ignoreStderr; - static const char *const options[] = { - "-ignorestderr", "-keepnewline", "--", NULL - }; - enum options { - EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST - }; - - /* - * Check for any leading option arguments. - */ - - keepNewline = 0; - ignoreStderr = 0; - for (skip = 1; skip < objc; skip++) { - string = TclGetString(objv[skip]); - if (string[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == EXEC_KEEPNEWLINE) { - keepNewline = 1; - } else if (index == EXEC_IGNORESTDERR) { - ignoreStderr = 1; - } else { - skip++; - break; - } - } - if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); - return TCL_ERROR; - } - - /* - * See if the command is to be run in background. - */ - - background = 0; - string = TclGetString(objv[objc - 1]); - if ((string[0] == '&') && (string[1] == '\0')) { - objc--; - 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. - */ - - argc = objc - skip; - argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); - - /* - * Copy the string conversions of each (post option) object into the - * argument vector. - */ - - for (i = 0; i < argc; i++) { - argv[i] = TclGetString(objv[i + skip]); - } - argv[argc] = NULL; - chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 : - ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)); - - /* - * Free the argv array. - */ - - TclStackFree(interp, (void *) argv); - - if (chan == 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) { - 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_SetObjResult(interp, Tcl_ObjPrintf( - "error reading output from command: %s", - Tcl_PosixError(interp))); - 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. - */ - - 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 (keepNewline == 0) { - string = TclGetStringFromObj(resultPtr, &length); - if ((length > 0) && (string[length - 1] == '\n')) { - Tcl_SetObjLength(resultPtr, length - 1); - } - } - Tcl_SetObjResult(interp, resultPtr); - - return result; -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_FblockedObjCmd -- - * - * This function 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. - * - *--------------------------------------------------------------------------- - */ - - /* 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_Channel chan; - int mode; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; - } - - if (TclGetChannelFromObj(interp, objv[1], &chan, &mode, 0) != TCL_OK) { - return TCL_ERROR; - } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(objv[1]))); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_OpenObjCmd -- - * - * This function is invoked to process the "open" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_OpenObjCmd( - 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; - Tcl_Channel chan; - - if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); - return TCL_ERROR; - } - prot = 0666; - if (objc == 2) { - modeString = "r"; - } else { - modeString = TclGetString(objv[2]); - if (objc == 4) { - const char *permString = TclGetString(objv[3]); - int code = TCL_ERROR; - int scanned = TclParseAllWhiteSpace(permString, -1); - - /* - * Support legacy octal numbers. - */ - - if ((permString[scanned] == '0') - && (permString[scanned+1] >= '0') - && (permString[scanned+1] <= '7')) { - Tcl_Obj *permObj; - - TclNewLiteralStringObj(permObj, "0o"); - Tcl_AppendToObj(permObj, permString+scanned+1, -1); - code = TclGetIntFromObj(NULL, permObj, &prot); - Tcl_DecrRefCount(permObj); - } - - if ((code == TCL_ERROR) - && TclGetIntFromObj(interp, objv[3], &prot) != TCL_OK) { - return TCL_ERROR; - } - } - } - - pipeline = 0; - what = TclGetString(objv[1]); - if (what[0] == '|') { - pipeline = 1; - } - - /* - * Open the file or create a process pipeline. - */ - - if (!pipeline) { - 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; - } - - mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); - if (mode == -1) { - chan = NULL; - } 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; - } - chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); - if (binary && chan) { - Tcl_SetChannelOption(interp, chan, "-translation", "binary"); - } - } - ckfree(cmdArgv); - } - if (chan == NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(interp, chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - * 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. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -TcpAcceptCallbacksDeleteProc( - ClientData clientData, /* Data which was passed when the assocdata - * was registered. */ - Tcl_Interp *interp) /* Interpreter being deleted - not used. */ -{ - Tcl_HashTable *hTblPtr = clientData; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - AcceptCallback *acceptCallbackPtr = Tcl_GetHashValue(hPtr); - - acceptCallbackPtr->interp = NULL; - } - Tcl_DeleteHashTable(hTblPtr); - ckfree(hTblPtr); -} - -/* - *---------------------------------------------------------------------- - * - * RegisterTcpServerInterpCleanup -- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - 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_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); - - if (hTblPtr == NULL) { - hTblPtr = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", - TcpAcceptCallbacksDeleteProc, hTblPtr); - } - - hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew); - if (!isNew) { - Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); - } - Tcl_SetHashValue(hPtr, 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. - * - * 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. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - - hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); - if (hTblPtr == NULL) { - return; - } - - hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * AcceptCallbackProc -- - * - * This callback is invoked by the TCP channel driver when it accepts a - * new connection from a client on a server socket. - * - * Results: - * None. - * - * Side effects: - * Whatever the script does. - * - *---------------------------------------------------------------------- - */ - -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. */ -{ - AcceptCallback *acceptCallbackPtr = 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 != NULL) { - char portBuf[TCL_INTEGER_SPACE]; - char *script = acceptCallbackPtr->script; - Tcl_Interp *interp = acceptCallbackPtr->interp; - int result; - - Tcl_Preserve(script); - Tcl_Preserve(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) { - Tcl_BackgroundException(interp, result); - 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. - */ - - Tcl_UnregisterChannel(NULL, chan); - - Tcl_Release(interp); - Tcl_Release(script); - } else { - /* - * The interpreter has been deleted, so there is no useful way to use - * the client socket - just close it. - */ - - Tcl_Close(NULL, chan); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - * Results: - * None. - * - * Side effects: - * 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. */ -{ - AcceptCallback *acceptCallbackPtr = callbackData; - /* The actual data. */ - - if (acceptCallbackPtr->interp != NULL) { - UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, - acceptCallbackPtr); - } - Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); - ckfree(acceptCallbackPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SocketObjCmd -- - * - * This function is invoked to process the "socket" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates a socket based channel. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_SocketObjCmd( - ClientData notUsed, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", NULL - }; - enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER - }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; - const char *host, *script = NULL, *myaddr = NULL; - Tcl_Channel chan; - - if (TclpHasSockets(interp) != TCL_OK) { - return TCL_ERROR; - } - - for (a = 1; a < objc; a++) { - const char *arg = Tcl_GetString(objv[a]); - - if (arg[0] != '-') { - break; - } - 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_SetObjResult(interp, Tcl_NewStringObj( - "cannot set -async option for server sockets", -1)); - return TCL_ERROR; - } - async = 1; - break; - case SKT_MYADDR: - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -myaddr option", -1)); - return TCL_ERROR; - } - myaddr = TclGetString(objv[a]); - break; - case SKT_MYPORT: { - const char *myPortName; - - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -myport option", -1)); - return TCL_ERROR; - } - myPortName = TclGetString(objv[a]); - if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { - return TCL_ERROR; - } - break; - } - case SKT_SERVER: - if (async == 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot set -async option for server sockets", -1)); - return TCL_ERROR; - } - server = 1; - a++; - if (a >= objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "no argument given for -server option", -1)); - return TCL_ERROR; - } - script = TclGetString(objv[a]); - break; - default: - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); - } - } - if (server) { - host = myaddr; /* NULL implies INADDR_ANY */ - if (myport != 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "option -myport is not valid for servers", -1)); - return TCL_ERROR; - } - } else if (a < objc) { - host = TclGetString(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"); - return TCL_ERROR; - } - - if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { - goto wrongNumArgs; - } - - if (server) { - AcceptCallback *acceptCallbackPtr = - ckalloc(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(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); - } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == NULL) { - return TCL_ERROR; - } - } - - Tcl_RegisterChannel(interp, chan); - Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_FcopyObjCmd -- - * - * This function 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. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_FcopyObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Channel inChan, outChan; - int mode, i, index; - Tcl_WideInt toRead; - Tcl_Obj *cmdPtr; - static const char *const switches[] = { "-size", "-command", NULL }; - enum { FcopySize, FcopyCommand }; - - if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { - Tcl_WrongNumArgs(interp, 1, objv, - "input output ?-size size? ?-command callback?"); - return TCL_ERROR; - } - - /* - * Parse the channel arguments and verify that they are readable or - * writable, as appropriate. - */ - - if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) { - return TCL_ERROR; - } - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for reading", - TclGetString(objv[1]))); - return TCL_ERROR; - } - if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) { - return TCL_ERROR; - } - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "channel \"%s\" wasn't opened for writing", - TclGetString(objv[2]))); - return TCL_ERROR; - } - - toRead = -1; - cmdPtr = NULL; - for (i = 3; i < objc; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case FcopySize: - if (Tcl_GetWideIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { - return TCL_ERROR; - } - if (toRead < 0) { - /* - * Handle all negative sizes like -1, meaning 'copy all'. By - * resetting toRead we avoid changes in the core copying - * functions (which explicitly check for -1 and crash on any - * other negative value). - */ - - toRead = -1; - } - break; - case FcopyCommand: - cmdPtr = objv[i+1]; - 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 *const options[] = {"input", "output", NULL}; - enum options {PENDING_INPUT, PENDING_OUTPUT}; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum options) index) { - case PENDING_INPUT: - if (!(mode & TCL_READABLE)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan))); - } - break; - case PENDING_OUTPUT: - if (!(mode & TCL_WRITABLE)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan))); - } - break; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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_SetObjResult(interp, Tcl_NewStringObj( - "cannot truncate to negative length of file", -1)); - return TCL_ERROR; - } - } else { - /* - * User wants to truncate to the current file position. - */ - - length = Tcl_Tell(chan); - if (length == Tcl_WideAsLong(-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not determine current location in \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); - return TCL_ERROR; - } - } - - if (Tcl_TruncateChannel(chan, length) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error during truncate on \"%s\": %s", - TclGetString(objv[1]), Tcl_PosixError(interp))); - return TCL_ERROR; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ChanPipeObjCmd -- - * - * This function is invoked to process the "chan pipe" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates a pair of Tcl channels wrapping both ends of a new - * anonymous pipe. - * - *---------------------------------------------------------------------- - */ - -static int -ChanPipeObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Channel rchan, wchan; - const char *channelNames[2]; - Tcl_Obj *resultPtr; - - if (objc != 1) { - Tcl_WrongNumArgs(interp, 1, objv, ""); - return TCL_ERROR; - } - - if (Tcl_CreatePipe(interp, &rchan, &wchan, 0) != TCL_OK) { - return TCL_ERROR; - } - - channelNames[0] = Tcl_GetChannelName(rchan); - channelNames[1] = Tcl_GetChannelName(wchan); - - resultPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(channelNames[0], -1)); - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(channelNames[1], -1)); - Tcl_SetObjResult(interp, resultPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclChannelNamesCmd -- - * - * This function is invoked to process the "chan names" and "file - * channels" Tcl commands. See the user documentation for details on - * what they do. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclChannelNamesCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - if (objc < 1 || objc > 2) { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; - } - return Tcl_GetChannelNamesEx(interp, - ((objc == 1) ? NULL : TclGetString(objv[1]))); -} - -/* - *---------------------------------------------------------------------- - * - * TclInitChanCmd -- - * - * This function is invoked to create the "chan" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A Tcl command handle. - * - * Side effects: - * None (since nothing is byte-compiled). - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitChanCmd( - Tcl_Interp *interp) -{ - /* - * Most commands are plugged directly together, but some are done via - * alias-like rewriting; [chan configure] is this way for security reasons - * (want overwriting of [fconfigure] to control that nicely), and [chan - * names] because the functionality isn't available as a separate command - * function at the moment. - */ - static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, - {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, - {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */ - {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */ - {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ - {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, - {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, - {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */ - {NULL, NULL, NULL, NULL, NULL, 0} - }; - static const char *const extras[] = { - "configure", "::fconfigure", - NULL - }; - Tcl_Command ensemble; - Tcl_Obj *mapObj; - int i; - - ensemble = TclMakeEnsemble(interp, "chan", initMap); - Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); - for (i=0 ; extras[i] ; i+=2) { - /* - * Can assume that reference counts are all incremented. - */ - - Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj(extras[i], -1), - Tcl_NewStringObj(extras[i+1], -1)); - } - Tcl_SetEnsembleMappingDict(interp, ensemble, mapObj); - return ensemble; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |