diff options
| -rw-r--r-- | Makefile.in | 1 | ||||
| -rw-r--r-- | examples/dbgtest.tcl | 34 | ||||
| -rwxr-xr-x | examples/jcov | 66 | ||||
| -rwxr-xr-x | examples/jtime | 53 | ||||
| -rwxr-xr-x | examples/jtrace | 23 | ||||
| -rwxr-xr-x | jimdb | 466 |
6 files changed, 643 insertions, 0 deletions
diff --git a/Makefile.in b/Makefile.in index 1b5e00d..fbbc4ee 100644 --- a/Makefile.in +++ b/Makefile.in @@ -117,6 +117,7 @@ install: all @TCL_EXTS@ install-exec install-docs install-exec: all $(INSTALL_DATA_DIR) $(DESTDIR)@bindir@ $(INSTALL_PROGRAM) $(JIMSH) $(DESTDIR)@bindir@ + $(INSTALL_PROGRAM) jimdb $(DESTDIR)@bindir@ uninstall: rm -f $(DESTDIR)@bindir@/$(JIMSH) diff --git a/examples/dbgtest.tcl b/examples/dbgtest.tcl new file mode 100644 index 0000000..ef6b56f --- /dev/null +++ b/examples/dbgtest.tcl @@ -0,0 +1,34 @@ +# An example script useful for testing the Jim debugger +# Taken from http://www.nist.gov/msidlibrary/doc/libes93c.ps + +set b 1 + +proc p4 {x} { + return [ + expr 5+[expr 1+$x]] +} + +set z [ + expr 1+[expr 2+[p4 $b]] +] + +proc p3 {} { + set m 0 +} + +proc p2 {} { + set c 4 + p3 + set d 5 +} + +proc p1 {} { + set a 2 + p2 + set a 3 + set a 5 +} + +p1 +set k 7 +p1 diff --git a/examples/jcov b/examples/jcov new file mode 100755 index 0000000..1508f4b --- /dev/null +++ b/examples/jcov @@ -0,0 +1,66 @@ +#!/usr/bin/env jimsh +# vim:se syntax=tcl: + +# Experimental code coverage for Jim Tcl + +set auto_path [linsert $auto_path 0 [file dirname $argv0]/jimlib] + +set opt_all 0 +if {[lindex $argv 0] eq "-all"} { + incr opt_all + set argv [lrange $argv 1 end] +} + +set argv [lassign $argv argv0] + +set coverage($argv0) {} + +proc xcov {type file line result name arglist} { + upvar ::coverage($file) info + incr info($line) +} + +xtrace xcov + +# Catch exit but not error +set rc [catch -noerror -exit {source $argv0} msg opts] + +xtrace + +proc show-coverage {filename} { + set info $::coverage($filename) + + puts "=== $filename ===" + set f [open $filename] + set n 0 + while {[$f gets buf] >= 0} { + incr n + if {[info exists info($n)]} { + set prefix [format "%4d: " $info($n)] + } else { + set b [string trimleft $buf] + if {$b eq "" || [string match "#*" $b] || [string match "\}*" $b]} { + set prefix " -: " + } else { + set prefix "####: " + } + } + puts "$prefix$buf" + } + $f close +} + +puts [dict keys $coverage] +if {$opt_all} { + foreach filename [lsort [dict keys $coverage]] { + if {$filename in {"" jcov}} { + continue + } + show-coverage $filename + puts "" + } +} else { + show-coverage $argv0 +} + +#parray coverage diff --git a/examples/jtime b/examples/jtime new file mode 100755 index 0000000..1f1929f --- /dev/null +++ b/examples/jtime @@ -0,0 +1,53 @@ +#!/usr/bin/env jimsh +# vim:se syntax=tcl: + +# Experimental code coverage for Jim Tcl + +set auto_path [linsert $auto_path 0 [file dirname $argv0]/jimlib] + +set argv [lassign $argv argv0] + +set jtime::fileinfo($argv0) {} +set jtime::last [clock micros] + +proc jtime::xtrace {type file line result name arglist} { + variable fileinfo + variable last + set now [clock micros] + + if {![exists fileinfo($file)]} { + set info {} + } else { + set info $fileinfo($file) + } + incr info($line) $($now - $last) + set fileinfo($file) $info + + set last $now +} + +xtrace jtime::xtrace + +# Catch exit but not error +set rc [catch -noerror -exit {source $argv0} msg opts] + +xtrace + +set info $jtime::fileinfo($argv0) + +set f [open $argv0] +set n 0 +while {[$f gets buf] >= 0} { + incr n + if {[info exists info($n)]} { + set prefix [format "%8d: " $info($n)] + } else { + set b [string trimleft $buf] + if {$b eq "" || [string match "#*" $b] || [string match "\}*" $b]} { + set prefix " -: " + } else { + set prefix " ####: " + } + } + puts "$prefix$buf" +} diff --git a/examples/jtrace b/examples/jtrace new file mode 100755 index 0000000..87aee8e --- /dev/null +++ b/examples/jtrace @@ -0,0 +1,23 @@ +#!/usr/bin/env jimsh +# vim:se syntax=tcl: + +# Experimental code coverage for Jim Tcl + +set auto_path [linsert $auto_path 0 [file dirname $argv0]/jimlib] + +set argv [lassign $argv argv0] + +proc jtime::xtrace {type file line result name arglist} { + set indent [string repeat " " [info level]] + if {[string length $arglist] > 45} { + set arglist [string range $arglist 0 45]... + } + stderr puts "$indent$name [string map {\r \\r \n \\n} $arglist]" +} + +xtrace jtime::xtrace + +# Catch exit but not error +set rc [catch -noerror -exit {source $argv0} msg opts] + +xtrace @@ -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 |