eventloop improvements and enhancements

Move Jim_EvalObjBackground() out of the core to eventloop
Time events are now kept and triggered in time order
Time handlers are removed before execution
Add 'update'
Add 'after info' and 'after idle'
Include time events in the return from Jim_ProcessEvents()
Add Tcl eventloop tests

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

3 files changed, 540 insertions, 47 deletions

diff --git a/tests/event.test b/tests/event.test
index 9f14f6d..0374539 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -1,35 +1,35 @@
+# This file contains a collection of tests for the procedures in the file
+# tclEvent.c, which includes the "update", and "vwait" Tcl
+# commands.  Sourcing this file into Tcl runs the tests and generates
+# output for errors.  No output means no errors were found.
+#
+# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
 source testing.tcl
 
 test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
     catch {rename bgerror {}}
     proc bgerror msg {
-		lappend ::x $msg
+	lappend ::x $msg
     }
-    after 100 {error "a simple error"}
-    after 200 {open non_existent}
+    after idle {error "a simple error"}
+    after idle {open non_existent}
+    after idle {set errorInfo foobar; set errorCode xyzzy}
     set x {}
-	vwait dummy
+    update idletasks
     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;
+	global errRes;
+	set errRes $err;
     }
     after 0 {error err1}
     vwait errRes;
@@ -39,31 +39,40 @@ test event-7.1 {bgerror / regular} {
 test event-7.2 {bgerror / accumulation} {
     set errRes {}
     proc bgerror {err} {
-		lappend ::errRes $err;
+	global errRes;
+	lappend errRes $err;
     }
     after 0 {error err1}
-    after 1 {error err2}
-    after 2 {error err3}
-    vwait dummy
+    after 0 {error err2}
+    after 0 {error err3}
+    update
     set errRes;
 } {err1 err2 err3}
 
 test event-7.3 {bgerror / accumulation / break} {
     set errRes {}
     proc bgerror {err} {
-		lappend ::errRes $err;
-		return -code break "skip!";
+	global errRes;
+	lappend errRes $err;
+	return -code break "skip!";
     }
     after 0 {error err1}
-    after 1 {error err2}
-    after 2 {error err3}
-    vwait dummy
-    set errRes
+    after 0 {error err2}
+    after 0 {error err3}
+    update
+    set errRes;
 } err1
 
 # end of bgerror tests
 catch {rename bgerror {}}
 
+
+test event-10.1 {Tcl_Exit procedure} {
+    set cmd [list exec [info nameofexecutable] "<<exit 3"]
+    list [catch $cmd msg] [lindex $errorCode 0] \
+        [lindex $errorCode 2]
+} {1 CHILDSTATUS 3}
+
 test event-11.1 {Tcl_VwaitCmd procedure} {
     list [catch {vwait} msg] $msg
 } {1 {wrong # args: should be "vwait name"}}
@@ -75,20 +84,23 @@ test event-11.3 {Tcl_VwaitCmd procedure} {
     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}]
+    foreach i [after info] {
+	after cancel $i
+    }
+    after 10; update; # On Mac make sure update won't take long
+    after 100 {set x x-done}
+    after 200 {set y y-done}
+    after 300 {set z z-done}
+    after idle {set q q-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}
+} {{} x-done y-done before q-done}
 
-foreach i $ids {
+foreach i [after info] {
     after cancel $i
 }
 
@@ -115,7 +127,6 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {
     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]
@@ -123,7 +134,7 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
     set x 0
     set y 0
     set z 0
-    vwait dummy
+    update
     $f1 writable { incr x; if { $y == 3 } { set z done } }
     $f2 writable { incr y; if { $x == 3 } { set z done } }
     vwait z
@@ -134,17 +145,41 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
 } {3 3 done}
 
 
+test event-12.1 {Tcl_UpdateCmd procedure} {
+    list [catch {update a b} msg] $msg
+} {1 {wrong # args: should be "update ?idletasks?"}}
 test event-12.3 {Tcl_UpdateCmd procedure} {
+    foreach i [after info] {
+	after cancel $i
+    }
     after 500 {set x after}
-    after 1 {set y after}
-    after 2 {set z "after, y = $y"}
+    after idle {set y after}
+    after idle {set z "after, y = $y"}
     set x before
     set y before
     set z before
-    vwait z
+    update idletasks
     list $x $y $z
 } {before after {after, y = after}}
+test event-12.4 {Tcl_UpdateCmd procedure} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    after 10; update; # On Mac make sure update won't take long
+    after 200 {set x x-done}
+    after 600 {set y y-done}
+    after idle {set z z-done}
+    set x before
+    set y before
+    set z before
+    after 300
+    update
+    list $x $y $z
+} {x-done before z-done}
 
-vwait dummy
+# cleanup
+foreach i [after info] {
+    after cancel $i
+}
 
 testreport
diff --git a/tests/testing.tcl b/tests/testing.tcl
index 9c0b4ec..5e6b395 100644
--- a/tests/testing.tcl
+++ b/tests/testing.tcl
@@ -4,8 +4,11 @@ proc makeFile {contents name} {
 	close $f
 }
 
-proc info_source {script} {
-	join [info source $script] :
+proc error_source {} {
+	lassign [info stacktrace] p f l
+	if {$f ne ""} {
+		puts "At      : $f:$l"
+	}
 }
 
 catch {
@@ -14,8 +17,7 @@ catch {
 	proc errorInfo {msg} {
 		return $::errorInfo
 	}
-	proc info_source {script} {
-		return ""
+	proc error_source {} {
 	}
 }
 
@@ -33,7 +35,8 @@ proc test {id descr script expected} {
 	if {!$::testquiet} {
 		puts -nonewline "$id "
 	}
-	set rc [catch {uplevel 1 $script} result]
+	set rc [catch {uplevel 1 $script} result opts]
+
 	# Note that rc=2 is return
 	if {($rc == 0 || $rc == 2) && $result eq $expected} {
 		if {!$::testquiet} {
@@ -45,7 +48,7 @@ proc test {id descr script expected} {
 			puts -nonewline "$id "
 		}
 		puts "ERR $descr"
-		puts "At      : [info_source $script]"
+		error_source
 		puts "Expected: '$expected'"
 		puts "Got     : '$result'"
 		incr ::testresults(numfail)
diff --git a/tests/timer.test b/tests/timer.test
new file mode 100644
index 0000000..d1c7e1f
--- /dev/null
+++ b/tests/timer.test
@@ -0,0 +1,455 @@
+# This file contains a collection of tests for the procedures in the
+# file tclTimer.c, which includes the "after" Tcl command.  Sourcing
+# this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands.  Sourcing this file into Tcl runs the tests and
+# generates output for errors.  No output means no errors were found.
+#
+# Copyright (c) 1997 by Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 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: timer.test,v 1.7.2.1 2001/10/13 01:14:19 hobbs Exp $
+
+source testing.tcl
+
+test timer-1.1 {Tcl_CreateTimerHandler procedure} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x ""
+    foreach i {100 200 1000 50 150} {
+	after $i lappend x $i
+    }
+    after 210
+    update
+    set x
+} {50 100 150 200}
+
+test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x ""
+    foreach i {100 200 300 50 150} {
+	after $i lappend x $i
+    }
+    after cancel lappend x 150
+    after cancel lappend x 50
+    after 210
+    update
+    set x
+} {100 200}
+
+# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
+# above.
+
+test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
+    set x start
+    after 100 { set x fired }
+    update idletasks
+    set result $x
+    after 200
+    update
+    lappend result $x
+} {start fired}
+test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    foreach i {200 600 1000} {
+	after $i lappend x $i
+    }
+    after 210
+    set result ""
+    set x ""
+    update
+    lappend result $x
+    after 400
+    update
+    lappend result $x
+    after 400
+    update
+    lappend result $x
+} {200 {200 600} {200 600 1000}}
+test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x {}
+    after 100 lappend x 100
+    set i [after 300 lappend x 300]
+    after 200 after cancel $i
+    after 400
+    update
+    set x
+} 100
+test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x {}
+    after 100 lappend x a
+    after 200 lappend x b
+    after 300 lappend x c
+    after 310
+    vwait x
+    set x
+} {a b c}
+test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x {}
+    after 100 {lappend x a; after 0 lappend x b}
+    after 100
+    vwait x
+    set x
+} a
+test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x {}
+    after 100 {lappend x a; after 100 lappend x b; after 100}
+    after 100
+    vwait x
+    set result $x
+    vwait x
+    lappend result $x
+} {a {a b}}
+
+# No tests for Tcl_DoWhenIdle:  it's already tested by other tests
+# below.
+
+test timer-4.1 {Tcl_CancelIdleCall procedure} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x before
+    set y before
+    set z before
+    after idle set x after1
+    after idle set y after2
+    after idle set z after3
+    after cancel set y after2
+    update idletasks
+    concat $x $y $z
+} {after1 before after3}
+test timer-4.2 {Tcl_CancelIdleCall procedure} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x before
+    set y before
+    set z before
+    after idle set x after1
+    after idle set y after2
+    after idle set z after3
+    after cancel set x after1
+    update idletasks
+    concat $x $y $z
+} {before after2 after3}
+
+test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x 1
+    set y 23
+    after idle {incr x; after idle {incr x; after idle {incr x}}}
+    after idle {incr y}
+    vwait x
+    set result "$x $y"
+    update idletasks
+    lappend result $x
+} {2 24 4}
+
+test timer-6.1 {Tcl_AfterCmd procedure, basics} {
+    list [catch {after} msg] $msg
+} {1 {wrong # args: should be "after option ?arg ...?"}}
+test timer-6.2 {Tcl_AfterCmd procedure, basics} {
+    list [catch {after 2x} msg] $msg
+} {1 {bad argument "2x": must be cancel, idle, or info}}
+test timer-6.3 {Tcl_AfterCmd procedure, basics} {
+    list [catch {after gorp} msg] $msg
+} {1 {bad argument "gorp": must be cancel, idle, or info}}
+test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
+    set x before
+    after 400 {set x after}
+    after 200
+    update
+    set y $x
+    after 400
+    update
+    list $y $x
+} {before after}
+test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
+    set x before
+    after 300 {set x after}
+    after 200
+    update
+    set y $x
+    after 200
+    update
+    list $y $x
+} {before after}
+test timer-6.6 {Tcl_AfterCmd procedure, cancel option} {
+    list [catch {after cancel} msg] $msg
+} {1 {wrong # args: should be "after cancel id|command"}}
+test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
+    after cancel after#1
+} {}
+test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
+    after cancel {foo bar}
+} {}
+test timer-6.9 {Tcl_AfterCmd procedure, cancel option} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x before
+    set y [after 100 set x after]
+    after cancel $y
+    after 200
+    update
+    set x
+} {before}
+test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x before
+    after 100 set x after
+    after cancel set x after
+    after 200
+    update
+    set x
+} {before}
+test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x before
+    after 100 set x after
+    set id [after 300 set x after]
+    after cancel $id
+    after 200
+    update
+    set y $x
+    set x cleared
+    after 200
+    update
+    list $y $x
+} {after cleared}
+test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x first
+    after idle lappend x second
+    after idle lappend x third
+    set i [after idle lappend x fourth]
+    after cancel {lappend x second}
+    after cancel $i
+    update idletasks
+    set x
+} {first third}
+test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x first
+    after idle lappend x second
+    after idle lappend x third
+    set i [after idle lappend x fourth]
+    after cancel lappend x second
+    after cancel $i
+    update idletasks
+    set x
+} {first third}
+test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set id [
+	after 100 {
+	    set x done
+	    after cancel $id
+	}
+    ]
+    vwait x
+} {}
+test timer-6.16 {Tcl_AfterCmd procedure, idle option} {
+    list [catch {after idle} msg] $msg
+} {1 {wrong # args: should be "after idle script ?script ...?"}}
+test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
+    set x before
+    after idle {set x after}
+    set y $x
+    update idletasks
+    list $y $x
+} {before after}
+test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
+    set x before
+    after idle set x after
+    set y $x
+    update idletasks
+    list $y $x
+} {before after}
+set event1 [after idle event 1]
+set event2 [after 1000 event 2]
+
+test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    after 1 "set x ab\0cd"
+    after 10
+    update
+    string length $x
+} {5}
+test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    after 1 set x ab\0cd
+    after 10
+    update
+    string length $x
+} {5}
+test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    after 1 set x ab\0cd
+    after cancel "set x ab\0ef"
+    set x [llength [after info]]
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x
+} {1}
+test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    after 1 set x ab\0cd
+    after cancel set x ab\0ef
+    set y [llength [after info]]
+    foreach i [after info] {
+	after cancel $i
+    }
+    set y
+} {1}
+test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    after idle "set x ab\0cd"
+    update
+    string length $x
+} {5}
+test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    after idle set x ab\0cd
+    update
+    string length $x
+} {5}
+test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    set x "hello world"
+    set id junk
+    set id [after 10 set x ab\0cd]
+    update
+    set y [string length [lindex [lindex [after info $id] 0] 2]]
+    foreach i [after info] {
+	after cancel $i
+    }
+    set y
+} {5}
+
+set event [after idle foo bar]
+scan $event after#%d id
+
+test timer-7.1 {GetAfterEvent procedure} {
+    list [catch {after info xfter#$id} msg] $msg
+} "1 {event \"xfter#$id\" doesn't exist}"
+test timer-7.2 {GetAfterEvent procedure} {
+    list [catch {after info afterx$id} msg] $msg
+} "1 {event \"afterx$id\" doesn't exist}"
+test timer-7.3 {GetAfterEvent procedure} {
+    list [catch {after info after#ab} msg] $msg
+} {1 {event "after#ab" doesn't exist}}
+test timer-7.4 {GetAfterEvent procedure} {
+    list [catch {after info after#} msg] $msg
+} {1 {event "after#" doesn't exist}}
+test timer-7.5 {GetAfterEvent procedure} {
+    list [catch {after info after#${id}x} msg] $msg
+} "1 {event \"after#${id}x\" doesn't exist}"
+test timer-7.6 {GetAfterEvent procedure} {
+    list [catch {after info afterx[expr $id+1]} msg] $msg
+} "1 {event \"afterx[expr $id+1]\" doesn't exist}"
+after cancel $event
+
+test timer-8.1 {AfterProc procedure} {
+    set x before
+    proc foo {} {
+	set x untouched
+	after 100 {set x after}
+	after 200
+	update
+	return $x
+    }
+    list [foo] $x
+} {untouched after}
+test timer-8.2 {AfterProc procedure} {
+    catch {rename bgerror {}}
+    proc bgerror msg {
+	set ::x $msg
+    }
+    set x empty
+    after 100 {error "After error"}
+    after 200
+    set y $x
+    update
+    catch {rename bgerror {}}
+    list $y $x
+} {empty {After error}}
+
+test timer-8.4 {AfterProc procedure, deleting handler from itself} {
+    foreach i [after info] {
+	after cancel $i
+    }
+    proc foo {} {
+	global x
+	set x {}
+	foreach i [after info] {
+	    lappend x [after info $i]
+	}
+	after cancel foo
+    }
+    after 1000 {error "I shouldn't ever have executed"}
+    after idle foo
+    update idletasks
+    set x
+} {{{error "I shouldn't ever have executed"} timer}}
+
+foreach i [after info] {
+    after cancel $i
+}
+
+testreport