diff options
author | Steve Bennett <steveb@workware.net.au> | 2011-07-28 12:52:22 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2021-01-09 11:06:48 +1000 |
commit | 0f09dd9e6b5a2474f04cfa0ea97e6e2b4bc77a45 (patch) | |
tree | 71c8baed08027749b6fc1477088de0a7c2d96907 /jimdb | |
parent | fe37b8dc2536b70d0aba3c6a70ead466ebe5b9d6 (diff) | |
download | jimtcl-0f09dd9e6b5a2474f04cfa0ea97e6e2b4bc77a45.zip jimtcl-0f09dd9e6b5a2474f04cfa0ea97e6e2b4bc77a45.tar.gz jimtcl-0f09dd9e6b5a2474f04cfa0ea97e6e2b4bc77a45.tar.bz2 |
jimdb: A command line Jim debugger using xtrace
Also add some additional tools that use xtrace.
examples/jcov - code coverage
examples/jtime - code coverage that measures execution time
examples/jtrace - trace script execution
Signed-off-by: Steve Bennett <steveb@workware.net.au>
Diffstat (limited to 'jimdb')
-rwxr-xr-x | jimdb | 466 |
1 files changed, 466 insertions, 0 deletions
@@ -0,0 +1,466 @@ +#!/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 + set s(stacktrace) {} + foreach level [range 1 [info level]] { + lassign [info frame $level] p f l + lassign [info level $level] 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 |