summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
authorhobbs <hobbs>2000-05-19 21:30:15 (GMT)
committerhobbs <hobbs>2000-05-19 21:30:15 (GMT)
commit3140106e88c21ed304344360760f7bba8f54e7fc (patch)
tree4fb1f802b2917d98a9bf73ee85bd09237045cfbe /generic/tclTest.c
parentf7b89504bf385e5b1901c3ca9b75b5241e31ca21 (diff)
downloadtcl-3140106e88c21ed304344360760f7bba8f54e7fc.zip
tcl-3140106e88c21ed304344360760f7bba8f54e7fc.tar.gz
tcl-3140106e88c21ed304344360760f7bba8f54e7fc.tar.bz2
* generic/tclTest.c:
* generic/tclIO.c: moved channel test commands from tclIO.c to tclTest.c. * generic/tclIO.h: new file, split out from tclIO.c to allow test commands to be moved to tclTest.c. * generic/tclStubInit.c: * generic/tclIntDecls.h: * generic/tclInt.decls: removed TclTestChannel*Cmd from internal stubs table and added TclChannelEventScriptInvoker to the internal stubs table so it can be used from the test code.
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c607
1 files changed, 603 insertions, 4 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 2eccc08..dd9730c 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -8,22 +8,35 @@
*
* Copyright (c) 1993-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.17 1999/10/13 02:22:18 hobbs Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.18 2000/05/19 21:30:16 hobbs Exp $
*/
#define TCL_TEST
#include "tclInt.h"
#include "tclPort.h"
+
+/*
+ * Required for Testregexp*Cmd
+ */
#include "tclRegexp.h"
+
+/*
+ * Required for TestlocaleCmd
+ */
#include <locale.h>
/*
+ * Required for the TestChannelCmd and TestChannelEventCmd
+ */
+#include "tclIO.h"
+
+/*
* Declare external functions used in Windows tests.
*/
@@ -277,6 +290,11 @@ static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, char **argv));
+static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, char **argv));
+
/*
* External (platform specific) initialization routine, these declarations
* explicitly don't use EXTERN since this code does not get compiled
@@ -329,9 +347,9 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd,
+ Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd,
+ Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
@@ -4242,3 +4260,584 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
return (NULL);
}
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestChannelCmd --
+ *
+ * Implements the Tcl "testchannel" debugging command and its
+ * subcommands. This is part of the testing environment but must be
+ * in this file instead of tclTest.c because it needs access to the
+ * fields of struct Channel.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestChannelCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Interpreter for result. */
+ int argc; /* Count of additional args. */
+ char **argv; /* Additional arg strings. */
+{
+ char *cmdName; /* Sub command. */
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashSearch hSearch; /* Search variable. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Channel *chanPtr; /* The actual channel. */
+ Tcl_Channel chan = NULL; /* The opaque type. */
+ size_t len; /* Length of subcommand string. */
+ int IOQueued; /* How much IO is queued inside channel? */
+ ChannelBuffer *bufPtr; /* For iterating over queued IO. */
+ char buf[TCL_INTEGER_SPACE];/* For sprintf. */
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " subcommand ?additional args..?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ cmdName = argv[1];
+ len = strlen(cmdName);
+
+ chanPtr = (Channel *) NULL;
+
+ if (argc > 2) {
+ chan = Tcl_GetChannel(interp, argv[2], NULL);
+ if (chan == (Tcl_Channel) NULL) {
+ return TCL_ERROR;
+ }
+ chanPtr = (Channel *) chan;
+ }
+
+ if ((cmdName[0] == 'c') &&
+ (strncmp(cmdName, "cut", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_CutChannel (chan);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'c') &&
+ (strncmp(cmdName, "forgetch", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_ClearChannelHandlers (chan);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " info channelName\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, argv[2]);
+ Tcl_AppendElement(interp, chanPtr->typePtr->typeName);
+ if (chanPtr->flags & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (chanPtr->flags & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (chanPtr->flags & CHANNEL_NONBLOCKING) {
+ Tcl_AppendElement(interp, "nonblocking");
+ } else {
+ Tcl_AppendElement(interp, "blocking");
+ }
+ if (chanPtr->flags & CHANNEL_LINEBUFFERED) {
+ Tcl_AppendElement(interp, "line");
+ } else if (chanPtr->flags & CHANNEL_UNBUFFERED) {
+ Tcl_AppendElement(interp, "none");
+ } else {
+ Tcl_AppendElement(interp, "full");
+ }
+ if (chanPtr->flags & BG_FLUSH_SCHEDULED) {
+ Tcl_AppendElement(interp, "async_flush");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (chanPtr->flags & CHANNEL_EOF) {
+ Tcl_AppendElement(interp, "eof");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (chanPtr->flags & CHANNEL_BLOCKED) {
+ Tcl_AppendElement(interp, "blocked");
+ } else {
+ Tcl_AppendElement(interp, "unblocked");
+ }
+ if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) {
+ Tcl_AppendElement(interp, "auto");
+ if (chanPtr->flags & INPUT_SAW_CR) {
+ Tcl_AppendElement(interp, "saw_cr");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ } else if (chanPtr->inputTranslation == TCL_TRANSLATE_LF) {
+ Tcl_AppendElement(interp, "lf");
+ Tcl_AppendElement(interp, "");
+ } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) {
+ Tcl_AppendElement(interp, "cr");
+ Tcl_AppendElement(interp, "");
+ } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) {
+ Tcl_AppendElement(interp, "crlf");
+ if (chanPtr->flags & INPUT_SAW_CR) {
+ Tcl_AppendElement(interp, "queued_cr");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ }
+ if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) {
+ Tcl_AppendElement(interp, "auto");
+ } else if (chanPtr->outputTranslation == TCL_TRANSLATE_LF) {
+ Tcl_AppendElement(interp, "lf");
+ } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) {
+ Tcl_AppendElement(interp, "cr");
+ } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) {
+ Tcl_AppendElement(interp, "crlf");
+ }
+ for (IOQueued = 0, bufPtr = chanPtr->inQueueHead;
+ bufPtr != (ChannelBuffer *) NULL;
+ bufPtr = bufPtr->nextPtr) {
+ IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
+ }
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendElement(interp, buf);
+
+ IOQueued = 0;
+ if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) {
+ IOQueued = chanPtr->curOutPtr->nextAdded -
+ chanPtr->curOutPtr->nextRemoved;
+ }
+ for (bufPtr = chanPtr->outQueueHead;
+ bufPtr != (ChannelBuffer *) NULL;
+ bufPtr = bufPtr->nextPtr) {
+ IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
+ }
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendElement(interp, buf);
+
+ TclFormatInt(buf, Tcl_Tell((Tcl_Channel) chanPtr));
+ Tcl_AppendElement(interp, buf);
+
+ TclFormatInt(buf, chanPtr->refCount);
+ Tcl_AppendElement(interp, buf);
+
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'i') &&
+ (strncmp(cmdName, "inputbuffered", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ for (IOQueued = 0, bufPtr = chanPtr->inQueueHead;
+ bufPtr != (ChannelBuffer *) NULL;
+ bufPtr = bufPtr->nextPtr) {
+ IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
+ }
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'i') &&
+ (strncmp(cmdName, "isshared", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, Tcl_IsChannelShared (chan));
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (chanPtr->flags & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (chanPtr->flags & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, chanPtr->channelName, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) {
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ return TCL_OK;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != (Tcl_HashEntry *) NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'o') &&
+ (strncmp(cmdName, "outputbuffered", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ IOQueued = 0;
+ if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) {
+ IOQueued = chanPtr->curOutPtr->nextAdded -
+ chanPtr->curOutPtr->nextRemoved;
+ }
+ for (bufPtr = chanPtr->outQueueHead;
+ bufPtr != (ChannelBuffer *) NULL;
+ bufPtr = bufPtr->nextPtr) {
+ IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
+ }
+ TclFormatInt(buf, IOQueued);
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'q') &&
+ (strncmp(cmdName, "queuedcr", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendResult(interp,
+ (chanPtr->flags & INPUT_SAW_CR) ? "1" : "0",
+ (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) {
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ return TCL_OK;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != (Tcl_HashEntry *) NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
+ if (chanPtr->flags & TCL_READABLE) {
+ Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+ }
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, chanPtr->refCount);
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'c') &&
+ (strncmp(cmdName, "splice", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SpliceChannel (chan);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, chanPtr->typePtr->typeName, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) {
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ return TCL_OK;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != (Tcl_HashEntry *) NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
+ if (chanPtr->flags & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+ }
+ }
+ return TCL_OK;
+ }
+
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",
+ "info, open, readable, or writable",
+ (char *) NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestChannelEventCmd --
+ *
+ * This procedure implements the "testchannelevent" command. It is
+ * used to test the Tcl channel event mechanism. It is present in
+ * this file instead of tclTest.c because it needs access to the
+ * internal structure of the channel.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates, deletes and returns channel event handlers.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestChannelEventCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tcl_Obj *resultListPtr;
+ Channel *chanPtr;
+ EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
+ char *cmd;
+ int index, i, mask, len;
+
+ if ((argc < 3) || (argc > 5)) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL);
+ if (chanPtr == (Channel *) NULL) {
+ return TCL_ERROR;
+ }
+ cmd = argv[2];
+ len = strlen(cmd);
+ if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) {
+ if (argc != 5) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName add eventSpec script\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (strcmp(argv[3], "readable") == 0) {
+ mask = TCL_READABLE;
+ } else if (strcmp(argv[3], "writable") == 0) {
+ mask = TCL_WRITABLE;
+ } else if (strcmp(argv[3], "none") == 0) {
+ mask = 0;
+ } else {
+ Tcl_AppendResult(interp, "bad event name \"", argv[3],
+ "\": must be readable, writable, or none", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ esPtr = (EventScriptRecord *) ckalloc((unsigned)
+ sizeof(EventScriptRecord));
+ esPtr->nextPtr = chanPtr->scriptRecordPtr;
+ chanPtr->scriptRecordPtr = esPtr;
+
+ esPtr->chanPtr = chanPtr;
+ esPtr->interp = interp;
+ esPtr->mask = mask;
+ esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
+ Tcl_IncrRefCount(esPtr->scriptPtr);
+
+ Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
+
+ return TCL_OK;
+ }
+
+ if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) {
+ if (argc != 4) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName delete index\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ Tcl_AppendResult(interp, "bad event index: ", argv[3],
+ ": must be nonnegative", (char *) NULL);
+ return TCL_ERROR;
+ }
+ for (i = 0, esPtr = chanPtr->scriptRecordPtr;
+ (i < index) && (esPtr != (EventScriptRecord *) NULL);
+ i++, esPtr = esPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (esPtr == (EventScriptRecord *) NULL) {
+ Tcl_AppendResult(interp, "bad event index ", argv[3],
+ ": out of range", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (esPtr == chanPtr->scriptRecordPtr) {
+ chanPtr->scriptRecordPtr = esPtr->nextPtr;
+ } else {
+ for (prevEsPtr = chanPtr->scriptRecordPtr;
+ (prevEsPtr != (EventScriptRecord *) NULL) &&
+ (prevEsPtr->nextPtr != esPtr);
+ prevEsPtr = prevEsPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (prevEsPtr == (EventScriptRecord *) NULL) {
+ panic("TclTestChannelEventCmd: damaged event script list");
+ }
+ prevEsPtr->nextPtr = esPtr->nextPtr;
+ }
+ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
+ Tcl_DecrRefCount(esPtr->scriptPtr);
+ ckfree((char *) esPtr);
+
+ return TCL_OK;
+ }
+
+ if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName list\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ resultListPtr = Tcl_GetObjResult(interp);
+ for (esPtr = chanPtr->scriptRecordPtr;
+ esPtr != (EventScriptRecord *) NULL;
+ esPtr = esPtr->nextPtr) {
+ if (esPtr->mask) {
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
+ } else {
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ Tcl_NewStringObj("none", -1));
+ }
+ Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
+ }
+ Tcl_SetObjResult(interp, resultListPtr);
+ return TCL_OK;
+ }
+
+ if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName removeall\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ for (esPtr = chanPtr->scriptRecordPtr;
+ esPtr != (EventScriptRecord *) NULL;
+ esPtr = nextEsPtr) {
+ nextEsPtr = esPtr->nextPtr;
+ Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
+ Tcl_DecrRefCount(esPtr->scriptPtr);
+ ckfree((char *) esPtr);
+ }
+ chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL;
+ return TCL_OK;
+ }
+
+ if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) {
+ if (argc != 5) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " channelName delete index event\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (index < 0) {
+ Tcl_AppendResult(interp, "bad event index: ", argv[3],
+ ": must be nonnegative", (char *) NULL);
+ return TCL_ERROR;
+ }
+ for (i = 0, esPtr = chanPtr->scriptRecordPtr;
+ (i < index) && (esPtr != (EventScriptRecord *) NULL);
+ i++, esPtr = esPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (esPtr == (EventScriptRecord *) NULL) {
+ Tcl_AppendResult(interp, "bad event index ", argv[3],
+ ": out of range", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[4], "readable") == 0) {
+ mask = TCL_READABLE;
+ } else if (strcmp(argv[4], "writable") == 0) {
+ mask = TCL_WRITABLE;
+ } else if (strcmp(argv[4], "none") == 0) {
+ mask = 0;
+ } else {
+ Tcl_AppendResult(interp, "bad event name \"", argv[4],
+ "\": must be readable, writable, or none", (char *) NULL);
+ return TCL_ERROR;
+ }
+ esPtr->mask = mask;
+ Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
+ TclChannelEventScriptInvoker, (ClientData) esPtr);
+ return TCL_OK;
+ }
+ Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
+ "add, delete, list, set, or removeall", (char *) NULL);
+ return TCL_ERROR;
+}