Eskil

# debug.tcl
#
#    Helpers for debugging.
#
#

namespace eval ::_Debug {

}

#-----------------------------------------------------------------------------
# Misc useful stuff
#-----------------------------------------------------------------------------

proc ::_Debug::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 ::_Debug::TRenter {cmd op} {

                -onvalue show -offvalue hide -command {console $::consoleState} \
                -underline 0
        $mW.debug add separator
    }

    $mW.debug add command -label "Edit" -command ::_Debug::ProcEditor \
            -underline 0
    $mW.debug add command -label "Windows" -command ::_Debug::WindowBrowser \
            -underline 0
    #after 500 ::_Debug::DumpStuff
    #after 500 ::_Debug::ProcEditor
    return $mW.debug
}

#-----------------------------------------------------------------------------
# Window structure browser
#-----------------------------------------------------------------------------
proc ::_Debug::WindowBrowser {} {
    set top .windowbrowser
    destroy $top
    ttk::toplevel $top -padx 3 -pady 3
    wm title $top "Window Browser"

    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}

    text $top.t -width 80 -wrap word

    set ::_Debug::WindowBrowser(treeW) $tree
    set ::_Debug::WindowBrowser(textW) $top.t
    bind $tree <<TreeviewSelect>> ::_Debug::WindowBrowserSelected

    grid $top.ftree $top.t -sticky news
    grid rowconfigure    $top 0 -weight 1
    grid columnconfigure $top 0 -weight 1
    grid columnconfigure $top 1 -weight 2

    set ::_Debug::WindowBrowser(deselect) ""
    PopWindowBrowser $tree
}

# An item was selected. Show info
proc ::_Debug::WindowBrowserSelected {} {
    $::_Debug::WindowBrowser(textW) delete 1.0 end
    if {$::_Debug::WindowBrowser(deselect) ne ""} {
        #puts "DESEL: $::_Debug::WindowBrowser(deselect)"
        {*}$::_Debug::WindowBrowser(deselect)
        set ::_Debug::WindowBrowser(deselect) ""
    }
    set tree $::_Debug::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]
    $::_Debug::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 ::_Debug::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 ::_Debug::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 ::_Debug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -background $bg]]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    #puts "MOO $w"
}

# Populate
proc ::_Debug::PopWindowBrowser {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]
            set out "$w  ($class)\n"
            set delayed ""
            foreach param [{*}$i $w configure] {
                lassign $param flag _ _ def value
                if {$value ne $def} {
                    append out "[list $flag $value] "
                } else {
                    append delayed "[list $flag $value] "
                }
                if {$flag eq "-container" && $value == 1} {
                    lappend containers $w $interp
                }
            }
            if {$delayed ne ""} {
                append out \n $delayed
            }
            try {
                set ix [{*}$i grid info $w]
                if {$ix ne ""} {
                    append out "\n\ngrid\n$ix"
                }
            } on error {} {}
            try {
                set ix [{*}$i pack info $w]
                if {$ix ne ""} {
                    append out "\n\npack\n$ix"
                }
            } on error {} {}

            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 ::_Debug::ProcEditorSelected {} {

    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

    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"

    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]
    }

    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"