* merged core-8-3-1-io-rewrite back into core-8-3-1-branch.

	The core-8-3-1-io-rewrite branch should now be considered defunct.

1 files changed, 581 insertions, 4 deletions

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 2eccc08..1e98921 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -8,12 +8,12 @@
  *
  * 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 Ajuba Solutions.
  *
  * 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.17.2.1 2000/07/27 01:39:19 hobbs Exp $
  */
 
 #define TCL_TEST
@@ -21,6 +21,7 @@
 #include "tclInt.h"
 #include "tclPort.h"
 #include "tclRegexp.h"
+#include "tclIO.h"
 #include <locale.h>
 
 /*
@@ -276,6 +277,10 @@ static int		TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
 			    Tcl_Interp *interp, int argc, char **argv));
 static int		TestupvarCmd _ANSI_ARGS_((ClientData dummy,
 			    Tcl_Interp *interp, int argc, char **argv));
+static int		TestChannelCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
+static int		TestChannelEventCmd _ANSI_ARGS_((ClientData dummy,
+			    Tcl_Interp *interp, int argc, char **argv));
 
 /*
  * External (platform specific) initialization routine, these declarations
@@ -329,9 +334,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 +4247,575 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
 	return (NULL);
     }
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestChannelCmd --
+ *
+ *	Implements the Tcl "testchannel" debugging command and its
+ *	subcommands. This is part of the testing environment.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+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. */
+    ChannelState *statePtr;	/* state info for channel */
+    Tcl_Channel chan;		/* 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. */
+    int mode;			/* rw mode of the channel */
+    
+    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], &mode);
+        if (chan == (Tcl_Channel) NULL) {
+            return TCL_ERROR;
+        }
+        chanPtr		= (Channel *) chan;
+	statePtr	= chanPtr->state;
+        chanPtr		= statePtr->topChanPtr;
+	chan		= (Tcl_Channel) chanPtr;
+    }
+
+    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 (statePtr->flags & TCL_READABLE) {
+            Tcl_AppendElement(interp, "read");
+        } else {
+            Tcl_AppendElement(interp, "");
+        }
+        if (statePtr->flags & TCL_WRITABLE) {
+            Tcl_AppendElement(interp, "write");
+        } else {
+            Tcl_AppendElement(interp, "");
+        }
+        if (statePtr->flags & CHANNEL_NONBLOCKING) {
+            Tcl_AppendElement(interp, "nonblocking");
+        } else {
+            Tcl_AppendElement(interp, "blocking");
+        }
+        if (statePtr->flags & CHANNEL_LINEBUFFERED) {
+            Tcl_AppendElement(interp, "line");
+        } else if (statePtr->flags & CHANNEL_UNBUFFERED) {
+            Tcl_AppendElement(interp, "none");
+        } else {
+            Tcl_AppendElement(interp, "full");
+        }
+        if (statePtr->flags & BG_FLUSH_SCHEDULED) {
+            Tcl_AppendElement(interp, "async_flush");
+        } else {
+            Tcl_AppendElement(interp, "");
+        }
+        if (statePtr->flags & CHANNEL_EOF) {
+            Tcl_AppendElement(interp, "eof");
+        } else {
+            Tcl_AppendElement(interp, "");
+        }
+        if (statePtr->flags & CHANNEL_BLOCKED) {
+            Tcl_AppendElement(interp, "blocked");
+        } else {
+            Tcl_AppendElement(interp, "unblocked");
+        }
+        if (statePtr->inputTranslation == TCL_TRANSLATE_AUTO) {
+            Tcl_AppendElement(interp, "auto");
+            if (statePtr->flags & INPUT_SAW_CR) {
+                Tcl_AppendElement(interp, "saw_cr");
+            } else {
+                Tcl_AppendElement(interp, "");
+            }
+        } else if (statePtr->inputTranslation == TCL_TRANSLATE_LF) {
+            Tcl_AppendElement(interp, "lf");
+            Tcl_AppendElement(interp, "");
+        } else if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
+            Tcl_AppendElement(interp, "cr");
+            Tcl_AppendElement(interp, "");
+        } else if (statePtr->inputTranslation == TCL_TRANSLATE_CRLF) {
+            Tcl_AppendElement(interp, "crlf");
+            if (statePtr->flags & INPUT_SAW_CR) {
+                Tcl_AppendElement(interp, "queued_cr");
+            } else {
+                Tcl_AppendElement(interp, "");
+            }
+        }
+        if (statePtr->outputTranslation == TCL_TRANSLATE_AUTO) {
+            Tcl_AppendElement(interp, "auto");
+        } else if (statePtr->outputTranslation == TCL_TRANSLATE_LF) {
+            Tcl_AppendElement(interp, "lf");
+        } else if (statePtr->outputTranslation == TCL_TRANSLATE_CR) {
+            Tcl_AppendElement(interp, "cr");
+        } else if (statePtr->outputTranslation == TCL_TRANSLATE_CRLF) {
+            Tcl_AppendElement(interp, "crlf");
+        }
+        for (IOQueued = 0, bufPtr = statePtr->inQueueHead;
+	     bufPtr != (ChannelBuffer *) NULL;
+	     bufPtr = bufPtr->nextPtr) {
+            IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
+        }
+        TclFormatInt(buf, IOQueued);
+        Tcl_AppendElement(interp, buf);
+        
+        IOQueued = 0;
+        if (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
+            IOQueued = statePtr->curOutPtr->nextAdded -
+                statePtr->curOutPtr->nextRemoved;
+        }
+        for (bufPtr = statePtr->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, statePtr->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 = statePtr->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] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
+        if (argc != 3) {
+            Tcl_AppendResult(interp, "channel name required",
+                    (char *) NULL);
+            return TCL_ERROR;
+        }
+        
+        if (statePtr->flags & TCL_READABLE) {
+            Tcl_AppendElement(interp, "read");
+        } else {
+            Tcl_AppendElement(interp, "");
+        }
+        if (statePtr->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, statePtr->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 (statePtr->curOutPtr != (ChannelBuffer *) NULL) {
+            IOQueued = statePtr->curOutPtr->nextAdded -
+                statePtr->curOutPtr->nextRemoved;
+        }
+        for (bufPtr = statePtr->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,
+                (statePtr->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);
+	    statePtr = chanPtr->state;
+            if (statePtr->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, statePtr->refCount);
+        Tcl_AppendResult(interp, buf, (char *) NULL);
+        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);
+	    statePtr = chanPtr->state;
+            if (statePtr->flags & TCL_WRITABLE) {
+                Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr));
+            }
+        }
+        return TCL_OK;
+    }
+
+    if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
+	/*
+	 * Syntax: transform channel -command command
+	 */
+
+        if (argc != 5) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " transform channelId -command cmd\"", (char *) NULL);
+            return TCL_ERROR;
+        }
+	if (strcmp(argv[3], "-command") != 0) {
+	    Tcl_AppendResult(interp, "bad argument \"", argv[3],
+		    "\": should be \"-command\"", (char *) NULL);
+	    return TCL_ERROR;
+	}
+
+	return TclChannelTransform(interp, chan,
+		Tcl_NewStringObj(argv[4], -1));
+    }
+
+    if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
+	/*
+	 * Syntax: unstack channel
+	 */
+
+        if (argc != 3) {
+	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+		    " unstack channel\"", (char *) NULL);
+            return TCL_ERROR;
+        }
+	return Tcl_UnstackChannel(interp, chan);
+    }
+
+    Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",
+            "info, open, readable, writable, transform, unstack",
+            (char *) NULL);
+    return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestChannelEventCmd --
+ *
+ *	This procedure implements the "testchannelevent" command. It is
+ *	used to test the Tcl channel event mechanism.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	Creates, deletes and returns channel event handlers.
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+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;
+    ChannelState *statePtr;	/* state info for channel */
+    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;
+    }
+    statePtr = chanPtr->state;
+
+    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 = statePtr->scriptRecordPtr;
+        statePtr->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 = statePtr->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 == statePtr->scriptRecordPtr) {
+            statePtr->scriptRecordPtr = esPtr->nextPtr;
+        } else {
+            for (prevEsPtr = statePtr->scriptRecordPtr;
+		 (prevEsPtr != (EventScriptRecord *) NULL) &&
+		     (prevEsPtr->nextPtr != esPtr);
+		 prevEsPtr = prevEsPtr->nextPtr) {
+                /* Empty loop body. */
+            }
+            if (prevEsPtr == (EventScriptRecord *) NULL) {
+                panic("TestChannelEventCmd: 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 = statePtr->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 = statePtr->scriptRecordPtr;
+	     esPtr != (EventScriptRecord *) NULL;
+	     esPtr = nextEsPtr) {
+            nextEsPtr = esPtr->nextPtr;
+            Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
+                    TclChannelEventScriptInvoker, (ClientData) esPtr);
+	    Tcl_DecrRefCount(esPtr->scriptPtr);
+            ckfree((char *) esPtr);
+        }
+        statePtr->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 = statePtr->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;
+}