# debug.tcl
#
# Helpers for debugging.
#
#
namespace eval ::_Debug {
}
#-----------------------------------------------------------------------------
# Tracing
#-----------------------------------------------------------------------------
proc ::_Debug::TRenter {cmd op} {
set fr [info frame -2]
set line X
if {[dict exists $fr line]} {
set line [dict get $fr line]
}
puts "Line $line Enter: '$cmd'"
}
proc ::_Debug::TRenterstep {cmd op} {
set fr [info frame -2]
set line X
if {[dict exists $fr line]} {
set line [dict get $fr line]
}
puts "Line $line Enterstep: '$cmd'"
}
proc ::_Debug::TRleave {cmd code res op} {
puts "Leave: '$res'"
}
proc ::_Debug::TRleavestep {cmd code res op} {
puts "Leavestep: '$res'"
}
proc ::_Debug::TR {cmd {step 0}} {
TRoff $cmd
trace add execution $cmd enter ::_Debug::TRenter
trace add execution $cmd leave ::_Debug::TRleave
if {$step} {
trace add execution $cmd enterstep ::_Debug::TRenterstep
trace add execution $cmd leavestep ::_Debug::TRleavestep
}
}
proc ::_Debug::TRoff {cmd} {
trace remove execution $cmd enter ::_Debug::TRenter
trace remove execution $cmd leave ::_Debug::TRleave
trace remove execution $cmd enterstep ::_Debug::TRenterstep
trace remove execution $cmd leavestep ::_Debug::TRleavestep
}
#-----------------------------------------------------------------------------
# GUI
#-----------------------------------------------------------------------------
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
#after 500 ::_Debug::DumpStuff
#after 500 ::_Debug::ProcEditor
return $mW.debug
}
#-----------------------------------------------------------------------------
# Procedure/method editor
#-----------------------------------------------------------------------------
# An item was selected. Show it and make it editable.
proc ::_Debug::ProcEditorSelected {} {
variable allcmds
set ::_Debug::ProcEditor(current) ""
set ::_Debug::ProcEditor(parent) ""
set ::_Debug::ProcEditor(proc) ""
set ::_Debug::ProcEditor(args) ""
$::_Debug::ProcEditor(bodyW) delete 1.0 end
set tree $::_Debug::ProcEditor(treeW)
set items [$tree selection]
if {[llength $items] < 1} return
set item [lindex $items 0]
set d $allcmds($item)
set type [dict get $d type]
set parent [dict get $d parent]
set name [dict get $d name]
set ::_Debug::ProcEditor(current) $item
set ::_Debug::ProcEditor(parent) $parent
set ::_Debug::ProcEditor(proc) $name
set ::_Debug::ProcEditor(args) ""
$::_Debug::ProcEditor(bodyW) delete 1.0 end
set traceState normal
if {$type eq "proc"} {
set arglist {}
foreach i [info args $item] {
if {[info default $item $i value]} {
lappend arglist [list $i $value]
} else {
lappend arglist [list $i]
}
}
set body [info body $item]
set ::_Debug::ProcEditor(args) $arglist
$::_Debug::ProcEditor(bodyW) insert end $body
} elseif {$type eq "method"} {
lassign [info class definition $parent $name] arglist body
set traceState disabled
set ::_Debug::ProcEditor(args) $arglist
$::_Debug::ProcEditor(bodyW) insert end $body
} else {
set traceState disabled
}
foreach w $::_Debug::ProcEditor(traceWs) {
$w configure -state $traceState
}
}
# Redefine currently edited proc/method
proc ::_Debug::ProcEditorRedefine {} {
variable allcmds
set body [$::_Debug::ProcEditor(bodyW) get 1.0 end]
set body [string trimright $body]
set item $::_Debug::ProcEditor(current)
set d $allcmds($item)
set type [dict get $d type]
set parent [dict get $d parent]
set name [dict get $d name]
if {$type eq "proc"} {
set todo [list proc $item \
$::_Debug::ProcEditor(args) $body]
set ::_Debug::redefines($item) $todo
uplevel \#0 $todo
} elseif {$type eq "method"} {
set todo [list oo::define $parent method $name \
$::_Debug::ProcEditor(args) $body]
set ::_Debug::redefines($parent..$name) $todo
uplevel \#0 $todo
}
}
proc ::_Debug::ProcEditorCopy {} {
clipboard clear
foreach item [array names ::_Debug::redefines] {
clipboard append $::_Debug::redefines($item)\n
}
}
# Tracing of commands
proc ::_Debug::ProcEditorTrace {level} {
variable allcmds
set item $::_Debug::ProcEditor(current)
set d $allcmds($item)
set type [dict get $d type]
set parent [dict get $d parent]
set name [dict get $d name]
if {$type ni "proc method"} return
# TODO: methods
if {$type eq "proc"} {
if {$level == 1} {
TR $item
} elseif {$level == 2} {
TR $item 1
} else {
TRoff $item
}
}
}
# Disassemble of current
proc ::_Debug::ProcEditorDisas {} {
variable allcmds
set item $::_Debug::ProcEditor(current)
set d $allcmds($item)
set type [dict get $d type]
set parent [dict get $d parent]
set name [dict get $d name]
if {$type ni "proc method"} return
if {$type eq "proc"} {
set da [tcl::unsupported::disassemble proc $item]
} else {
set da [tcl::unsupported::disassemble method $parent $name]
}
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
}
# Treeview filtering. React on keystroke
proc ::_Debug::ProcEditorFilter {aVal kVal} {
set f $::_Debug::ProcEditor(filter)
set fx $::_Debug::ProcEditor(filterx)
# Do not react unless changed.
if {$f eq $fx} {
return
}
set tree $::_Debug::ProcEditor(treeW)
# Recreate the tree.
# This is easier since the treeview does not have an item hide attribute.
set pat *$f*
TreePopulate $tree $pat
set ::_Debug::ProcEditor(filterx) $f
}
# Make sure the hierarchy for a leaf exist, creating if needed.
proc ::_Debug::TreeCreatePath {tree path} {
if {[$tree exists $path]} return
set d $::_Debug::allcmds($path)
set parent [dict get $d parent]
if {$path ni {"" ::}} {
TreeCreatePath $tree $parent
}
set text [dict get $d name]
if {$parent eq "::"} {
set parent ""
}
$tree insert $parent end -id $path -text $text -open 1 \
-values [list $parent]
}
# Populate the treeview with all known procs and methods
proc ::_Debug::TreePopulate {tree {filter *}} {
$tree delete [$tree children {}]
foreach cmd [lsort -dictionary [array names ::_Debug::allcmds]] {
set d $::_Debug::allcmds($cmd)
set type [dict get $d type]
if {$type ni "proc method"} continue
if { ! [string match -nocase $filter [dict get $d name]]} continue
set path [dict get $d parent]
if {$path ne ""} {
TreeCreatePath $tree $path
}
$tree insert $path end -id $cmd \
-text [dict get $d name] -values [list $path]
}
}
# 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) ""
set ::_Debug::ProcEditor(filterx) ""
ttk::entry $top.ftree.ef -textvariable ::_Debug::ProcEditor(filter)
addBalloon $top.ftree.ef "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 tag configure highlight -background pink
$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
bind $tree <<TreeviewSelect>> ::_Debug::ProcEditorSelected
ttk::label $top.l1a -text "Parent" -anchor w
ttk::label $top.l1b -textvariable ::_Debug::ProcEditor(parent) -anchor w
ttk::label $top.l2a -text "Proc/Method" -anchor w
ttk::label $top.l2b -textvariable ::_Debug::ProcEditor(proc) -anchor w
ttk::label $top.l3a -text "Args" -anchor w
ttk::label $top.l3b -textvariable ::_Debug::ProcEditor(args) -anchor w
ttk::button $top.bc -text "Copy" -command ::_Debug::ProcEditorCopy
addBalloon $top.bc "Put all redefines on clipboard"
set ::_Debug::ProcEditor(bodyW) [text $top.t -yscrollcommand "$top.sby set" \
-width 90]
ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"
ttk::frame $top.fb
ttk::button $top.b1 -text "Redefine" -command ::_Debug::ProcEditorRedefine
addBalloon $top.b1 "Redefine for this session"
ttk::button $top.b2 -text "Disas" -command ::_Debug::ProcEditorDisas
addBalloon $top.b2 "Show byte code"
ttk::button $top.b3 -text "Trace" -command "::_Debug::ProcEditorTrace 1"
addBalloon $top.b3 "Enable execution trace"
ttk::button $top.b4 -text "Tr Step" -command "::_Debug::ProcEditorTrace 2"
addBalloon $top.b4 "Enable detailed execution trace"
ttk::button $top.b5 -text "Tr Off" -command "::_Debug::ProcEditorTrace 0"
addBalloon $top.b5 "Disable execution trace"
set ::_Debug::ProcEditor(traceWs) [list $top.b3 $top.b4 $top.b5]
grid $top.b1 $top.b2 $top.b3 $top.b4 $top.b5 -in $top.fb
grid columnconfigure $top.fb all -weight 1 -uniform a
grid $top.ftree $top.l1a $top.l1b - $top.bc - -padx 3 -pady 3 -sticky news
grid ^ $top.l2a $top.l2b - - - -padx 3 -pady 3 -sticky we
grid ^ $top.l3a $top.l3b - - - -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 $top.t -weight 1
}
#-----------------------------------------------------------------------------
# Procedure/method information collection
#-----------------------------------------------------------------------------
#
# There is nuances to namespace handling that needs awareness.
#
# "parent" operates on just existing namespaces and cannot be used on
# procedures. It returns a normalized name, with a slight gotcha that
# top namespace is "::", thus ending in colons. Thus this cannot be used
# directly for joining without care.
# % namespace parent ::eskil::rev
# ::eskil
# % namespace parent eskil::rev
# ::eskil
# % namespace parent ::eskil
# ::
# % namespace parent ::
#
# "qualifier" pairs with "tail"
# It just parses the string and does not need to make sense.
# Thus this can be used on qualified procedure names.
# % namespace qualifier ::eskil::rev
# ::eskil
# % namespace qualifier eskil::rev
# eskil
# % namespace qualifier ::eskil
#
# Ditto with "tail"
# % namespace tail ::eskil::rev
# rev
# % namespace tail ::eskil
# eskil
# % namespace tail ::
#
# "children", like "parent", operates on real namespace and normalizes.
# % namespace children ::eskil
# ::eskil::rev
# % namespace children ::eskil::
# ::eskil::rev
# % namespace children ""
# ::eskil ::zlib ::pkg ::oo ::tcl
#
# Conclusion:
# If a namespace is always kept with "::" at the end things are mostly easy.
# "parent" and "children" will work, as well as joining with $parent$tail.
# This cannot be used with "qualifiers", so extra care is needed there.
# The helpers below handles this.
# Parent namespace. Always ends with ::
proc ::_Debug::Qualifiers {ns} {
set ns [string trimright $ns ":"]
set q [namespace qualifiers $ns]
if { ! [string match *:: $q]} {
append q ::
}
return $q
}
# Parent namespace. Always ends with ::
proc ::_Debug::Parent {ns} {
set p [namespace parent $ns]
if { ! [string match *:: $p]} {
append p ::
}
return $p
}
# allcmds structure:
# fullId for different things:
# proc: Its qualified namespace path. Name = leaf
# namespace: Its qualified namespace path ending in ::. Name = leaf::
# class: Its qualified namespace path. Name = leaf
# method: A list of class id + method. Name = method
# allcmds(fullId) = dict:
# type = proc/namespace/class/method/import
# parent = fullId of parent/class
# name = leaf name
# origin = for import
# 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 nsId [lindex $todoNs 0]
set todoNs [lrange $todoNs 1 end]
if {$nsId eq "::_Debug::"} continue
set tail [namespace tail [string trimright $nsId ":"]]
dict set allcmds($nsId) type namespace
dict set allcmds($nsId) parent [Parent $nsId]
dict set allcmds($nsId) name ${tail}::
foreach child [namespace children $nsId] {
lappend todoNs ${child}::
}
array unset thisround
array set thisround {}
# First collect commands, since we want to override with detail later
foreach cmd [info commands $nsId*] {
dict set allcmds($cmd) type "cmd"
dict set allcmds($cmd) parent [Qualifiers $cmd]
dict set allcmds($cmd) name [namespace tail $cmd]
set thisround($cmd) 1
}
# Which ones are procs?
foreach cmd [info procs $nsId*] {
dict set allcmds($cmd) type "proc"
dict set allcmds($cmd) parent [Qualifiers $cmd]
dict set allcmds($cmd) name [namespace tail $cmd]
set thisround($cmd) 0
}
# Which ones are imports?
if { ! [catch {namespace eval $nsId {namespace import}} imports]} {
foreach cmd $imports {
dict set allcmds($nsId$cmd) type "import"
dict set allcmds($nsId$cmd) origin \
[namespace origin $nsId$cmd]
set thisround($nsId$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]} {
#puts "ENSEMBLE $cmd"
dict set allcmds($cmd) type ensemble
foreach {key val} [namespace ensemble configure $cmd] {
#lappend allcmds($cmd) $key $val
if {$key eq "-map"} {
#puts "$cmd $val"
dict lappend allcmds($cmd) maps {*}$val
}
# Recognise a snit class
if {$key eq "-unknown" && [string match ::snit::* $val]} {
#puts "SNIT? $cmd"
#lset allcmds($cmd) 0 snit
}
}
set thisround($cmd) 0
continue
}
}
# Namespace ensembles?
}
# Go through tcloo classes
set todoObj [list ::oo::object]
while {[llength $todoObj] != 0} {
set obj [lindex $todoObj 0]
set todoObj [lrange $todoObj 1 end]
dict set allcmds($obj) type class
dict set allcmds($obj) parent [Qualifiers $obj]
dict set allcmds($obj) name [namespace tail $obj]
foreach child [info class subclasses $obj] {
lappend todoObj $child
}
foreach m [info class methods $obj -private] {
set id [list $obj $m]
dict set allcmds($id) type method
dict set allcmds($id) parent $obj
dict set allcmds($id) name $m
}
}
}
# Debug of debug
proc ::_Debug::DumpStuff {} {
try {
::_Debug::CollectInfo
} on error {res i} {
puts $res
puts $i
after 1000
}
# Proc
parray ::_Debug::allcmds *updateColors*
parray ::_Debug::allcmds *cleanupAndExit
# Cmd
parray ::_Debug::allcmds *ttk::paned
parray ::_Debug::allcmds *llength
# OO class
parray ::_Debug::allcmds *Account*
# Snit class
parray ::_Debug::allcmds *eskilprint*
#
parray ::_Debug::allcmds *indexEntry*
exit
}
#-----------------------------------------------------------------------------
# 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 {} {
#HoHA
}
destructor {
my variable total
if {$total} {puts "remaining $total will be given to charity"}
}
}