Jim TCL debugging

/df

Well-Known Member
Debugging the Jim TCL code that is used to code a lot of the CF packages is a bit primitive. Techniques available include sourcing (possibly tweaked) code into the interactive Jim shell and running bits of it there, and inserting puts to track the execution and display values of variables. This isn't very satisfactory and I went looking for better solutions.

The Jim implementation is a pretty capable TCL, but doesn't have certain primitives (eg trace) needed to support debugging packages designed for TCL (eg). However this snippet seemed to have some utility, and I've extended it somewhat, to add some more breakpoint commands and command history. You still can't break on line numbers but you can break and trace procs.

The code below should be saved as /mod/lib/jim/debug.tcl.

Code:
# "A minimal debugger" 
# Based on <https://wiki.tcl-lang.org/page/A+minimal+debugger> by Richard Suchenwirth
# (who is a bit of a TCL genius BTW)

package provide debug 1.0
# in the debuggee code, say 'package require debug' and 'namespace import debug::*'
# then insert calls to 'bp [breakpoint-name]' at interesting points
# also 'bproc procname' to break around proc procname
# and 'tproc procname' to trace proc procname

package require namespace 

namespace eval debug {

	namespace export bp bproc tproc
	
	variable cmds

	# breakpoint commands (1 char); format {cmd-char cmd-body cmd-helptext ...}
	# body ends with continue if the command $line should not be executed 
	set cmds {c {puts "continuing.."; break} "continue the program"
		  i {set line {info locals}} "info locals"
		  s {lappend ::debug::bp_skip [lrange $line 1 end]; continue} "s pattern[s]: skip matching breakpoints"
		  d {foreach var [lrange $line 1 end] {
		     	switch -glob -- $var {
		     	-* {set ::debug::bp_displ \
		     	       [lsearch -exact -inline -not -all $::debug::bp_displ [string range $var 1 end]]}
		     	*  {lappend ::debug::bp_displ $var}
		     	}}; continue} "d var ...: display var and its value on each break (-var to cancel)"
		  p {foreach prc [lrange $line 1 end] {uplevel 1 ::debug::bproc $prc}; continue} "p proc ...: break around each call to proc (-proc to cancel)"
		  t {foreach prc [lrange $line 1 end] {uplevel 1 ::debug::tproc $prc}; continue} "t proc ...: trace calls to each proc (-proc to cancel)"
		  h {puts "Available commands:"
		     foreach {cmd body help} $::debug::cmds { puts "$cmd\t$help" }
		     puts "Any Tcl command, that will be run in the scope of the breakpoint."
		     continue} "this help"
		 }
		       
	if {[info commands history] ne {}} {
		history completion [lambda {line} {
			foreach {cmd junk junk} $cmds {
				if {$cmd eq $line} {return $line}
			}
			return [tcl::autocomplete $line]
			}]	
		proc getline {prompt {varname ""}} {
			if {$varname ne ""} {
				upvar 1 $varname line
			}
			if {[history getline $prompt line] > 0} {
				history add $line
			}
		}
	} else {
		proc getline {prompt {varname ""}} {
			puts -nonewline $prompt; flush stdout
			gets stdin $varname
		}
	}
	
	
	proc _bp {{s {}} {who {}}} {
		if {![info exists ::debug::bp_skip]} {
			set ::debug::bp_skip [list]
		} elseif {[lsearch -command [lambda {p v} {string match $v $p}] $::debug::bp_skip $s] >= 0} {
			return
		}	
		if {![info exists ::debug::bp_displ]} {
			set ::debug::bp_displ [list]
		} else {
			foreach var $::debug::bp_displ {
				uplevel 1 [subst -nocommands {
					if {[info exists $var]} {
						puts "$var=[set $var]"
					} else {
						puts "$var - unset"
					}}]	
			}
		}	
		if {$who eq {} && [catch {info level -1} who]} {set who ::}
		while 1 {
			getline "$who/$s> " line
			set bpcmd ""
			foreach {cmd body junk} $::debug::cmds {
				if {$cmd ne [lindex $line 0]} {continue}
				set bpcmd $body
				break
			}
			if {$bpcmd ne ""} {eval $bpcmd}
			catch {uplevel 1 $line} res
			puts $res
		}
	}
	
	proc bp {{s {}}} {
		tailcall _bp $s
	} 

	proc bproc {name} {
		switch -glob -- $name {
		-*	{	set name [string range $name 1 end]
				set wrapped "::debug::[set name]bwrapped"
				if {$wrapped in [uplevel 1 info procs $wrapped]} {
					uplevel 1 rename $wrapped $name
				} else {puts "Proc $name not broken"; return}
			}	
		*	{	if {$name ni [uplevel 1 info procs $name]} {puts "Unknown proc $name"; return}
				set wrapped "::debug::[set name]bwrapped"
				uplevel 1 rename $name $wrapped
				uplevel 1 proc $name [list [info args $wrapped]] \
					[list "_bp Enter \"proc $name\"\nputs Result=\[set __result__ \[eval \{[info body $wrapped]\} ]]\n_bp Leave \"proc $name\""]
			}
		}
		return $name
	}


	proc tproc {name} {
		switch -glob -- $name {
		-*	{	set name [string range $name 1 end]
				set wrapped "::debug::[set name]twrapped"
				if {$wrapped in [uplevel 1 info procs $wrapped]} {
					uplevel 1 rename $wrapped $name
				} else {puts "Proc $name not traced"; return}
			}	
		*	{	if {$name ni [uplevel 1 info procs $name]} {puts "Unknown proc $name"; return}
				set wrapped "::debug::[set name]twrapped"
				uplevel 1 rename $name $wrapped
				uplevel 1 proc $name [list [info args $wrapped]] \
					[list "puts \[info level]:\[info level 0]\n#:\n[info body $wrapped]"]
			}
		}
		return $name
	}
}
 
I shall have to experiment, debugging has never been that easy.

Perhaps store it as a package on git.hpkg.tv to ease downloading and installing
 
Jim has now acquired the xtrace command and its own debugger. This should arrive in (a yet to be released) version 0.81
(Now I've finally worked out how to build it properly...) I've upgraded my machines to 0.80 and it all seems to work OK. Then I moved on to the dev. master build and that's OK too.
 
Back
Top