Replaces Tcl's after command by twapi::wait_on_handle to use monotonic timer on Windows

twapi_timer.tcl

package require twapi

if {![namespace exists twapi_timer]} {
namespace eval twapi_timer {
	variable ids
	array set ids {}
}
}

proc twapi_timer::_timer_handler {script hevent sig} {
	cancel $hevent
	uplevel #0 $script
} 

proc twapi_timer::handle_type {hevent} {
	set arg1 [lindex $hevent 0]
	set arg2 [lindex $hevent 1]
	if {[string is integer -strict $arg1] && "HANDLE" eq $arg2} {
		set type "hevent"
	} elseif {[string match "after\#*" $hevent]} {
		set type "after"
	} else {
		set type "script"
	}
	return $type
}

proc twapi_timer::after {args} {
	variable ids
	set argc [llength $args]
	switch -exact -- $argc {
	0 {
		::tcl_after
	}
	1 {
		set arg0 [lindex $args 0]
		switch -exact -- $arg0 {
		info {
			return [array names ids]
		}
		default {
			set ms $arg0
			set hevent [twapi_timer::create_event]
			twapi::wait_on_handle $hevent -wait $ms
			return
		}
		}
	}
	2 {
		set arg0 [lindex $args 0]
		set arg1 [lindex $args 1]
		switch -exact -- $arg0 {
		cancel {
			switch -exact -- [handle_type $arg1] {
			hevent -
			after {
				set hevent $arg1
				cancel $hevent
			}
			script {
				set script $arg1
				foreach hevent [array names ids] {
					if {$script eq $ids($hevent)} {
						cancel $hevent
					}
				}
			}
			}
			return
		}
		idle {
			set script $arg1
			set hevent [::tcl_after idle $script]
			return $hevent
		}
		info {
			set hevent [lindex $args 1]
			if {[info exists ids($hevent)]} {
				set script $ids($hevent)
				return [list $script timer]
			} else {
				return
			}
		}
		default {
			set ms $arg0
			set script [lindex $args 1]
		}
		}
	}
	default {
		set arg0 [lindex $args 0]
		set script [lrange $args 1 end]
		switch -exact -- $arg0 {
		cancel {
			foreach hevent [array names ids] {
				if {$script eq $ids($hevent)} {
					cancel $hevent
				}
			}
			return
		}
		idle {
			set hevent [::tcl_after idle $script]
			return $hevent
		}
		default {
			set ms $arg0
		}
		}
	}
	}
	set hevent [twapi_timer::create_event]
	twapi::wait_on_handle $hevent -wait $ms -async [namespace code [list _timer_handler $script]]
	set ids($hevent) $script
	return $hevent
}

proc twapi_timer::create_event {} {
	variable ids
	set hevent [twapi::create_event]
	if {[info exists ids($hevent)]} {
		twapi_timer::_close_handle $hevent
		set hevent [create_event]
	}
	return $hevent
}

proc twapi_timer::cancel {hevent} {
	variable ids
	if {[info exists ids($hevent)]} {
		switch [handle_type $hevent] {
		hevent {
			if {[catch {twapi::cancel_wait_on_handle $hevent} err]} {
				log Debg "twapi::cancel_wait_on_handle $hevent -> err=$err"
			}
			_close_handle $hevent
		}
		after {
			::tcl_after cancel $hevent
		}
		}
		array unset ids $hevent
	}
}

proc twapi_timer::_close_handle {hevent} {
	if {[catch {twapi::close_handle $hevent} err]} {
		log Debg "twapi::close_handle $hevent -> err=$err"
	}
}

if {[info commands ::tcl_after] ne "::tcl_after"} {
rename ::after ::tcl_after
interp alias {} ::after {} ::twapi_timer::after
}