Fix some eventloop bugs

bgerror is supposed to be suppressed subsequently if it returns break
vwait should error on invalid array element
vwait should return an empty result
Don't accept 'after info' since it isn't supported
Also add some eventloop tests

Signed-off-by: Steve Bennett <steveb@workware.net.au>

4 files changed, 185 insertions, 14 deletions

diff --git a/jim-eventloop.c b/jim-eventloop.c
index ff94f50..0f34dd3 100644
--- a/jim-eventloop.c
+++ b/jim-eventloop.c
@@ -419,9 +419,21 @@ static int JimELVwaitCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
         Jim_WrongNumArgs(interp, 1, argv, "name");
         return JIM_ERR;
     }
+
+    interp->suppress_bgerror = 0;
+
     oldValue = Jim_GetGlobalVariable(interp, argv[1], JIM_NONE);
-    if (oldValue)
+    if (oldValue) {
         Jim_IncrRefCount(oldValue);
+    }
+    else {
+        /* If a result was left, it is an error */
+        int len;
+        Jim_GetString(interp->result, &len);
+        if (len) {
+            return JIM_ERR;
+        }
+    }
     while (1) {
         Jim_Obj *currValue;
 
@@ -439,6 +451,8 @@ static int JimELVwaitCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
     }
     if (oldValue)
         Jim_DecrRefCount(interp, oldValue);
+
+    Jim_SetEmptyResult(interp);
     return JIM_OK;
 }
 
@@ -461,18 +475,18 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
     jim_wide ms, id;
     Jim_Obj *objPtr, *idObjPtr;
     const char *options[] = {
-        "info", "cancel", NULL
+        "cancel", NULL
     };
     enum
-    { INFO, CANCEL, RESTART, EXPIRE, CREATE };
-    int option = CREATE;
+    { AFTER_CANCEL, AFTER_INFO, AFTER_RESTART, AFTER_EXPIRE, AFTER_CREATE };
+    int option = AFTER_CREATE;
 
     if (argc < 2) {
         Jim_WrongNumArgs(interp, 1, argv, "<after milliseconds> ?script|cancel <id>?");
         return JIM_ERR;
     }
     if (Jim_GetWide(interp, argv[1], &ms) != JIM_OK) {
-        if (Jim_GetEnum(interp, argv[1], options, &option, "after options", JIM_ERRMSG) != JIM_OK) {
+        if (Jim_GetEnum(interp, argv[1], options, &option, NULL, JIM_ERRMSG) != JIM_OK) {
             return JIM_ERR;
         }
     }
@@ -483,7 +497,7 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
         return JIM_OK;
     }
     switch (option) {
-        case CREATE:
+        case AFTER_CREATE:
             Jim_IncrRefCount(argv[2]);
             id = Jim_CreateTimeHandler(interp, ms, JimAfterTimeHandler, argv[2],
                 JimAfterTimeEventFinalizer);
@@ -495,7 +509,7 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
             Jim_DecrRefCount(interp, idObjPtr);
             Jim_SetResult(interp, objPtr);
             return JIM_OK;
-        case CANCEL:{
+        case AFTER_CANCEL:{
                 int tlen;
                 jim_wide remain = 0;
                 const char *tok = Jim_GetString(argv[2], &tlen);
@@ -510,8 +524,6 @@ static int JimELAfterCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
                 Jim_SetResultString(interp, "invalid event", -1);
                 return JIM_ERR;
             }
-        default:
-            fprintf(stderr, "unserviced option to after %d\n", option);
     }
     return JIM_OK;
 }
diff --git a/jim.c b/jim.c
index 58d47a9..732253f 100644
--- a/jim.c
+++ b/jim.c
@@ -4670,6 +4670,7 @@ Jim_Interp *Jim_CreateInterp(void)
     i->unknown = Jim_NewStringObj(i, "unknown", -1);
     i->unknown_called = 0;
     i->errorProc = i->emptyObj;
+    i->suppress_bgerror = 0;
     i->currentScriptObj = Jim_NewEmptyStringObj(i);
     Jim_IncrRefCount(i->emptyObj);
     Jim_IncrRefCount(i->result);
@@ -9886,17 +9887,24 @@ int Jim_EvalObjBackground(Jim_Interp *interp, Jim_Obj *scriptObjPtr)
     retval = Jim_EvalObj(interp, scriptObjPtr);
     interp->framePtr = savedFramePtr;
     /* Try to report the error (if any) via the bgerror proc */
-    if (retval != JIM_OK) {
+    if (retval != JIM_OK && !interp->suppress_bgerror) {
         Jim_Obj *objv[2];
+        int rc = JIM_ERR;
 
         objv[0] = Jim_NewStringObj(interp, "bgerror", -1);
         objv[1] = Jim_GetResult(interp);
         Jim_IncrRefCount(objv[0]);
         Jim_IncrRefCount(objv[1]);
-        if (Jim_GetCommand(interp, objv[0], JIM_NONE) == NULL || Jim_EvalObjVector(interp, 2, objv) != JIM_OK) {
-            /* Report the error to stderr. */
-            fprintf(stderr, "Background error:" JIM_NL);
-            Jim_PrintErrorMessage(interp);
+        if (Jim_GetCommand(interp, objv[0], JIM_NONE) == NULL || (rc = Jim_EvalObjVector(interp, 2, objv)) != JIM_OK) {
+            if (rc == JIM_BREAK) {
+                /* No more bgerror calls */
+                interp->suppress_bgerror++;
+            }
+            else {
+                /* Report the error to stderr. */
+                fprintf(stderr, "Background error:" JIM_NL);
+                Jim_PrintErrorMessage(interp);
+            }
         }
         Jim_DecrRefCount(interp, objv[0]);
         Jim_DecrRefCount(interp, objv[1]);
diff --git a/jim.h b/jim.h
index 34b71f5..b8d5d1d 100644
--- a/jim.h
+++ b/jim.h
@@ -541,6 +541,7 @@ typedef struct Jim_Interp {
     Jim_Obj *unknown; /* Unknown command cache */
     int unknown_called; /* The unknown command has been invoked */
     int errorFlag; /* Set if an error occurred during execution. */
+    int suppress_bgerror; /* bgerror returned break, so don't call it again */
     void *cmdPrivData; /* Used to pass the private data pointer to
                   a command. It is set to what the user specified
                   via Jim_CreateCommand(). */
diff --git a/tests/event.test b/tests/event.test
new file mode 100644
index 0000000..9f14f6d
--- /dev/null
+++ b/tests/event.test
@@ -0,0 +1,150 @@
+source testing.tcl
+
+test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
+    catch {rename bgerror {}}
+    proc bgerror msg {
+		lappend ::x $msg
+    }
+    after 100 {error "a simple error"}
+    after 200 {open non_existent}
+    set x {}
+	vwait dummy
+    rename bgerror {}
+    set x
+} {{a simple error} {non_existent: No such file or directory}}
+
+test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
+    proc bgerror msg {
+		lappend ::x $msg
+		return -code break
+    }
+    after 100 {error "a simple error"}
+    after 200 {open non_existent}
+    set x {}
+    vwait dummy
+    rename bgerror {}
+    set x
+} {{a simple error}}
+
+test event-7.1 {bgerror / regular} {
+    set errRes {}
+    proc bgerror {err} {
+		set ::errRes $err;
+    }
+    after 0 {error err1}
+    vwait errRes;
+    set errRes;
+} err1
+
+test event-7.2 {bgerror / accumulation} {
+    set errRes {}
+    proc bgerror {err} {
+		lappend ::errRes $err;
+    }
+    after 0 {error err1}
+    after 1 {error err2}
+    after 2 {error err3}
+    vwait dummy
+    set errRes;
+} {err1 err2 err3}
+
+test event-7.3 {bgerror / accumulation / break} {
+    set errRes {}
+    proc bgerror {err} {
+		lappend ::errRes $err;
+		return -code break "skip!";
+    }
+    after 0 {error err1}
+    after 1 {error err2}
+    after 2 {error err3}
+    vwait dummy
+    set errRes
+} err1
+
+# end of bgerror tests
+catch {rename bgerror {}}
+
+test event-11.1 {Tcl_VwaitCmd procedure} {
+    list [catch {vwait} msg] $msg
+} {1 {wrong # args: should be "vwait name"}}
+test event-11.2 {Tcl_VwaitCmd procedure} {
+    list [catch {vwait a b} msg] $msg
+} {1 {wrong # args: should be "vwait name"}}
+test event-11.3 {Tcl_VwaitCmd procedure} {
+    catch {unset x}
+    set x 1
+    list [catch {vwait x(1)} msg] $msg
+} {1 {can't read "x(1)": variable isn't array}}
+
+test event-11.4 {Tcl_VwaitCmd procedure} {
+	vwait dummy
+    lappend ids [after 100 {set x x-done}]
+    lappend ids [after 200 {set y y-done}]
+    lappend ids [after 300 {set z z-done}]
+    set x before
+    set y before
+    set z before
+    set q before
+    list [vwait y] $x $y $z $q
+} {{} x-done y-done before before}
+
+foreach i $ids {
+    after cancel $i
+}
+
+test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {
+    set f1 [open test1 w]
+    proc accept {s args} {
+	puts $s foobar
+	close $s
+    }
+    catch {set s1 [socket stream.server 5001]}
+    after 1000
+    catch {set s2 [socket stream 5001]}
+    close $s1
+    set x 0
+    set y 0
+    set z 0
+    $s2 readable { incr z }
+    vwait z
+    $f1 writable { incr x; if { $y == 3 } { set z done } }
+    $s2 readable { incr y; if { $x == 3 } { set z done } }
+    vwait z
+    close $f1
+    close $s2
+    file delete test1 test2
+    list $x $y $z
+} {3 3 done}
+
+test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
+    file delete test1 test2
+    set f1 [open test1 w]
+    set f2 [open test2 w]
+    set x 0
+    set y 0
+    set z 0
+    vwait dummy
+    $f1 writable { incr x; if { $y == 3 } { set z done } }
+    $f2 writable { incr y; if { $x == 3 } { set z done } }
+    vwait z
+    close $f1
+    close $f2
+    file delete test1 test2
+    list $x $y $z
+} {3 3 done}
+
+
+test event-12.3 {Tcl_UpdateCmd procedure} {
+    after 500 {set x after}
+    after 1 {set y after}
+    after 2 {set z "after, y = $y"}
+    set x before
+    set y before
+    set z before
+    vwait z
+    list $x $y $z
+} {before after {after, y = after}}
+
+vwait dummy
+
+testreport