#---------------------------------------------------------*-tcl-*------
#
# psdebug.tcl,
# Helpers for debugging.
#
# Copyright (c) 2024, Peter Spjuth (peter.spjuth@gmail.com)
#
# Permission is granted to use this code under the same terms as
# for the Tcl core code.
#
#----------------------------------------------------------------------
# This is used as a Tcl Module. Use it like this:
# ::tcl::tm::path add <path-to-dir-with-module>
# package require psdebug
# namespace import ::_PsDebug::*
#----------------------------------------------------------------------
package provide psdebug 1.0
namespace eval ::_PsDebug {
variable allcmds
namespace export debugMenu
}
#-----------------------------------------------------------------------------
# Misc useful stuff
#-----------------------------------------------------------------------------
proc ::_PsDebug::dumpMyMemUsage {str} {
try {
set xx [exec ps --pid [pid] --format vsize]
set mem 0
regexp {\d+} $xx mem
puts "$str : memory usage $mem"
} on error {} {
puts "$str : memory usage unknown, call to ps failed"
}
}
#-----------------------------------------------------------------------------
# Tracing
#-----------------------------------------------------------------------------
proc ::_PsDebug::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 ::_PsDebug::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 ::_PsDebug::TRleave {cmd code res op} {
puts "Leave: '$res'"
}
proc ::_PsDebug::TRleavestep {cmd code res op} {
puts "Leavestep: '$res'"
}
proc ::_PsDebug::TR {cmd {step 0}} {
TRoff $cmd
trace add execution $cmd enter ::_PsDebug::TRenter
trace add execution $cmd leave ::_PsDebug::TRleave
if {$step} {
trace add execution $cmd enterstep ::_PsDebug::TRenterstep
trace add execution $cmd leavestep ::_PsDebug::TRleavestep
}
}
proc ::_PsDebug::TRoff {cmd} {
trace remove execution $cmd enter ::_PsDebug::TRenter
trace remove execution $cmd leave ::_PsDebug::TRleave
trace remove execution $cmd enterstep ::_PsDebug::TRenterstep
trace remove execution $cmd leavestep ::_PsDebug::TRleavestep
}
#-----------------------------------------------------------------------------
# GUI
#-----------------------------------------------------------------------------
proc ::_PsDebug::debugMenu {mW args} {
if {"-append" in $args} {
set dW $mW
} else {
set dW $mW.debug
$mW add cascade -label "Debug" -menu $dW -underline 0
menu $dW
}
if {$::tcl_platform(platform) eq "windows"} {
$dW add checkbutton -label "Console" -variable ::consoleState \
-onvalue show -offvalue hide -command {console $::consoleState} \
-underline 0
$dW add separator
}
$dW add command -label "Edit" -command ::_PsDebug::ProcEditor \
-underline 0
$dW add command -label "Windows" -command ::_PsDebug::WindowBrowser \
-underline 0
return $dW
}
#-----------------------------------------------------------------------------
# Window structure browser
#-----------------------------------------------------------------------------
proc ::_PsDebug::WindowBrowser {} {
set top .windowbrowser
destroy $top
tk::toplevel $top -padx 3 -pady 3
place [ttk::frame $top.tilebg] -border outside \
-x 0 -y 0 -relwidth 1 -relheight 1
wm title $top "Window Browser"
wm protocol $top WM_DELETE_WINDOW [list ::_PsDebug::WindowBrowserClosed $top]
ttk::panedwindow $top.pw -orient horizontal
pack $top.pw -fill both -expand 1
# Widget Tree
ttk::frame $top.ftree
set tree $top.ftree.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.sby -side right -fill y -pady 3 -padx {0 3}
pack $tree -fill both -expand 1 -pady 3 -padx {3 0}
# Info Text
text $top.t -width 80 -wrap word
set ::_PsDebug::WindowBrowser(treeW) $tree
set ::_PsDebug::WindowBrowser(textW) $top.t
bind $tree <<TreeviewSelect>> ::_PsDebug::WindowBrowserSelected
$top.pw add $top.ftree -weight 1
$top.pw add $top.t -weight 2
set ::_PsDebug::WindowBrowser(deselect) ""
PopulateWindowBrowser $tree
}
proc ::_PsDebug::WindowBrowserClosed {top} {
destroy $top
if {$::_PsDebug::WindowBrowser(deselect) ne ""} {
{*}$::_PsDebug::WindowBrowser(deselect)
set ::_PsDebug::WindowBrowser(deselect) ""
}
}
# An item was selected. Show info
proc ::_PsDebug::WindowBrowserSelected {} {
$::_PsDebug::WindowBrowser(textW) delete 1.0 end
if {$::_PsDebug::WindowBrowser(deselect) ne ""} {
#puts "DESEL: $::_PsDebug::WindowBrowser(deselect)"
{*}$::_PsDebug::WindowBrowser(deselect)
set ::_PsDebug::WindowBrowser(deselect) ""
}
set tree $::_PsDebug::WindowBrowser(treeW)
set items [$tree selection]
if {[llength $items] < 1} return
set item [lindex $items 0]
set values [$tree item $item -values]
set d [lindex $values 0]
set txt [dict get $d out]
$::_PsDebug::WindowBrowser(textW) insert end $txt
set interp [dict get $d interp]
set i [list interp eval $interp]
set w [dict get $d w]
# A few experiments to highlight selection.
try {
# Overlaid frame seems to work best
set tl [{*}$i winfo toplevel $w]
set wx [expr [{*}$i winfo rootx $w] - [{*}$i winfo rootx $tl]]
set wy [expr [{*}$i winfo rooty $w] - [{*}$i winfo rooty $tl]]
set ww [{*}$i winfo width $w]
set wh [{*}$i winfo height $w]
set cleancmd ""
if {$tl eq "."} {
set tl ""
}
for {set t 1} {$t <= 4} {incr t} {
set whl($t) $tl._debug_hl_$t
destroy $whl($t)
append cleancmd [list destroy $whl($t)]\;
frame $whl($t) -background red
}
place $whl(1) -x $wx -y $wy -width $ww -height 3
place $whl(2) -x $wx -y $wy -width 3 -height $wh
place $whl(3) -x [+ $wx $ww] -y $wy -width 3 -height $wh
place $whl(4) -x $wx -y [+ $wy $wh] -width $ww -height 3
set ::_PsDebug::WindowBrowser(deselect) \
[list eval $cleancmd]
return
} on error {err info} {
#puts "In $interp"
#puts "$err"
#puts "$info"
}
try {
# Reconfiguring class. Does not work with disabled buttons e.g.
set class [{*}$i winfo class $w]
set oldstyle [{*}$i $w cget -style]
if {$oldstyle eq ""} {
set basestyle $class
} else {
set basestyle $oldstyle
}
set style HighLightRed.$basestyle
{*}$i ttk::style configure $style -background red -fieldbackground red
{*}$i $w configure -style $style
set ::_PsDebug::WindowBrowser(deselect) \
[list {*}$i [list $w configure -style $oldstyle]]
#puts "CLASS $class STYLE $style"
#puts [{*}$i ttk::style configure $basestyle]
#puts [{*}$i ttk::style configure $style]
return
} on error {err info} {
#puts "In $interp"
#puts "$err"
#puts "$info"
}
try {
# Tk style background change. Only works with Tk.
set bg [{*}$i $w cget -background]
{*}$i $w configure -background red
set ::_PsDebug::WindowBrowser(deselect) \
[list {*}$i [list $w configure -background $bg]]
return
} on error {err info} {
#puts "In $interp"
#puts "$err"
#puts "$info"
}
#puts "MOO $w"
}
# Format configure data from a widget for display
proc ::_PsDebug::FormatConfigure {configData} {
set first ""
set last ""
foreach param $configData {
lassign $param flag _ _ def value
if {$value ne $def} {
# List changed values first
append first "[list $flag $value] "
} else {
append last "[list $flag $value] "
}
}
set first [string trim $first]
set last [string trim $last]
if {$first ne ""} {
set first "Changed Parameters:\n$first\n"
}
if {$last ne ""} {
append first "Default Parameters:\n" $last
}
return [string trim $first]
}
# Populate
proc ::_PsDebug::PopulateWindowBrowser {tree} {
$tree delete [$tree children {}]
set todo [list . {}]
# Outer loop for subinterps TBD
while {[llength $todo] > 0} {
set containers {}
while {[llength $todo] > 0} {
# POP
set w [lindex $todo 0]
set interp [lindex $todo 1]
set i [list interp eval $interp]
set todo [lrange $todo 2 end]
set long $interp$w
if {$w in {.windowbrowser}} continue
foreach child [lsort -dictionary [{*}$i winfo children $w]] {
lappend todo $child $interp
}
set id($long) "N$long"
if {[info exists parents($long)]} {
# Parent passed from other interp
set parentId $id($parents($long))
} else {
set parent [{*}$i winfo parent $w]
if {$parent eq ""} {
set parentId ""
} else {
set parentId $id($interp$parent)
}
}
set class [{*}$i winfo class $w]
# Info to be displayed
set out "$w ($class)\n"
set configData [{*}$i $w configure]
append out [FormatConfigure $configData]
foreach param $configData {
lassign $param flag _ _ def value
if {$flag eq "-container" && $value == 1} {
lappend containers $w $interp
}
}
# Add grid info, if any
try {
set ix [{*}$i grid info $w]
if {$ix ne ""} {
append out "\n\ngrid\n$ix"
}
} on error {} {}
# Add pack info, if any
try {
set ix [{*}$i pack info $w]
if {$ix ne ""} {
append out "\n\npack\n$ix"
}
} on error {} {}
# Add menu info, if menu
try {
set last [{*}$i $w index end]
for {set ix 0} {$ix <= $last} {incr ix} {
set configData [{*}$i $w entryconfigure $ix]
append out \n\n [FormatConfigure $configData]
}
} trap {TCL LOOKUP INDEX} {} {
# Non-menu widgets will normally error out on not having the
# "index" subcommand, which ends up here. Ignore.
} on error {msg erri} {
# Give some hint on other errors
#puts "MOOO $msg\n$erri"
}
set name $w
regexp {\.[^.]+$} $w name
set open 1
if {[string match "*#*" $w]} {
set open 0
}
set d {}
dict set d w $w
dict set d interp $interp
dict set d id $id($long)
dict set d out $out
$tree insert $parentId end -id $id($long) -open $open \
-text $name -values [list $d]
}
# TODO: Handle -container and subinterp? How?
foreach {w interp} $containers {
set wid [winfo id $w]
foreach sub [interp slaves $interp] {
try {
set subId [interp eval $sub . cget -use]
if {$subId == $wid} {
#puts "Found interp $sub for $w"
set parents($sub.) $interp$w
lappend todo . $sub
}
} on error {} {}
}
}
#break
}
}
#-----------------------------------------------------------------------------
# Procedure/method editor
#-----------------------------------------------------------------------------
# An item was selected. Show it and make it editable.
proc ::_PsDebug::ProcEditorSelected {} {
variable allcmds
set ::_PsDebug::ProcEditor(current) ""
set ::_PsDebug::ProcEditor(parent) ""
set ::_PsDebug::ProcEditor(proc) ""
set ::_PsDebug::ProcEditor(args) ""
$::_PsDebug::ProcEditor(bodyW) delete 1.0 end
set tree $::_PsDebug::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 ::_PsDebug::ProcEditor(current) $item
set ::_PsDebug::ProcEditor(parent) $parent
set ::_PsDebug::ProcEditor(proc) $name
set ::_PsDebug::ProcEditor(args) ""
$::_PsDebug::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 ::_PsDebug::ProcEditor(args) $arglist
$::_PsDebug::ProcEditor(bodyW) insert end $body
} elseif {$type eq "method"} {
lassign [info class definition $parent $name] arglist body
set traceState disabled
set ::_PsDebug::ProcEditor(args) $arglist
$::_PsDebug::ProcEditor(bodyW) insert end $body
} else {
set traceState disabled
}
foreach w $::_PsDebug::ProcEditor(traceWs) {
$w configure -state $traceState
}
}
# Redefine currently edited proc/method
proc ::_PsDebug::ProcEditorRedefine {} {
variable allcmds
set body [$::_PsDebug::ProcEditor(bodyW) get 1.0 end]
set body [string trimright $body]
set item $::_PsDebug::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 \
$::_PsDebug::ProcEditor(args) $body]
set ::_PsDebug::redefines($item) $todo
uplevel \#0 $todo
} elseif {$type eq "method"} {
set todo [list oo::define $parent method $name \
$::_PsDebug::ProcEditor(args) $body]
set ::_PsDebug::redefines($parent..$name) $todo
uplevel \#0 $todo
}
}
proc ::_PsDebug::ProcEditorCopy {} {
clipboard clear
foreach item [array names ::_PsDebug::redefines] {
clipboard append $::_PsDebug::redefines($item)\n
}
}
# Tracing of commands
proc ::_PsDebug::ProcEditorTrace {level} {
variable allcmds
set item $::_PsDebug::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 ::_PsDebug::ProcEditorDisas {} {
variable allcmds
set item $::_PsDebug::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
tk::toplevel $top -padx 3 -pady 3
place [ttk::frame $top.tilebg] -border outside \
-x 0 -y 0 -relwidth 1 -relheight 1
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 ::_PsDebug::ProcEditorFilter {aVal kVal} {
set f $::_PsDebug::ProcEditor(filter)
set fx $::_PsDebug::ProcEditor(filterx)
# Do not react unless changed.
if {$f eq $fx} {
return
}
set tree $::_PsDebug::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 ::_PsDebug::ProcEditor(filterx) $f
}
# Make sure the hierarchy for a leaf exist, creating if needed.
proc ::_PsDebug::TreeCreatePath {tree path} {
if {[$tree exists $path]} return
set d $::_PsDebug::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 ::_PsDebug::TreePopulate {tree {filter *}} {
$tree delete [$tree children {}]
foreach cmd [lsort -dictionary [array names ::_PsDebug::allcmds]] {
set d $::_PsDebug::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 ::_PsDebug::ProcEditor {} {
::_PsDebug::CollectInfo
set top .proceditor
destroy $top
tk::toplevel $top -padx 3 -pady 3
place [ttk::frame $top.tilebg] -border outside \
-x 0 -y 0 -relwidth 1 -relheight 1
wm title $top "Proc Editor"
ttk::frame $top.ftree
set ::_PsDebug::ProcEditor(filter) ""
set ::_PsDebug::ProcEditor(filterx) ""
ttk::entry $top.ftree.ef -textvariable ::_PsDebug::ProcEditor(filter)
addBalloon $top.ftree.ef "Filter"
bind $top.ftree.ef <KeyRelease> {::_PsDebug::ProcEditorFilter %A %K}
set tree $top.ftree.tree
set ::_PsDebug::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>> ::_PsDebug::ProcEditorSelected
ttk::label $top.l1a -text "Parent" -anchor w
ttk::label $top.l1b -textvariable ::_PsDebug::ProcEditor(parent) -anchor w
ttk::label $top.l2a -text "Proc/Method" -anchor w
ttk::label $top.l2b -textvariable ::_PsDebug::ProcEditor(proc) -anchor w
ttk::label $top.l3a -text "Args" -anchor w
ttk::label $top.l3b -textvariable ::_PsDebug::ProcEditor(args) -anchor w
ttk::button $top.bc -text "Copy" -command ::_PsDebug::ProcEditorCopy
addBalloon $top.bc "Put all redefines on clipboard"
set ::_PsDebug::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 ::_PsDebug::ProcEditorRedefine
addBalloon $top.b1 "Redefine for this session"
ttk::button $top.b2 -text "Disas" -command ::_PsDebug::ProcEditorDisas
addBalloon $top.b2 "Show byte code"
ttk::button $top.b3 -text "Trace" -command "::_PsDebug::ProcEditorTrace 1"
addBalloon $top.b3 "Enable execution trace"
ttk::button $top.b4 -text "Tr Step" -command "::_PsDebug::ProcEditorTrace 2"
addBalloon $top.b4 "Enable detailed execution trace"
ttk::button $top.b5 -text "Tr Off" -command "::_PsDebug::ProcEditorTrace 0"
addBalloon $top.b5 "Disable execution trace"
set ::_PsDebug::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 ::_PsDebug::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 ::_PsDebug::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 ::_PsDebug::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 "::_PsDebug::"} 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 ::_PsDebug::DumpStuff {} {
try {
::_PsDebug::CollectInfo
} on error {res i} {
puts $res
puts $i
after 1000
}
# Proc
parray ::_PsDebug::allcmds *updateColors*
parray ::_PsDebug::allcmds *cleanupAndExit
# Cmd
parray ::_PsDebug::allcmds *ttk::paned
parray ::_PsDebug::allcmds *llength
# OO class
parray ::_PsDebug::allcmds *Account*
# Snit class
parray ::_PsDebug::allcmds *eskilprint*
#
parray ::_PsDebug::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"}
}
}