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>

4 files changed, 176 insertions, 0 deletions

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