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
The Jim implementation is a pretty capable TCL, but doesn't have certain primitives (eg
The code below should be saved as
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
}
}
