/usr/share/tcltk/tcllib1.19/debug/heartbeat.tcl is in tcllib 1.19-dfsg-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | # -*- 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
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
return
|