jimdb

#!/usr/bin/env jimsh
# vim:se syntax=tcl:
#
# A simple command line debugger for Jim Tcl.

set opt_trace 0

set argv [lassign $argv argv0]
if {[string match -t* $argv0]} {
    set opt_trace 1
    set argv [lassign $argv argv0]
}

if {$argv0 eq ""} {
    stderr puts "Usage: jimdb ?-trace? script ?args ...?"
    exit 1
}

puts "Jim Tcl debugger v1.0  -  Use ? for help\n"

# --- debugger implementation ---
proc debugger::w {&s} {
    set n 0
    foreach t $s(stacktrace) {
        lassign $t f l p args
        set args [debugger::_squash $args]
        if {$f eq ""} {
            set loc ""
        } else {
            set loc " @ $f:$l"
        }
        puts [format "%s #%s %s" $($n == $s(level) ? ">" : " ") $n "$p $args $loc"]
        incr n
    }
}

proc debugger::? {&s {cmd ""}} {
    set help {
        s {s "step into" "Step to the next command"}
        w {w "where (stacktrace)" "Displays the current stack trace. The current frame is identified with >"}
        n {n "step over" "Step to the next command without entering procs"}
        l {"l [loc]" "list source" "Lists source code. loc may be filename, filename:line, line, procname"}
        r {r "step out" "Continue until the current proc exits"}
        v {v "local vars" "Display all local variables in the current frame"}
        c {c "continue" "Continue until a breakpoint or ^C"}
        u {u "up stack frame" "Move up stack frame (towards #0)"}
        p {"p [expr]" "print" "Prints an expression (or variable). e.g. p x, p \$x / 3"}
        d {d "down stack frame" "Move down stack frame (away from #0)"}
        b {"b [loc]" "breakpoints" "List breakpoints (no args), or set a breakpoint at filename:line, line or procname"}
        t {"t [0|1|2]" "trace" "Toggle command tracing on/off, or sets given trace mode"}
        ? {"? [cmd]" "help" "Display general help or for the given command"}
        q {q "quit" "Quit the script"}
    }
    if {$cmd eq ""} {
        foreach {cmd1 info1 cmd2 info2} $help {
            lassign $info1 u1 desc1
            lassign $info2 u2 desc2
            puts [format "     %-9s %-20s     %-9s %-20s" $u1 $desc1 $u2 $desc2]
        }
    } elseif {[exists help($cmd)]} {
        lassign $help($cmd) u desc detail
        puts "$u    $detail"
    } else {
        puts "No such command: $cmd"
    }
}

proc debugger::c {&s} {
    return -code break
}

proc debugger::p {&s expr} {
    if {[catch {uplevel #$s(level) [list expr $expr]} msg]} {
        if {[uplevel #$s(level) exists $expr]} {
            puts "p \$$expr"
            catch {uplevel #$s(level) [list set $expr]} msg
        }
    }
    return $msg
}

proc debugger::q {&s} {
    exit 0
}

proc debugger::b {&s {loc ""}} {
    if {$loc eq ""} {
        foreach bp [lsort [dict keys $s(bplines)]] {
            puts "Breakpoint at [dict get $s bplines $bp] ($bp)"
        }
        foreach bp [lsort [dict keys $s(bpprocs)]] {
            puts "Breakpoint at $bp"
        }
        return
    }
    lassign [debugger::_findloc s $loc 0] file line
    if {$file ne ""} {
        dict set s(bplines) $file:$line $loc
        puts "Breakpoint at $file:$line"
    } else {
        set procs [lsort [info procs $loc]]
        if {[llength $procs] > 5} {
            puts "Too many matches: $procs"
        } elseif {[llength $procs] == 0} {
            dict set s(bpprocs) $loc 1
            puts "Breakpoint at $loc (future)"
        } else {
            foreach p $procs {
                lassign [debugger::_findloc s $p] file line
                dict set s(bpprocs) $p $file:$line
                puts "Breakpoint at $p ($file:$line)"
            }
        }
    }
    return
}

proc debugger::n {&s} {
    set s(bplevel) $s(blevel)
    return -code break
}

proc debugger::r {&s} {
    incr s(bplevel) -1
    return -code break
}

proc debugger::s {&s} {
    set s(bpany) 1
    return -code break
}

proc debugger::v {&s {pat *}} {
    set level #$s(level)
    if {$s(level) == 0} {
        set vars [info globals $pat]
    } else {
        set vars [uplevel $level info locals $pat]
    }
    foreach i [lsort $vars] {
        puts "$i = [debugger::_squash [uplevel $level set $i]]"
    }
}

proc debugger::u {&s} {
    if {$s(level) > 0} {
        incr s(level) -1
    }
    tailcall debugger::w s
}

proc debugger::d {&s} {
    if {$s(level) < [info level] - 2} {
        incr s(level)
    }
    tailcall debugger::w s
}

proc debugger::t {&s {mode {}}} {
    if {$mode eq ""} {
        set mode $(!$s(trace))
    }
    switch -exact -- $mode {
        0 {
            set msg off
        }
        1 {
            set msg on
        }
        2 {
            set msg full
        }
        default {
            error "Unknown trace mode: $mode"
        }
    }
    set s(trace) $mode
    puts "Tracing is now $msg"
}

proc debugger::l {&s {loc {}}} {
    if {$loc eq ""} {
        lassign $s(active) file line
        if {$file eq ""} {
            return "No source location available"
        }
    } else {
        lassign [debugger::_findloc s $loc] file line
    }
    if {$file eq ""} {
        return "Don't know anything about: $loc"
    }
    puts "@ $file"
    debugger::_showlines s $file $line 8
    set s(lastcmd) "l $file:$($line + 8)"
    return
}

# ----- internal commands below this point -----

# This proc can be overridden to read commands from
# some other location, such as remote socket
proc debugger::_getcmd {&s &cmd} {
    if {![exists s(historyfile)]} {
        set s(historyfile) [env HOME]/.jimdb_history
        history load $s(historyfile)
    }
    while 1 {
        if {[history getline "dbg> " cmd] < 0} {
            signal default SIGINT
            puts "Use q to quit, ? for help"
            set cmd ""
            return 0
        }
        if {$cmd eq "h"} {
            history show
            continue
        }
        # Don't bother adding single char commands to the history
        if {[string length $cmd] > 1} {
            history add $cmd
            history save $s(historyfile)
        }
        return 1
    }
}

proc debugger::?? {&s} {
    parray s
    return ""
}

proc debugger::_squash {arglist} {
    set arglist [regsub -all "\[\n\t\r \]+" $arglist { }]
    if {[string length $arglist] > 60} {
        set arglist [string range $arglist 0 57]...
    }
    return $arglist
}

# Converts something which looks like a location into a file/line
# number -> file=active, line=number
# filename -> file=filename, line=1
# filename:number -> file=filename, line=number
# procname -> file, line = of first line of body
proc debugger::_findloc {&s loc {checkproc 1}} {
    lassign $s(active) afile aline
    if {[string is integer -strict $loc]} {
        set result [list $afile $loc]
    } else {
        if {[string match *:* $loc]} {
            regexp (.*):(.*) $loc -> file line
        } else {
            set file $loc
            set line 1
        }
        if {[file exists $file]} {
            set result [list $file $line]
        } elseif {$checkproc && [exists -proc $loc]} {
            set result [info source [info body $loc]]
        } else {
            set result ""
        }
    }
    return $result
}

proc debugger::_showlines {&s file line context} {
    lassign $s(active) afile aline
    if {[catch {
        set file [debugger::_findfile $file]
        set f [open $file]
        set file [file tail $file]
        set afile [file tail $afile]
        set n 0
        set lines [split [$f read] \n]
        if {$line >= [llength $lines]} {
            set line [llength $lines]
        }
        foreach l $lines {
            incr n
            if {$n > $line + $context} {
                break
            }
            if {$n >= $line - $context} {
                if {$n == $aline && $file eq $afile} {
                    set marker ">"
                } elseif {$n == $line} {
                    set marker "*"
                } else {
                    set marker " "
                }
                puts [format "%s%4d %s" $marker $n $l]
            }
        }
        $f close
    } msg]} {
        puts $msg
    }
}

proc debugger::_showloc {&s file line name arglist} {
    set tail [file tail $file]
    if {$file eq ""} {
        puts "@ $name [debugger::_squash $arglist]"
    } else {
        puts "@ $tail:$line $name [debugger::_squash $arglist]"
        debugger::_showlines s $file $line 1
    }
}

proc debugger::_checkbp {&s file line name} {
    if {[signal check -clear SIGINT] ne ""} {
        return 1
    }
    if {$s(bpany) == 0} {
        return 1
    }
    # We don't want to stop on the same line with a different command
    # when stepping with 'n'. This isn't perfect since the same
    # command might be part of a nested expression, but we have no additional
    # information available.
    if {$s(laststop) eq "$file:$line" && $s(prevname) ne $name} {
        return 0
    }
    if {$s(blevel) <= $s(bplevel)} {
        return 1
    }
    if {[dict exists $s(bplines) $file:$line]} {
        puts "Breakpoint @ $file:$line"
        return 1
    }
    return 0
}

proc debugger::_findfile {filename} {
    # Search for the given file in likely places
    foreach dir [list {*}$::auto_path . [file dirname $::argv0] [file dirname [info nameofexecutable]]] {
        if {[file exists $dir/$filename]} {
            return $dir/$filename
        }
    }
    return $filename
}

# The execution trace (xtrace) callback
proc debugger::_db {type file line result name arglist} {
    upvar #0 debugger::state s

    #puts "@ $file:$line ($result) $type $name [debugger::_squash $arglist]"

    # proc is only used to activate breakpoints
    if {$type eq "proc"} {
        # If we aren't already going to stop at the next command
        # do so if we have a proc breakpoint
        if {$s(bpany) != 1} {
            set s(bpany) [dict exists $s bpprocs $name]
        }
        return
    }

    # level is the proc frame level
    set s(level) $([info level] - 1)
    # blevel is the breakpoint level for n, r commands
    set s(blevel) [info level]
    set s(active) [list $file $line $name $arglist]

    incr s(bpany) -1

    if {[catch -nobreak -noreturn {
        if {[debugger::_checkbp s $file $line $name]} {
            # Breakpoint here
            set s(bpany) 0
            set s(bplevel) -1
            set s(laststop) $file:$line
            set s(prevname) $name

            # Build the active stacktrace, omitting internal frames
            set s(stacktrace) {}
            foreach {p f l cmd} [stacktrace 1] {
                if {[lindex $cmd 0] eq "debugger::_db"} {
                    continue
                }
                lassign $cmd p pargs
                lappend s(stacktrace) [list $f $l $p $pargs]
            }
            lappend s(stacktrace) $s(active)

            if {$result ne ""} {
                puts "=> [debugger::_squash $result]"
            }
            debugger::_showloc s $file $line $name $arglist

            set buf {}
            while {1} {
                set rc [debugger::_getcmd s buf]
                if {$rc == -1} {
                    # Stop tracing
                    return
                }
                if {$buf eq ""} {
                    set buf $s(lastcmd)
                } else {
                    set s(lastcmd) $buf
                }

                # Mark the active stack frame
                set s(active) [lindex $s(stacktrace) $s(level)]

                set args [lassign $buf cmd]
                catch -nobreak {
                    if {[exists -proc debugger::$cmd]} {
                        debugger::$cmd s {*}$args
                    } else {
                        uplevel #$s(level) $buf
                    }
                } result
                if {$result ne ""} {
                    puts $result
                }
            }
        } elseif {$s(trace) && $file ne ""} {
            if {$s(trace) == 2 && $result ne ""} {
                puts "=> [debugger::_squash $result]"
            }
            if {$file ne $s(lastsource)} {
                puts "@ $file"
            }
            set s(lastsource) $file
            debugger::_showlines s $file $line 0
        }
    } err opts]} {
        puts [errorInfo $err]
        exit 1
    }
}

# Allows a breakpoint to be manually inserted
# The message is for documentation purposes
proc breakpoint {{msg ""}} {
    set ::debugger::state(bpany) 1
}

signal ignore SIGINT

set debugger::state {
    bplevel -1
    bpany -1
    bplines {}
    bpprocs {}
    lastcmd ""
    laststop ""
    level 0
    trace 0
    active {}
    prevname {}
    stacktrace {}
    lastsource {}
}

set debugger::state(trace) $opt_trace
# Break at the very next command after source
set debugger::state(bpany) 2

# Install the debugger
xtrace debugger::_db

source $argv0