# wdbg - A simple debugger for wish based applications.
 #
 #    Author: Todd Coram 
 # 
 # Commands:
 #        bp id - set a break point and output 'id' to identify it. You  are
 #          then allowed to interactively enter Tcl commands in the debugger
 #          window.
 #
 #        try id block - try and execute 'block'. If it raises and error, enter
 #          the debugger window under the break point guise of 'id'.
 #
 #        log_trace var ?ops? ?state? - If 'state' is "on" (default), then trace
 #           the variable named 'var' based on 'ops', where 'ops' can be:
 #           r - read, w - write or u - unset (default "w"). If 'state' is
 #           "off", then turn that particular trace off. Tracing output is sent
 #           to the debugger window.
 #
 #        log - send arbitrary output to the debugger window.
 #
 # Plus, the following debugger commands (in addition to plain-old tcl):
 #        i - show the contents of the current local variables.
 #      l - show lines surrounding the breakpoint (only in procs)
 #      c - continue execution
 
 namespace eval ::wdbg {
    variable got_cmd 0
    namespace export bp log_trace log show_locals try
 }

 proc ::wdbg::bp {id} {
    variable got_cmd

    ::wdbg::_raise_window
    ::wdbg::log "\n*Breakpoint: $id" cmdTag
    .wdbg.e configure -state normal
    while {1} {
        set res [catch {info level -1} level]
        if {$res != 0} {
            set level 0
        }
        ::wdbg::log "$level> " cmdTag -nonewline
        .wdbg.f.t yview moveto 1.0
        .wdbg.e selection range 0 end
        focus .wdbg.e

        tkwait variable ::wdbg::got_cmd

        set line [.wdbg.e get]
        set cmd [lindex $line 0]
        set args [lindex $line 1]
        switch -- $cmd {
            "c" { .wdbg.e configure -state disabled; return }
            "i" { set cmd ::wdbg::show_locals}
            "l" { set cmd "::wdbg::_show_lines {$id} $args"}
            "help" {
                ::wdbg::log "Commands:"
                ::wdbg::log "\tc - continue"
                ::wdbg::log "\ti - info on local variables"
                ::wdbg::log "\tl ?n? - list proc source around the breakpoint"
                ::wdbg::log "\tuse \"set var\" to retrieve a variable's content."
                ::wdbg::log "\talmost any Tcl command is valid here..."
                continue
            }
            default {
                set cmd [.wdbg.e get]
            }
        }
        ::wdbg::log "$cmd" cmdTag
        catch {uplevel 1 $cmd} result
        ::wdbg::log "$result" resultTag
    }
 }

 proc ::wdbg::try {id block} {
    set cres [catch {uplevel 1 $block} result]
    if {$cres != 0} {
        ::wdbg::log "Failed try: $result" errorTag
        uplevel 1 [list ::wdbg::bp $id]
    }
 }

 proc ::wdbg::log_trace {var {ops w} {state on}} {
    set cmd "::wdbg::_log_trace $var"

    if {$state == "off"} {
        uplevel 1 ::trace vdelete $var $ops [list $cmd]
        return
    }
    uplevel 1 ::trace variable $var $ops [list $cmd]
 }

 proc ::wdbg::log {str {tag logTag} {opt ""}} {
    ::wdbg::_raise_window

    .wdbg.f.t insert end "$str" $tag

    if {$opt == "-nonewline"} {
    } else {
        .wdbg.f.t insert end "\n"
    }

    .wdbg.f.t yview moveto 1.0
 }

 proc ::wdbg::show_locals {} {
    set vars [uplevel 1 {info local}]

    if {[llength $vars] == 0} {
        ::wdbg::log "none" resultTag
        return
    }

    ::wdbg::log "proc [uplevel 1 {info level 0}]'s local variables:" resultTag
    foreach var $vars {
        upvar $var value
        set _value {}
        if {![uplevel 1 info exists $var]} {
            set _value "\#unset\#"
        } else {
            set _value $value
        }
        ::wdbg::log "\t$var = $_value" resultTag
    }
 }

 proc ::wdbg::_show_lines {id {lines 6}} {
    if {[catch [uplevel 1 {info body [lindex [info level 0] 0]}] body] != 0} {
        ::wdbg::log "Sorry, I can only show source for procs."
        return
    }
    set blist [split $body "\n"]
    set lidx [lsearch -glob $blist "*bp*$id*"]
    if {$lidx == -1} {
        set lidx [lsearch -glob $blist "*try*$id*"]
        if {$lidx == -1} {
            ::wdbg::log "Can't find breakpoint in source" errorTag
            return
        }
    }
    set range [expr $lines / 2]
    set blist [lreplace $blist $lidx $lidx "--> [lindex $blist $lidx]"]
    set lstr [lrange $blist [expr $lidx - $range] [expr $lidx + $range]]
    set str [join $lstr "\n"]
    ::wdbg::log "$str" \
        resultTag
 }

 proc ::wdbg::_raise_window {} {
    if {![winfo exists .wdbg]} {

        # Create the breakpoint window
        #
        toplevel .wdbg
        entry .wdbg.e -width 80
        bind .wdbg.e <Key-Return> [list set ::wdbg::got_cmd 1]
        .wdbg.e configure -state disabled

        frame .wdbg.f
        text .wdbg.f.t -width 80 -height 20 -yscrollcommand {.wdbg.f.sb set} \
            -wrap word -takefocus 0
        bind .wdbg.f.t <KeyPress> {break}

        # Color scheme for the text window
        #
        .wdbg.f.t tag configure traceTag -foreground orange
        .wdbg.f.t tag configure errorTag -foreground red
        .wdbg.f.t tag configure logTag -foreground darkgreen
        .wdbg.f.t tag configure resultTag -foreground blue
        .wdbg.f.t tag configure cmdTag -foreground [.wdbg.f.t cget -foreground]

        scrollbar .wdbg.f.sb -orient vertical -command {.wdbg.f.t yview}

        pack .wdbg.f.t -anchor nw -expand yes -fill both -side left
        pack .wdbg.f.sb -anchor e -expand no -fill y -side left

        pack .wdbg.e -side top -fill x -expand no -anchor nw
        pack .wdbg.f -fill both -expand yes -anchor nw

        wm title .wdbg "Wdbg - A Simple Wish-based Debugger"

        # "continue" if someone tries to close the debugger window...
        #
        wm protocol .wdbg WM_DELETE_WINDOW { .wdbg.e delete 0 end; \
                                                 .wdbg.e insert end "c"; \
                                                 set ::wdbg::got_cmd 1; \
                                                 wm withdraw .wdbg }
        # first command defaults to "help"...
        #
        .wdbg.e insert end  "help"
    }
    wm deiconify .wdbg
    raise .wdbg
    focus .wdbg.e
 }


 proc ::wdbg::_log_trace {vname name1 name2 op} {
    upvar $vname vn
    ::wdbg::log "trace -> $name1 = ($vn)" traceTag
 }

 #############
 # Test

 if { [info exists argv0] && [string compare [info script] $argv0] == 0} {
    namespace import ::wdbg::*

    log "starting"

    bp "top level"
    proc foo {} {
        set x what
        set y huh?
        set n1 22
        set n2 43
        
        
        try "this works" {show_locals}
        try "this fails" {show_local}
        
        log_trace n1 w
        incr n1
        incr n1
        incr n1
        incr n1
        
        bp "try changing the local variables"
        show_locals
    }

    proc bar {} {
        bp "in bar"
        foo
    }
    
    bar
 }