# debug.tcl
#
# Helpers for debugging.
#
#
namespace eval ::_Debug {
}
proc ::_Debug::TRenter {cmd op} {
set fr [info frame -2]
puts "Line [dict get $fr line] Enter: '$cmd'"
}
proc ::_Debug::TRenterstep {cmd op} {
set fr [info frame -2]
#puts "$fr"
puts "Line [dict get $fr line] Enterstep: '$cmd'"
}
proc ::_Debug::TRleave {cmd core res op} {
puts "Leave: '$res'"
}
proc ::_Debug::TRleavestep {cmd code res op} {
puts "Leavestep: '$res'"
}
proc ::_Debug::TR {cmd} {
trace add execution $cmd enter ::_Debug::TRenter
trace add execution $cmd leave ::_Debug::TRleave
trace add execution $cmd enterstep ::_Debug::TRenterstep
trace add execution $cmd leavestep ::_Debug::TRleavestep
}
# Get procs in global namespace
proc ::_Debug::Procs {pat} {
return [uplevel \#0 [list info procs $pat]]
}
proc debugMenu {mW} {
$mW add cascade -label "Debug" -menu $mW.debug -underline 0
menu $mW.debug
if {$::tcl_platform(platform) eq "windows"} {
$mW.debug add checkbutton -label "Console" -variable consolestate \
-onvalue show -offvalue hide -command {console $consolestate} \
-underline 0
$mW.debug add separator
}
$mW.debug add command -label "Edit" -command ::_Debug::ProcEditor \
-underline 0
#::_Debug::DumpStuff
return $mW.debug
}
proc ::_Debug::ProcEditorUpdate {aVal kVal} {
# Only update on keys generating characters
if {$aVal eq "" || ![string is graph $aVal]} return
set p [Procs $::_Debug::ProcEditor(proc)]
if {$p eq "" && $::_Debug::ProcEditor(proc) ne ""} {
# Try prefix matching
set p [Procs $::_Debug::ProcEditor(proc)*]
# Include namespaces if starting with ::
if {[string match "::*" $::_Debug::ProcEditor(proc)]} {
if {[regexp {^(.*::)([^:]*)$} $::_Debug::ProcEditor(proc) -> ns pat]} {
if {[namespace exists $ns]} {
set child [namespace children $ns $pat*]
lappend p {*}$child
}
}
}
}
set p [lsort -dictionary $p]
$::_Debug::ProcEditor(procW) configure -values $p
# Keep the first
set p [lindex $p 0]
if {$p eq ""} {
set ::_Debug::ProcEditor(args) ""
$::_Debug::ProcEditor(bodyW) delete 1.0 end
return
}
if {$p ne $::_Debug::ProcEditor(proc)} {
after idle [list set "::_Debug::ProcEditor(proc)" $p]
after idle [list $::_Debug::ProcEditor(procW) selection range insert end]
}
after idle ::_Debug::ProcEditorSelected
}
proc ::_Debug::ProcEditorSelected {} {
set p [Procs $::_Debug::ProcEditor(proc)]
if {$p eq ""} {
set ::_Debug::ProcEditor(args) ""
$::_Debug::ProcEditor(bodyW) delete 1.0 end
return
}
set arglist {}
foreach i [info args $p] {
if {[info default $p $i value]} {
lappend arglist [list $i $value]
} else {
lappend arglist [list $i]
}
}
set body [info body $p]
set ::_Debug::ProcEditor(args) $arglist
$::_Debug::ProcEditor(bodyW) delete 1.0 end
$::_Debug::ProcEditor(bodyW) insert end $body
}
proc ::_Debug::ProcEditorRedefine {} {
set body [$::_Debug::ProcEditor(bodyW) get 1.0 end]
set body [string trimright $body]
uplevel \#0 [list proc $::_Debug::ProcEditor(proc) \
$::_Debug::ProcEditor(args) $body]
}
proc ::_Debug::ProcEditorDisas {} {
set da [tcl::unsupported::disassemble proc $::_Debug::ProcEditor(proc)]
set top .proceditor.disas
destroy $top
ttk::toplevel $top
wm title $top "Proc Editor Disassemble"
text $top.t -yscrollcommand "$top.sby set"
ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"
grid $top.t $top.sby -padx 3 -pady 3 -sticky news
grid columnconfigure $top 0 -weight 1
grid rowconfigure $top 0 -weight 1
$top.t insert end $da
}
#-----------------------------------------------------------------------------
# Tree view and filter
#-----------------------------------------------------------------------------
proc ::_Debug::ProcEditorFilter {aVal kVal} {
# Only update on keys generating characters
if {$aVal eq "" || ![string is graph $aVal]} return
set f $::_Debug::ProcEditor(filter)
set tree $::_Debug::ProcEditor(treeW)
#foreach item [$tree]
}
proc ::_Debug::TreeCreatePath {tree path} {
if {[$tree exists $path]} return
set parent [namespace qualifiers $path]
TreeCreatePath $tree $parent
set tail [namespace tail $path]
$tree insert $parent end -id $path -text $tail -open 0
}
proc ::_Debug::TreePopulate {tree} {
foreach cmd [lsort -dictionary [array names ::_Debug::allcmds]] {
if {$::_Debug::allcmds($cmd) ne "proc"} continue
set cmd2 [string trim $cmd ":"]
set path [namespace qualifiers $cmd2]
set tail [namespace tail $cmd2]
if {$path ne ""} {
TreeCreatePath $tree $path
}
$tree insert $path end -text $tail -values [list $cmd]
}
}
#-----------------------------------------------------------------------------
# Main Proc Editor window
#-----------------------------------------------------------------------------
proc ::_Debug::ProcEditor {} {
::_Debug::CollectInfo
set top .proceditor
destroy $top
ttk::toplevel $top -padx 3 -pady 3
wm title $top "Proc Editor"
ttk::frame $top.ftree
set ::_Debug::ProcEditor(filter) ""
ttk::entry $top.ftree.ef -textvariable ::_Debug::ProcEditor(filter)
bind $top.ftree.ef <KeyRelease> {::_Debug::ProcEditorFilter %A %K}
set tree $top.ftree.tree
set ::_Debug::ProcEditor(treeW) $tree
ttk::treeview $tree -height 20 -selectmode browse -show "tree" \
-yscrollcommand "$top.ftree.sby set"
ttk::scrollbar $top.ftree.sby -orient vertical -command "$tree yview"
$tree column "#0" -minwidth 50 -width 200
pack $top.ftree.ef -side "top" -fill x -padx 3 -pady 3
pack $top.ftree.sby -side right -fill y -pady 3 -padx {0 3}
pack $tree -fill both -expand 1 -pady 3 -padx {3 0}
TreePopulate $tree
ttk::label $top.l1 -text "Proc" -anchor w
ttk::combobox $top.e1 -textvariable ::_Debug::ProcEditor(proc) -values ""
set ::_Debug::ProcEditor(procW) $top.e1
bind $top.e1 <KeyRelease> {::_Debug::ProcEditorUpdate %A %K}
bind $top.e1 <<ComboboxSelected>> ::_Debug::ProcEditorSelected
#trace add variable ::_Debug::ProcEditor(proc) write "::_Debug::ProcEditorUpdate"
ttk::label $top.l2 -text "Args" -anchor w
ttk::entry $top.e2 -textvariable ::_Debug::ProcEditor(args)
set ::_Debug::ProcEditor(bodyW) [text $top.t -yscrollcommand "$top.sby set"]
ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"
ttk::frame $top.fb
ttk::button $top.b1 -text "Redefine" -command ::_Debug::ProcEditorRedefine
ttk::button $top.b2 -text "Disas" -command ::_Debug::ProcEditorDisas
grid $top.b1 $top.b2 -in $top.fb
grid columnconfigure $top.fb all -weight 1 -uniform a
grid $top.ftree $top.l1 $top.e1 - -padx 3 -pady 3 -sticky we
grid ^ $top.l2 $top.e2 - -padx 3 -pady 3 -sticky we
grid ^ $top.t - $top.sby -padx 3 -pady 3 -sticky news
grid ^ $top.fb - - -padx 3 -pady 3 -sticky we
grid columnconfigure $top 2 -weight 1
grid rowconfigure $top 2 -weight 1
}
# Collect all info about procedures/method/whatever.
# This is work in progress...
proc ::_Debug::CollectInfo {} {
variable allcmds
array set allcmds {}
# Only do this once
if {[array size allcmds] > 0} return
# Find all commands in all namespaces
set todoNs [list ::]
while {[llength $todoNs] != 0} {
set ns [lindex $todoNs 0]
set todoNs [lrange $todoNs 1 end]
set preNs [string trimright $ns ":"]
if {$ns eq "::_Debug"} continue
foreach child [namespace children $ns] {
lappend todoNs $child
}
array unset thisround
array set thisround {}
# First collect commands, since we want to override with detail later
foreach cmd [info commands ${preNs}::*] {
set allcmds($cmd) "cmd"
set thisround($cmd) 1
}
# Which ones are procs?
foreach cmd [info procs ${preNs}::*] {
set allcmds($cmd) "proc"
set thisround($cmd) 0
}
# Which ones are imports?
if { ! [catch {namespace eval $ns {namespace import}} imports]} {
foreach cmd $imports {
set allcmds(${preNs}::$cmd) "import"
set thisround(${preNs}::$cmd) 0
}
}
# Look through and command that is not something identified
foreach cmd [array names thisround] {
if { ! $thisround($cmd)} continue
# Is it an ensemble?
if {[namespace ensemble exists $cmd]} {
set allcmds($cmd) ensemble
foreach {key val} [namespace ensemble configure $cmd] {
#lappend allcmds($cmd) $key $val
if {$key eq "-map"} {
#puts "$cmd $val"
lappend allcmds($cmd) {*}$val
}
# Recognise a snit class
if {$key eq "-unknown" && [string match ::snit::* $val]} {
lset allcmds($cmd) 0 snit
}
}
}
# Is it oo::class?
if { ! [catch {info class methods $cmd -private} methods]} {
set allcmds($cmd) "oo::class $methods"
}
}
# info class
# info object
# How to recognise methods?
#allcmds(::eskilprint) = cmd
#allcmds(::eskilprint::install) = cmd
#allcmds(::eskilprint::Snit_methodnewPage) = proc
#allcmds(::DirCompareTree::Snit_methodaddCmdCol) = proc
#allcmds(::pdf4tcl::pdf4tcl) = cmd
#allcmds(::Account) = cmd
# Namespace ensembles?
}
}
# Debug of debug
proc ::_Debug::DumpStuff {} {
::_Debug::CollectInfo
parray ::_Debug::allcmds *Account*
parray ::_Debug::allcmds *eskilprint*
}
#-----------------------------------------------------------------------------
# Test just to include an OO object in the code
#-----------------------------------------------------------------------------
catch {Account destroy}
oo::class create Account {
constructor {{ownerName undisclosed}} {
my variable total overdrawLimit owner
set total 0
set overdrawLimit 10
set owner $ownerName
}
method deposit amount {
my variable total
set total [expr {$total + $amount}]
}
method withdraw amount {
my variable total overdrawLimit
if {($amount - $total) > $overdrawLimit} {
error "Can't overdraw - total: $total, limit: $overdrawLimit"
}
set total [expr {$total - $amount}]
}
method transfer {amount targetAccount} {
my variable total
my withdraw $amount
$targetAccount deposit $amount
set total
}
method dump {} {
}
destructor {
my variable total
if {$total} {puts "remaining $total will be given to charity"}
}
}