68 lines
1.5 KiB
68 lines
1.5 KiB
# -*- tcl -* |
|
# Debug -- Heartbeat. Track operation of Tcl's eventloop. |
|
# -- Colin McCormack / originally Wub server utilities |
|
|
|
# # ## ### ##### ######## ############# ##################### |
|
## Requisites |
|
|
|
package require Tcl 8.5 |
|
package require debug |
|
|
|
namespace eval ::debug { |
|
namespace export heartbeat |
|
namespace ensemble create |
|
} |
|
|
|
# # ## ### ##### ######## ############# ##################### |
|
## API & Implementation |
|
|
|
proc ::debug::heartbeat {{delta 500}} { |
|
variable duration $delta |
|
variable timer |
|
|
|
if {$duration > 0} { |
|
# stop a previous heartbeat before starting the next |
|
catch { after cancel $timer } |
|
on heartbeat |
|
::debug::every $duration { |
|
debug.heartbeat {[::debug::pulse]} |
|
} |
|
} else { |
|
catch { after cancel $timer } |
|
off heartbeat |
|
} |
|
} |
|
|
|
proc ::debug::every {ms body} { |
|
eval $body |
|
variable timer [after $ms [info level 0]] |
|
return |
|
} |
|
|
|
proc ::debug::pulse {} { |
|
variable duration |
|
variable hbtimer |
|
variable heartbeat |
|
|
|
set now [::tcl::clock::milliseconds] |
|
set diff [expr {$now - $hbtimer - $duration}] |
|
|
|
set hbtimer $now |
|
|
|
return [list [incr heartbeat] $diff] |
|
} |
|
|
|
# # ## ### ##### ######## ############# ##################### |
|
|
|
namespace eval ::debug { |
|
variable duration 0 ; # milliseconds between heart-beats |
|
variable heartbeat 0 ; # beat counter |
|
variable hbtimer [::tcl::clock::milliseconds] |
|
variable timer |
|
} |
|
|
|
# # ## ### ##### ######## ############# ##################### |
|
## Ready |
|
|
|
package provide debug::heartbeat 1.0.1 |
|
return
|
|
|