Eskil

# debug.tcl
#
#    Helpers for debugging.
#
#
proc testme {x y z} {
    puts "In Testme $x $y $z"
    list [lindex $x 0] [lindex $y 0]

namespace eval ::_Debug {
    
}

proc debugTRenter {cmd op} {
proc ::_Debug::TRenter {cmd op} {
    set fr [info frame -2]
    puts "Line [dict get $fr line] Enter: '$cmd'"
}
proc debugTRenterstep {cmd op} {
proc ::_Debug::TRenterstep {cmd op} {
    set fr [info frame -2]
    #puts "$fr"
    puts "Line [dict get $fr line] Enterstep: '$cmd'"
}
proc debugTRleave {cmd core res op} {
proc ::_Debug::TRleave {cmd core res op} {
    puts "Leave: '$res'"
}
proc debugTRleavestep {cmd code res op} {
proc ::_Debug::TRleavestep {cmd code res op} {
    puts "Leavestep: '$res'"
}

proc debugTR {cmd} {
    trace add execution $cmd enter debugTRenter
    trace add execution $cmd leave debugTRleave
    trace add execution $cmd enterstep debugTRenterstep
    trace add execution $cmd leavestep debugTRleavestep
proc ::_Debug::TR {cmd} {
    trace add execution $cmd enter ::_Debug::TRenter
    trace add execution $cmd leave ::_Debug::TRleave
    trace add execution $cmd enterstep ::_Debug::TRenterstep
    trace add execution $cmd leavestep ::_Debug::TRleavestep
}

# Get procs in global namespace
proc ::_Debug::Procs {pat} {
    return [uplevel \#0 [list info procs $pat]]
}

proc DebugMenu {m} {
proc debugMenu {m} {
    $m add cascade -label "Debug" -menu $m.debug -underline 0
    menu $m.debug

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

    $m.debug add command -label "Edit" -command ProcEditor -underline 0
    $m.debug add command -label "Edit" -command ::_Debug::ProcEditor \
            -underline 0
    #::_Debug::DumpStuff
    return $m.debug
}

proc ProcEditorUpdate {a k} {
proc ::_Debug::ProcEditorUpdate {a k} {
    # Only update on keys generating characters
    if {$a eq "" || ![string is graph $a]} return
    #puts "Key '$a' '$k'"
    set p [info procs $::ProcEditor(proc)]
    if {$p eq "" && $::ProcEditor(proc) ne ""} {
    set p [Procs $::_Debug::ProcEditor(proc)]
    if {$p eq "" && $::_Debug::ProcEditor(proc) ne ""} {
        # Try prefix matching
        set p [info procs $::ProcEditor(proc)*]

        set p [Procs $::_Debug::ProcEditor(proc)*]
        
        # Include namespaces if starting with ::
        if {[string match "::*" $::ProcEditor(proc)]} {
            if {[regexp {^(.*::)([^:]*)$} $::ProcEditor(proc) -> ns pat]} {
        if {[string match "::*" $::_Debug::ProcEditor(proc)]} {
            if {[regexp {^(.*::)([^:]*)$} $::_Debug::ProcEditor(proc) -> ns pat]} {
                if {[namespace exists $ns]} {
                    set child [namespace children $ns $pat*]
                    lappend p {*}$child
                }
            }
        }
    }
    set p [lsort -dictionary $p]
    $::ProcEditor(procW) configure -values $p
    $::_Debug::ProcEditor(procW) configure -values $p
    # Keep the first
    set p [lindex $p 0]

    if {$p eq ""} {
        set ::ProcEditor(args) ""
        $::ProcEditor(bodyW) delete 1.0 end
        set ::_Debug::ProcEditor(args) ""
        $::_Debug::ProcEditor(bodyW) delete 1.0 end
        return
    }
    if {$p ne $::ProcEditor(proc)} {
        after idle [list set "::ProcEditor(proc)" $p]
        after idle [list $::ProcEditor(procW) selection range insert end]
    if {$p ne $::_Debug::ProcEditor(proc)} {
        after idle [list set "::_Debug::ProcEditor(proc)" $p]
        after idle [list $::_Debug::ProcEditor(procW) selection range insert end]
    }

    after idle ProcEditorSelected
    after idle ::_Debug::ProcEditorSelected
}

proc ProcEditorSelected {} {
    set p [info procs $::ProcEditor(proc)]
proc ::_Debug::ProcEditorSelected {} {
    set p [Procs $::_Debug::ProcEditor(proc)]
    if {$p eq ""} {
        set ::ProcEditor(args) ""
        $::ProcEditor(bodyW) delete 1.0 end
        set ::_Debug::ProcEditor(args) ""
        $::_Debug::ProcEditor(bodyW) delete 1.0 end
        return
    }
    set arglist {}
    foreach i [info args $p] {
        if {[info default $p $i value]} {
            lappend arglist [list $i $value]
        } else {
            lappend arglist [list $i]
        }
    }
    set body [info body $p]

    set ::ProcEditor(args) $arglist
    $::ProcEditor(bodyW) delete 1.0 end
    $::ProcEditor(bodyW) insert end $body
    set ::_Debug::ProcEditor(args) $arglist
    $::_Debug::ProcEditor(bodyW) delete 1.0 end
    $::_Debug::ProcEditor(bodyW) insert end $body
}

proc ProcEditorRedefine {} {
    set body [$::ProcEditor(bodyW) get 1.0 end]
proc ::_Debug::ProcEditorRedefine {} {
    set body [$::_Debug::ProcEditor(bodyW) get 1.0 end]
    set body [string trimright $body]

    ##nagelfar ignore Non constant argument to proc
    proc $::ProcEditor(proc) $::ProcEditor(args) $body
    uplevel \#0 [list proc $::_Debug::ProcEditor(proc) \
                         $::_Debug::ProcEditor(args) $body]
}

proc ProcEditorDisas {} {
    set da [tcl::unsupported::disassemble proc $::ProcEditor(proc)]
proc ::_Debug::ProcEditorDisas {} {
    set da [tcl::unsupported::disassemble proc $::_Debug::ProcEditor(proc)]

    set top .proceditor.disas
    destroy $top
    toplevel $top
    ttk::toplevel $top
    ttk::frame $top.bgf
    place $top.bgf -x 0 -y 0 -relwidth 1.0 -relheight 1.0 -anchor nw
    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
}

#-----------------------------------------------------------------------------
# Tree view and filter
#-----------------------------------------------------------------------------
proc ::_Debug::ProcEditorFilter {a k} {
    # Only update on keys generating characters
    if {$a eq "" || ![string is graph $a]} return
    set f $::_Debug::ProcEditor(filter)
    set tree $::_Debug::ProcEditor(treeW)
    #foreach item [$tree] 
}

proc ::_Debug::TreeCreatePath {tree path} {
    if {[$tree exists $path]} return
    set parent [namespace qualifiers $path]
    TreeCreatePath $tree $parent
    
    set tail [namespace tail $path]

    $tree insert $parent end -id $path -text $tail -open 0
}

proc ::_Debug::TreePopulate {tree} {
    foreach cmd [lsort -dictionary [array names ::_Debug::allcmds]] {
        if {$::_Debug::allcmds($cmd) ne "proc"} continue
        set cmd2 [string trim $cmd ":"]
        set path [namespace qualifiers $cmd2]
        set tail [namespace tail $cmd2]
        if {$path ne ""} {
            TreeCreatePath $tree $path
        }
        $tree insert $path end -text $tail -values [list $cmd]
    }
}

#-----------------------------------------------------------------------------
# Main Proc Editor window
#-----------------------------------------------------------------------------
proc ProcEditor {} {
proc ::_Debug::ProcEditor {} {
    ::_Debug::CollectInfo

    set top .proceditor
    destroy $top
    toplevel $top -padx 3 -pady 3
    ttk::frame $top.bgf
    place $top.bgf -x 0 -y 0 -relwidth 1.0 -relheight 1.0 -anchor nw
    wm title $top "Proc Editor"
    ttk::toplevel $top -padx 3 -pady 3
    wm title $top "Proc Editor"

    ttk::frame $top.ftree
    set ::_Debug::ProcEditor(filter) ""
    ttk::entry $top.ftree.ef -textvariable ::_Debug::ProcEditor(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 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

    ttk::label $top.l1 -text "Proc" -anchor w
    ttk::combobox $top.e1 -textvariable ::ProcEditor(proc) -values ""
    set ::ProcEditor(procW) $top.e1
    bind $top.e1 <KeyRelease> {ProcEditorUpdate %A %K}
    bind $top.e1 <<ComboboxSelected>> ProcEditorSelected
    #trace add variable ::ProcEditor(proc) write "ProcEditorUpdate"
    ttk::combobox $top.e1 -textvariable ::_Debug::ProcEditor(proc) -values ""
    set ::_Debug::ProcEditor(procW) $top.e1
    bind $top.e1 <KeyRelease> {::_Debug::ProcEditorUpdate %A %K}
    bind $top.e1 <<ComboboxSelected>> ::_Debug::ProcEditorSelected
    #trace add variable ::_Debug::ProcEditor(proc) write "::_Debug::ProcEditorUpdate"
    ttk::label $top.l2 -text "Args" -anchor w
    ttk::entry $top.e2 -textvariable ::ProcEditor(args)
    set ::ProcEditor(bodyW) [text $top.t -yscrollcommand "$top.sby set"]
    ttk::entry $top.e2 -textvariable ::_Debug::ProcEditor(args)
    set ::_Debug::ProcEditor(bodyW) [text $top.t -yscrollcommand "$top.sby set"]
    ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"

    ttk::frame  $top.fb
    ttk::button $top.b1 -text "Redefine" -command ProcEditorRedefine
    ttk::button $top.b2 -text "Disas"    -command ProcEditorDisas
    ttk::button $top.b1 -text "Redefine" -command ::_Debug::ProcEditorRedefine
    ttk::button $top.b2 -text "Disas"    -command ::_Debug::ProcEditorDisas
    grid $top.b1 $top.b2 -in $top.fb
    grid columnconfigure $top.fb all -weight 1 -uniform a

    grid $top.l1 $top.e1 -        -padx 3 -pady 3 -sticky we
    grid $top.l2 $top.e2 -        -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 $top.ftree $top.l1 $top.e1 -        -padx 3 -pady 3 -sticky we
    grid ^          $top.l2 $top.e2 -        -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 1 -weight 1
    grid columnconfigure $top 2 -weight 1
    grid rowconfigure    $top 2 -weight 1
}

# 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 ns [lindex $todoNs 0]
        set todoNs [lrange $todoNs 1 end]
        set preNs [string trimright $ns ":"]

        if {$ns eq "::_Debug"} continue
        

        foreach child [namespace children $ns] {
            lappend todoNs $child
        }
        array unset thisround
        array set thisround {}
        # First collect commands, since we want to override with detail later
        foreach cmd [info commands ${preNs}::*] {
            set allcmds($cmd) "cmd"
            set thisround($cmd) 1
        }
        # Which ones are procs?
        foreach cmd [info procs ${preNs}::*] {
            set allcmds($cmd) "proc"
            set thisround($cmd) 0
        }
        # Which ones are imports?
        if {![catch {namespace eval $ns {namespace import}} imports]} {
            foreach cmd $imports  {
                set allcmds(${preNs}::$cmd) "import"
                set thisround(${preNs}::$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]} {
                set allcmds($cmd) ensemble
                foreach {key val} [namespace ensemble configure $cmd] {
                    #lappend allcmds($cmd) $key $val
                    if {$key eq "-map"} {
                        #puts "$cmd $val"
                        lappend allcmds($cmd) {*}$val
                    }
                    # Recognise a snit class
                    if {$key eq "-unknown" && [string match ::snit::* $val]} {
                        lset allcmds($cmd) 0 snit
                    }
                }
            }
            # Is it oo::class?
            if {![catch {info class methods $cmd -private} methods]} {
                set allcmds($cmd) "oo::class $methods"
            }
        }
        # info class
        # info object

        # How to recognise methods?
        #allcmds(::eskilprint)                          = cmd
        #allcmds(::eskilprint::install)                 = cmd
        #allcmds(::eskilprint::Snit_methodnewPage) = proc
        #allcmds(::DirCompareTree::Snit_methodaddCmdCol) = proc
        #allcmds(::pdf4tcl::pdf4tcl)                = cmd
        #allcmds(::Account) = cmd

        # Namespace ensembles?
    }
}

# Debug of debug
proc ::_Debug::DumpStuff {} {
    ::_Debug::CollectInfo
    parray ::_Debug::allcmds *Account*
    parray ::_Debug::allcmds *eskilprint*
}

#-----------------------------------------------------------------------------
# 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 {} {
    }
    destructor {
        my variable total
        if {$total} {puts "remaining $total will be given to charity"}
    }
}