TIP #455 implementation: Extensions to [vwait]: Variable Sets and Scripted Access to Tcl_DoOneEvent

3 files changed, 476 insertions, 36 deletions

diff --git a/doc/vwait.n b/doc/vwait.n
index f64d39c..5f240d6 100644
--- a/doc/vwait.n
+++ b/doc/vwait.n
@@ -12,6 +12,8 @@
 vwait \- Process events until a variable is written
 .SH SYNOPSIS
 \fBvwait\fR \fIvarName\fR
+.PP
+\fBvwait\fR ?\Ioptions\fR? ?\fIvarName ...\fR?
 .BE
 .SH DESCRIPTION
 .PP
@@ -24,8 +26,75 @@ command will return as soon as the event handler that modified
 a variable name with respect to the global namespace, but can refer to any
 namespace's variables if the fully-qualified name is given.
 .PP
+In the second more complex command form \fIoptions\fR allow for finer
+control of the wait operation and to deal with multiple event sources.
+\fIOptions\fR can be made up of
+.TP
+\fB\-\-\fR
+.
+Marks the end of options. All following arguments are handled as
+variable names.
+.TP
+\fB\-all\fR
+.
+All conditions for the wait operation must be met to complete the
+wait operation. Otherwise (the default) the first event completes
+the wait.
+.TP
+\fB\-extended\fR
+.
+An extended result in list form is returned, see below for explanation.
+.TP
+\fB\-nofileevents\fR
+.
+File events are not handled in the wait operation.
+.TP
+\fB\-noidleevents\fR
+.
+Idle handlers are not invoked during the wait operation.
+.TP
+\fB\-notimerevents\fR
+.
+Timer handlers are not serviced during the wait operation.
+.TP
+\fB\-nowindowevents\fR
+.
+Events of the windowing system are not handled during the wait operation.
+.TP
+\fB\-readable\fR \fIchannel\fR
+.
+\fIChannel\fR must name a Tcl channel open for reading. If \fIchannel\fR
+is or becomes readable the wait operation completes.
+.TP
+\fB\-timeout\fR milliseconds\fR
+.
+The wait operation is constrained to \fImilliseconds\fR.
+.TP
+\fB\-variable\fR \fIvarName\fR
+.
+\fIVarName\fR must be the name of a global variable. Writing or
+unsetting this variable completes the wait operation.
+.TP
+\fB\-writable\fR \fIchannel\fR
+.
+\fIChannel\fR must name a Tcl channel open for writing. If \fIchannel\fR
+is or becomes writable the wait operation completes.
+.PP
+The result returned by \fBvwait\fR is for the simple form an empty
+string. If the \fI\-timeout\fR option is specified, the result is the
+number of milliseconds remaining when the wait condition has been
+met, or -1 if the wait operation timed out.
+.PP
+If the \fI\-extended\fR option is specified, the result is made up
+of a Tcl list with an even number of elements. Odd elements
+take the values \fBreadable\fR, \fBtimeleft\fR, \fBvariable\fR,
+and \fBwritable\fR. Even elements are the corresponding variable
+and channel names or the remaining number of milliseconds.
+The list is ordered by the occurrences of the event(s) with the
+exception of \fBtimeleft\fR which always comes last.
+.PP
 In some cases the \fBvwait\fR command may not return immediately
-after \fIvarName\fR is set.  This happens if the event handler
+after \fIvarName\fR et.al. is set. This happens if the event handler
 that sets \fIvarName\fR does not complete immediately.  For example,
 if an event handler sets \fIvarName\fR and then itself calls
 \fBvwait\fR to wait for a different variable, then it may not return
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index c8fe92e..73784f0 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -50,6 +50,19 @@ typedef struct {
 } ErrAssocData;
 
 /*
+ * For each "vwait" event source a structure of the following type
+ * is used:
+ */
+
+typedef struct {
+    int *donePtr;		/* Pointer to flag to signal or NULL. */
+    int sequence;		/* Order of occurrence. */
+    int mask;			/* 0, or TCL_READABLE/TCL_WRITABLE. */
+    Tcl_Obj *sourceObj;		/* Name of the event source, either a
+				 * variable name or channel name. */
+} VwaitItem;
+
+/*
  * For each exit handler created with a call to Tcl_Create(Late)ExitHandler
  * there is a structure of the following type:
  */
@@ -116,6 +129,9 @@ static Tcl_ThreadCreateType NewThreadProc(void *clientData);
 static void		BgErrorDeleteProc(void *clientData,
 			    Tcl_Interp *interp);
 static void		HandleBgErrors(void *clientData);
+static void		VwaitChannelReadProc(void *clientData, int mask);
+static void		VwaitChannelWriteProc(void *clientData, int mask);
+static void		VwaitTimeoutProc(void *clientData);
 static char *		VwaitVarProc(void *clientData,
 			    Tcl_Interp *interp, const char *name1,
 			    const char *name2, int flags);
@@ -1487,73 +1503,431 @@ Tcl_VwaitObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
-    int done, foundEvent;
-    const char *nameString;
+    int i, done = 0, timedOut = 0, foundEvent, any = 1, timeout = 0;
+    int numItems = 0, extended = 0, result, mode, mask = TCL_ALL_EVENTS;
+    Tcl_SavedResult savedResult;
+    Tcl_TimerToken timer = NULL;
+    Tcl_Time before, after;
+    Tcl_Channel chan;
+    Tcl_WideInt diff = -1;
+    VwaitItem localItems[32], *vwaitItems = localItems;
+    static const char *const options[] = {
+	"-all",	"-extended", "-nofileevents", "-noidleevents",
+	"-notimerevents", "-nowindowevents", "-readable",
+	"-timeout", "-variable", "-writable", "--", NULL
+    };
+    enum options {
+	OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS,
+	OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE,
+	OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST
+    };
 
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "name");
-	return TCL_ERROR;
+    if ((objc == 2) && (strcmp(Tcl_GetString(objv[1]), "--") != 0)) {
+	/*
+	 * Legacy "vwait" syntax, skip option handling.
+	 */
+	i = 1;
+	goto endOfOptionLoop;
     }
-    nameString = Tcl_GetString(objv[1]);
-    if (Tcl_TraceVar2(interp, nameString, NULL,
-	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
-	    VwaitVarProc, &done) != TCL_OK) {
-	return TCL_ERROR;
-    };
-    done = 0;
+
+    if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) {
+	vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1));
+    }
+
+    for (i = 1; i < objc; i++) {
+	const char *name;
+	int index;
+
+	name = TclGetString(objv[i]);
+	if (name[0] != '-') {
+	    break;
+	}
+	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+		&index) != TCL_OK) {
+	    result = TCL_ERROR;
+	    goto done;
+	}
+	switch ((enum options) index) {
+	case OPT_ALL:
+	    any = 0;
+	    break;
+	case OPT_EXTD:
+	    extended = 1;
+	    break;
+	case OPT_NO_FEVTS:
+	    mask &= ~TCL_FILE_EVENTS;
+	    break;
+	case OPT_NO_IEVTS:
+	    mask &= ~TCL_IDLE_EVENTS;
+	    break;
+	case OPT_NO_TEVTS:
+	    mask &= ~TCL_TIMER_EVENTS;
+	    break;
+	case OPT_NO_WEVTS:
+	    mask &= ~TCL_WINDOW_EVENTS;
+	    break;
+	case OPT_TIMEOUT:
+	    if (++i >= objc) {
+	needArg:
+		Tcl_ResetResult(interp);
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"argument required for \"%s\"", options[index]));
+		Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL);
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    if (timeout < 0) {
+		Tcl_ResetResult(interp);
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"timeout must be positive", -1));
+		Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", NULL);
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    break;
+	case OPT_LAST:
+	    i++;
+	    goto endOfOptionLoop;
+	case OPT_VARIABLE:
+	    if (++i >= objc) {
+		goto needArg;
+	    }
+	    result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+			    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+			    VwaitVarProc, &vwaitItems[numItems]);
+	    if (result != TCL_OK) {
+		goto done;
+	    }
+	    vwaitItems[numItems].donePtr = &done;
+	    vwaitItems[numItems].sequence = -1;
+	    vwaitItems[numItems].mask = 0;
+	    vwaitItems[numItems].sourceObj = objv[i];
+	    numItems++;
+	    break;
+	case OPT_READABLE:
+	    if (++i >= objc) {
+		goto needArg;
+	    }
+	    if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+		!= TCL_OK) {
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    if (!(mode & TCL_READABLE)) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"channel \"%s\" wasn't open for reading",
+			TclGetString(objv[i])));
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    Tcl_CreateChannelHandler(chan, TCL_READABLE,
+		    VwaitChannelReadProc, &vwaitItems[numItems]);
+	    vwaitItems[numItems].donePtr = &done;
+	    vwaitItems[numItems].sequence = -1;
+	    vwaitItems[numItems].mask = TCL_READABLE;
+	    vwaitItems[numItems].sourceObj = objv[i];
+	    numItems++;
+	    break;
+	case OPT_WRITABLE:
+	    if (++i >= objc) {
+		goto needArg;
+	    }
+	    if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+		!= TCL_OK) {
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    if (!(mode & TCL_WRITABLE)) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"channel \"%s\" wasn't open for writing",
+			TclGetString(objv[i])));
+		result = TCL_ERROR;
+		goto done;
+	    }
+	    Tcl_CreateChannelHandler(chan, TCL_WRITABLE,
+		    VwaitChannelWriteProc, &vwaitItems[numItems]);
+	    vwaitItems[numItems].donePtr = &done;
+	    vwaitItems[numItems].sequence = -1;
+	    vwaitItems[numItems].mask = TCL_WRITABLE;
+	    vwaitItems[numItems].sourceObj = objv[i];
+	    numItems++;
+	    break;
+	}
+    }
+
+  endOfOptionLoop:
+    if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
+		 TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"can't wait: would block forever", -1));
+	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
+	result = TCL_ERROR;
+	goto done;
+    }
+
+    if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"timer events disabled with timeout specified", -1));
+	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", NULL);
+	result = TCL_ERROR;
+	goto done;
+    }
+
+    for (result = TCL_OK; i < objc; i++) {
+	result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+			TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+			VwaitVarProc, &vwaitItems[numItems]);
+	if (result != TCL_OK) {
+	    break;
+	}
+	vwaitItems[numItems].donePtr = &done;
+	vwaitItems[numItems].sequence = -1;
+	vwaitItems[numItems].mask = 0;
+	vwaitItems[numItems].sourceObj = objv[i];
+	numItems++;
+    }
+    if (result != TCL_OK) {
+	result = TCL_ERROR;
+	goto done;
+    }
+
+    if (!(mask & TCL_FILE_EVENTS)) {
+	for (i = 0; i < numItems; i++) {
+	    if (vwaitItems[i].mask) {
+		Tcl_SetObjResult(interp, Tcl_NewStringObj(
+			"file events disabled with channel(s) specified", -1));
+		Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", NULL);
+		result = TCL_ERROR;
+		goto done;
+	    }
+	}
+    }
+
+    if (timeout > 0) {
+	vwaitItems[numItems].donePtr = &timedOut;
+	vwaitItems[numItems].sequence = -1;
+	vwaitItems[numItems].mask = 0;
+	vwaitItems[numItems].sourceObj = NULL;
+	timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc,
+			&vwaitItems[numItems]);
+	Tcl_GetTime(&before);
+    } else {
+	timeout = 0;
+    }
+
+    if ((numItems == 0) && (timeout == 0)) {
+	/*
+	 * "vwait" is equivalent to "update",
+	 * "vwait -nofileevents -notimerevents -nowindowevents"
+	 * is equivalent to "update idletasks"
+	 */
+	any = 1;
+	mask |= TCL_DONT_WAIT;
+    }
+
     foundEvent = 1;
-    while (!done && foundEvent) {
-	foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+    while (!timedOut && foundEvent &&
+	   ((!any && (done < numItems)) || (any && !done))) {
+	foundEvent = Tcl_DoOneEvent(mask);
 	if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
 	    break;
 	}
 	if (Tcl_LimitExceeded(interp)) {
 	    Tcl_ResetResult(interp);
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", NULL);
 	    break;
 	}
+	if ((numItems == 0) && (timeout == 0)) {
+	    /*
+	     * Behavior like "update": clear interpreter's result because
+	     * event handlers could have executed commands.
+	     */
+	    Tcl_ResetResult(interp);
+	    result = TCL_OK;
+	    goto done;
+	}
     }
-    Tcl_UntraceVar2(interp, nameString, NULL,
-	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
-	    VwaitVarProc, &done);
 
     if (!foundEvent) {
 	Tcl_ResetResult(interp);
-	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		"can't wait for variable \"%s\": would wait forever",
-		nameString));
+	Tcl_SetObjResult(interp, Tcl_NewStringObj((numItems == 0) ?
+		"can't wait: would wait forever" :
+		"can't wait for variable(s)/channel(s): would wait forever",
+		-1));
 	Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
-	return TCL_ERROR;
+	result = TCL_ERROR;
+	goto done;
     }
-    if (!done) {
+
+    if (!done && !timedOut) {
 	/*
 	 * The interpreter's result was already set to the right error message
 	 * prior to exiting the loop above.
 	 */
+	result = TCL_ERROR;
+	goto done;
+    }
 
-	return TCL_ERROR;
+    result = TCL_OK;
+    if (timeout <= 0) {
+	/*
+	 * Clear out the interpreter's result, since it may have been set
+	 * by event handlers.
+	 */
+	Tcl_ResetResult(interp);
+	goto done;
     }
 
     /*
-     * Clear out the interpreter's result, since it may have been set by event
-     * handlers.
+     * When timeout was specified, report milliseconds left or -1 on timeout.
      */
+    if (timedOut) {
+	diff = -1;
+    } else {
+	Tcl_GetTime(&after);
+	diff = after.sec * 1000 + after.usec / 1000;
+	diff -= before.sec * 1000 + before.usec / 1000;
+	diff = timeout - diff;
+	if (diff < 0) {
+	    diff = 0;
+	}
+    }
 
-    Tcl_ResetResult(interp);
-    return TCL_OK;
+  done:
+    if ((timeout > 0) && (timer != NULL)) {
+	Tcl_DeleteTimerHandler(timer);
+    }
+    if (result != TCL_OK) {
+	Tcl_SaveResult(interp, &savedResult);
+    }
+    for (i = 0; i < numItems; i++) {
+	if (vwaitItems[i].mask & TCL_READABLE) {
+	    if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+		    &chan, &mode, 0) == TCL_OK) {
+		Tcl_DeleteChannelHandler(chan, VwaitChannelReadProc,
+			&vwaitItems[i]);
+	    }
+	} else if (vwaitItems[i].mask & TCL_WRITABLE) {
+	    if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+		    &chan, &mode, 0) == TCL_OK) {
+		Tcl_DeleteChannelHandler(chan, VwaitChannelWriteProc,
+			&vwaitItems[i]);
+	    }
+	} else {
+	    Tcl_UntraceVar2(interp, TclGetString(vwaitItems[i].sourceObj),
+		    NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+		    VwaitVarProc, &vwaitItems[i]);
+	}
+    }
+
+    if (result == TCL_OK) {
+	if (extended) {
+	    int k;
+	    Tcl_Obj *listObj, *keyObj;
+
+	    TclNewObj(listObj);
+	    for (k = 0; k < done; k++) {
+		for (i = 0; i < numItems; i++) {
+		    if (vwaitItems[i].sequence != k) {
+			continue;
+		    }
+		    if (vwaitItems[i].mask & TCL_READABLE) {
+			TclNewLiteralStringObj(keyObj, "readable");
+		    } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+			TclNewLiteralStringObj(keyObj, "writable");
+		    } else {
+			TclNewLiteralStringObj(keyObj, "variable");
+		    }
+		    Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+		    Tcl_ListObjAppendElement(NULL, listObj,
+			    vwaitItems[i].sourceObj);
+		}
+	    }
+	    if (timeout > 0) {
+		TclNewLiteralStringObj(keyObj, "timeleft");
+		Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+		Tcl_ListObjAppendElement(NULL, listObj,
+			Tcl_NewWideIntObj(diff));
+	    }
+	    Tcl_SetObjResult(interp, listObj);
+	} else if (timeout > 0) {
+	    Tcl_SetObjResult(interp, Tcl_NewWideIntObj(diff));
+	}
+    } else {
+	Tcl_RestoreResult(interp, &savedResult);
+    }
+    if (vwaitItems != localItems) {
+	ckfree(vwaitItems);
+    }
+    return result;
+}
+
+static void
+VwaitChannelReadProc(
+    void *clientData,		/* Pointer to vwait info record. */
+    int mask)			/* Event mask, must be TCL_READABLE. */
+{
+    VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+    if (!(mask & TCL_READABLE)) {
+	return;
+    }
+    if (itemPtr->donePtr != NULL) {
+	itemPtr->sequence = itemPtr->donePtr[0];
+	itemPtr->donePtr[0] += 1;
+	itemPtr->donePtr = NULL;
+    }
+}
+
+static void
+VwaitChannelWriteProc(
+    void *clientData,		/* Pointer to vwait info record. */
+    int mask)			/* Event mask, must be TCL_WRITABLE. */
+{
+    VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+    if (!(mask & TCL_WRITABLE)) {
+	return;
+    }
+    if (itemPtr->donePtr != NULL) {
+	itemPtr->sequence = itemPtr->donePtr[0];
+	itemPtr->donePtr[0] += 1;
+	itemPtr->donePtr = NULL;
+    }
+}
+
+static void
+VwaitTimeoutProc(
+    void *clientData)		/* Pointer to vwait info record. */
+{
+    VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+    if (itemPtr->donePtr != NULL) {
+	itemPtr->donePtr[0] = 1;
+	itemPtr->donePtr = NULL;
+    }
 }
 
 static char *
 VwaitVarProc(
-    void *clientData,		/* Pointer to integer to set to 1. */
+    void *clientData,		/* Pointer to vwait info record. */
     Tcl_Interp *interp,		/* Interpreter containing variable. */
     const char *name1,		/* Name of variable. */
     const char *name2,		/* Second part of variable name. */
     TCL_UNUSED(int) /*flags*/)	/* Information about what happened. */
 {
-    int *donePtr = (int *)clientData;
+    VwaitItem *itemPtr = (VwaitItem *) clientData;
 
-    *donePtr = 1;
+    if (itemPtr->donePtr != NULL) {
+	itemPtr->sequence = itemPtr->donePtr[0];
+	itemPtr->donePtr[0] += 1;
+	itemPtr->donePtr = NULL;
+    }
     Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 	    VwaitVarProc, clientData);
     return NULL;
diff --git a/tests/event.test b/tests/event.test
index 3f9735a..16cbc24 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -509,12 +509,9 @@ test event-10.1 {Tcl_Exit procedure} {stdio} {
         [lindex $::errorCode 2]
 } {1 {child process exited abnormally} CHILDSTATUS 3}
 
-test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body {
+test event-11.1 {Tcl_VwaitCmd procedure} -body {
     vwait
-} -result {wrong # args: should be "vwait name"}
-test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
-    vwait a b
-} -result {wrong # args: should be "vwait name"}
+} -result {}
 test event-11.3 {Tcl_VwaitCmd procedure} -setup {
     catch {unset x}
 } -body {