#---------------------------------------------------------*-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"}
    }
}
