Eskil

#  namespace import ::_PsDebug::*
#----------------------------------------------------------------------

package provide psdebug 1.0

namespace eval ::_PsDebug {
    variable allcmds
    variable backdoor
    namespace export debugMenu
    namespace export debugMenu backDoor
}

#-----------------------------------------------------------------------------
# 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::Limit {str} {
    if {[string length $str] > 50} {
        set str [string range $str 0 50]...
    }
    return $str
}

proc ::_PsDebug::TRenter {cmd op} {
    set fr [info frame -2]
    set line X
    set lineNo X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
        set lineNo [dict get $fr line]
    }
    puts "Line $line Enter: '$cmd'"
    puts "Line $lineNo Enter: '[Limit $cmd]'"
}
proc ::_PsDebug::TRenterstep {cmd op} {
    set fr [info frame -2]
    set line X
    set lineNo X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
        set lineNo [dict get $fr line]
    }
    puts "Line $line  Enterstep: '$cmd'"
    puts "Line $lineNo  Enterstep: '[Limit $cmd]'"
}
proc ::_PsDebug::TRleave {cmd code res op} {
    puts "Leave: '$res'"
    puts "Leave: '[Limit $res]'"
}
proc ::_PsDebug::TRleavestep {cmd code res op} {
    puts "Leavestep: '$res'"
    puts "Leavestep: '[Limit $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

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
        menu $dW -tearoff 0
    }

    if {$::tcl_platform(platform) eq "windows"} {
        $dW add checkbutton -label "Console" -variable ::consoleState \
                -onvalue show -offvalue hide -command {console $::consoleState} \
        $dW add checkbutton -label "Console" -variable ::_PsDebug::consoleState \
                -onvalue show -offvalue hide -command {console $::_PsDebug::consoleState} \
                -underline 0
        $dW add separator
    }

    $dW add command -label "Edit" -command ::_PsDebug::ProcEditor \
            -underline 0
    $dW add command -label "Windows" -command ::_PsDebug::WindowBrowser \

    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

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

        #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]
        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
        {*}$i $W configure -style $style
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -style $oldstyle]]
                [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 bg [{*}$i $W cget -background]
        {*}$i $W configure -background red
        set ::_PsDebug::WindowBrowser(deselect) \
                [list {*}$i [list $w configure -background $bg]]
                [list {*}$i [list $W configure -background $bg]]
        return
    } on error {err info} {
        #puts "In $interp"
        #puts "$err"
        #puts "$info"
    }
    #puts "MOO $w"
    #puts "MOO $W"
}

# Format configure data from a widget for display
proc ::_PsDebug::FormatConfigure {configData} {
    set first ""
    set last ""
    foreach param $configData {

    $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 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
            set long $interp$W
            if {$W in {.windowbrowser}} continue

            foreach child [lsort -dictionary [{*}$i winfo children $w]] {
            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]
                set parent [{*}$i winfo parent $W]
                if {$parent eq ""} {
                    set parentId ""
                } else {
                    set parentId $id($interp$parent)
                }
            }

            set class [{*}$i winfo class $w]
            set class [{*}$i winfo class $W]
            # Info to be displayed
            set out "$w  ($class)\n"
            set configData [{*}$i $w configure]
            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
                    lappend containers $W $interp
                }
            }
            # Add grid info, if any
            try {
                set ix [{*}$i grid info $w]
                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]
                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]
                set last [{*}$i $W index end]
                for {set ix 0} {$ix <= $last} {incr ix} {
                    set configData [{*}$i $w entryconfigure $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 name $W
            regexp {\.[^.]+$} $W name

            set open 1
            if {[string match "*#*" $w]} {
            if {[string match "*#*" $W]} {
                set open 0
            }

            set d {}
            dict set d w $w
            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] {
            set wid [winfo id $W]
            foreach sub [interp children $interp] {
                try {
                    set subId [interp eval $sub . cget -use]
                    if {$subId == $wid} {
                        #puts "Found interp $sub for $w"
                        set parents($sub.) $interp$w
                        #puts "Found interp $sub for $W"
                        set parents($sub.) $interp$W
                        lappend todo . $sub
                    }
                } on error {} {}

            }
        }
        #break

        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
    foreach W $::_PsDebug::ProcEditor(traceWs) {
        $W configure -state $traceState
    }

}

# Redefine currently edited proc/method
proc ::_PsDebug::ProcEditorRedefine {} {
    variable allcmds

proc ::_PsDebug::ProcEditorCopy {} {
    clipboard clear
    foreach item [array names ::_PsDebug::redefines] {
        clipboard append $::_PsDebug::redefines($item)\n
    }
}

# Helper to start trace from code
proc ::_PsDebug::traceProc {item level} {
    variable allcmds
    # Fill in enough info to let ProcEditorTrace work.
    set ::_Debug::ProcEditor(current) $item
    set allcmds($item) [list type proc parent :: name doTemplate]
    ::_PsDebug::ProcEditorTrace $level
}

# Tracing of commands
proc ::_PsDebug::ProcEditorTrace {level} {
    variable allcmds
    set item $::_PsDebug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]

        }
        $tree insert $path end -id $cmd \
                -text [dict get $d name] -values [list $path]
    }
}

# Main Proc Editor window
proc ::_PsDebug::ProcEditor {} {
proc ::_PsDebug::ProcEditor {{suffix {}}} {
    ::_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
    if {$suffix ne ""} {
        wm title $top "Proc Editor - $suffix"
    } else {
    wm title $top "Proc Editor"
        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}

    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
}

#-----------------------------------------------------------------------------
# Debug backdoor support
# Example use:
#    backDoor . -keyword "MyDebug" -escape 1 \
#            -callback [list addDebug .]
#    Get standard debug menu with -menu 1 
#    If psmenu package is available the generated debug menu can be prepended
#    with items like this:
#        -menu {
#            "Die"           -cmd exit
#            ---
#        }
#    Callback is called after creating the menu.
#    If -escape is true, Key-Esc will be bound to setting focus on toplevel.
#    If -now is true, the effect is triggered immediately
#-----------------------------------------------------------------------------

proc ::_PsDebug::backDoor {W args} {
    variable backdoor

    set opts(-keyword) "PsDebug"
    set opts(-callback) ""
    set opts(-menu) ""
    set opts(-postmenu) ""
    set opts(-escape) 0
    set opts(-now) 0
    array set opts $args

    set top [winfo toplevel $W]
    set backdoor($top) ""
    set backdoor($top,kw) $opts(-keyword)
    set backdoor($top,cb) $opts(-callback)
    set backdoor($top,menu) $opts(-menu)
    set backdoor($top,postmenu) $opts(-postmenu)
    set backdoor($top,ix) end-[expr {[string length $opts(-keyword)] - 1}]
    
    set val [bindtags $top]
    set tag psBackDoor$top
    lappend val $tag
    bindtags $top $val
    # Keep this binding on a separate tag, so that other key
    # bindings on the top does not steal the keys
    bind $tag <Key> "::_PsDebug::BackDoorKey $top %A"
    # Go out to toplevel with escape, whereever you are
    bind $top <Key-Escape> [list focus $top]

    if {$opts(-now)} {
        set backdoor($top) $backdoor($top,kw)
        BackDoorKey $top ""
    }
}

proc ::_PsDebug::BackDoorKey {top aVal} {
    variable backdoor
    append backdoor($top) $aVal
    set backdoor($top) [string range $backdoor($top) $backdoor($top,ix) end]
    if {$backdoor($top) eq $backdoor($top,kw)} {
        # -postmenu implies -menu
        if {$backdoor($top,postmenu) ne "" && $backdoor($top,menu) eq ""} {
            set backdoor($top,menu) 1
        }
        if {$backdoor($top,menu) == 1} {
            if {$top eq "."} {
                set dW [debugMenu .m]
            } else {
                set dW [debugMenu $top.m]
            }
        } elseif {$backdoor($top,menu) ne ""} {
            psmenu::psmenu $top [string map [list % [list $backdoor($top,menu)]] {
                "&Debug" -var dW %
            }]
            debugMenu $dW -append
        }
        if {$backdoor($top,postmenu) ne ""} {
            # TBD append
            psmenu::psmenu $dW -top $top $backdoor($top,postmenu)
        }
        uplevel \#0 $backdoor($top,cb)
    }
}

#-----------------------------------------------------------------------------
# Procedure/method information collection
#-----------------------------------------------------------------------------
#
# There is nuances to namespace handling that needs awareness.
#