tkgoodstuff/tcl/FvwmDebug.tcl

118 lines
3.8 KiB
Tcl
Executable File

# FvwmDebug (tkgoodstuff client)
proc FvwmDebugDoOnLoad {} {
if [string match "" [info commands fvwm]] {
TKGError "FvwmDebug client will not work unless fvwm starts\
tkgoodstuff as an fvwm module." exit
}
}
proc FvwmDebugCreateWindow {} {
uplevel {
fvwm send $Fvwm(outid) "Style fvwmdebug Sticky"
toplevel .fvwmdebug
wm geometry .fvwmdebug +0+100
set fvparams {pagex pagey npagex npagey maxpagex maxpagey desktop focus}
pack [frame .fvwmdebug.simple -relief raised -bd 1] -fill x -anchor w
pack [frame .fvwmdebug.simple.title1]
pack [frame .fvwmdebug.simple.entries]
foreach v $fvparams {
pack [label .fvwmdebug.simple.title1.l$v -text $v -width 11] -side left
pack [label .fvwmdebug.simple.entries.e$v -textvariable FvwmW($v) \
-width 11 -background lightblue] -side left
}
set fparams1 {x y w h t npagex npagey iconic iconx icony iconw iconh}
set fparams2 {flags windowname iconname resname resclass mapped}
pack [frame .fvwmdebug.grid -relief raised -bd 1] -fill x -anchor w
pack [frame .fvwmdebug.grid.title1] -anchor w
pack [label .fvwmdebug.grid.title1.id -text ID -width 10] -side left
foreach v $fparams1 {
pack [label .fvwmdebug.grid.title1.l$v -text $v -width 7] -side left
}
pack [frame .fvwmdebug.grid.title2] -anchor w
pack [label .fvwmdebug.grid.title2.id -width 10] -side left
foreach v $fparams2 {
pack [label .fvwmdebug.grid.title2.l$v -text $v -width 15 -foreground red] -side left
}
TKGAddToHook Fvwm_ConfigureWindow_hook FvwmDebug-wl-update
set fevents1 {
AddWindow
ConfigureWindow
NewPage
NewDesk
WindowName
IconName
}
set fevents2 {
ResName
ResClass
DestroyWindow
FocusChange
Iconify
IconLocation
Deiconify
Map
}
pack [frame .fvwmdebug.numevents1 -relief raised -bd 1] -fill x
foreach v $fevents1 {
set FvwmDebug-$v 0
set w .fvwmdebug.numevents1.[string tolower $v]
pack [frame $w] -expand y -fill x -side left
pack [label $w.name -text $v] -side top -expand n
pack [label $w.num -width 5 -textvariable FvwmDebug-$v \
-background lightblue] -side top -expand n
TKGAddToHook Fvwm_[set v]_hook FvwmDebug-update-$v
proc FvwmDebug-update-$v args [subst {
global FvwmDebug-$v
incr FvwmDebug-$v
}]
}
pack [frame .fvwmdebug.numevents2 -relief raised -bd 1] -fill x
foreach v $fevents2 {
set FvwmDebug-$v 0
set w .fvwmdebug.numevents2.[string tolower $v]
pack [frame $w] -expand y -fill x -side left
pack [label $w.name -text $v] -side top -expand n
pack [label $w.num -width 5 -textvariable FvwmDebug-$v\
-background lightblue] -side top -expand n
TKGAddToHook Fvwm_[set v]_hook FvwmDebug-update-$v
proc FvwmDebug-update-$v args [subst {
global FvwmDebug-$v
incr FvwmDebug-$v
}]
}
TKGAddToHook Fvwm_DestroyWindow_hook FvwmDebug-destroy
}
}
proc FvwmDebug-wl-update args {
global FvwmW FvwmWL fparams1 fparams2
if ![winfo exists .fvwmdebug] return
foreach id [lsort [array names FvwmWL]] {
set w .fvwmdebug.grid.w$id
if ![winfo exists $w] {
pack [frame $w -relief raised -bd 2] -side top -anchor w
pack [label $w.l -text $id -width 10] -in $w -side left
pack [frame $w.w] -side left -in $w -anchor w
set w $w.w
pack [frame $w.w1] -side top -in $w -anchor w
foreach v $fparams1 {
pack [label $w.w1e$v -textvariable FvwmW($id,$v) -width 7 -relief sunken\
-background lightblue] -in $w.w1 -side left
}
pack [frame $w.w2] -side top -anchor w
foreach v $fparams2 {
pack [label $w.w1e$v -textvariable FvwmW($id,$v) -width 15 -relief sunken -anchor w\
-foreground red -background lightblue] -in $w.w2 -side left
}
}
}
}
proc FvwmDebug-destroy {id} {
if ![winfo exists .fvwmdebug] return
.fvwmdebug.grid.w[set id].l configure -foreground gray30
}
DEBUG "Loaded FvwmDebug.tcl"