Version 7 of a debugger with syntax highlighting using ctext
Updated 2005-09-29 04:23:24TR - Tcl is good at introspection for monitoring its own execution. Tk is good at graphical user interfaces. Combining them with little more than two standard extensions, namely ctext (for syntax highlighting) and BWidget (for a tree viewer) quickly makes a nice tool for debugging. You just plug in the following code in your main program
package require twDebugInspector twDebug::Inspector .newToplevel
and you get a picture like the following:
Although it resembles Mac OS X, this screenshot was made on Linux ...
Normally you also want to create a pkgIndex.tcl file containing:
package ifneeded twDebugInspector 1.0 [list source [file join $dir twDebugInspector.tcl]]
The code used to create that thing is down below. It is not completely finished but you can already use it to change procedures at runtime and save the changes back to the running program or to a file. This debugger was inspired by ped.
# twDebugInspector.tcl
# a Tcl introspection tool for debugging
#
# $Id: 13989,v 1.8 2005-09-29 06:00:49 jcw Exp $
package provide twDebugInspector 0.1
package require Tk 8.4
package require BWidget
package require ctext
namespace eval twDebug {
variable state ; # used to hold status data for the current item
variable config ; # used to hold configuration data (like window paths)
namespace export Inspector
}
# create a ctext widget and a browser for procedures and variables
#
proc twDebug::Inspector {toplevel} {
variable config
set w $toplevel
if {[winfo exists $w]} {
wm deiconify $w
raise $w
focus $w
update idletasks
return
}
toplevel $w
wm title $w {Tcl in-process inspector}
wm protocol $w WM_DELETE_WINDOW [list twDebug::InspectorClose $w]
# panedwindow holding tree and propc window:
panedwindow $w.pane -orient horizontal -showhandle 0 -sashwidth 1 \
-relief flat -borderwidth 1
# the ctext widget holding a selected proc:
twDebug::ScrolledWidget ctext $w.info 1 1 -width 80 -height 24 \
-highlightthickness 0 -background white -wrap none \
-tabs {0.5c 1c 1.5c 2c 2.5c 3c 3.5c 4c 4.5c 5c 5.5c 6c} \
-font {courier 10} -background #e5e5e5
set config(win,ctext) $w.info
# the tree holding all inspectable information:
twDebug::ScrolledWidget Tree $w.tree 0 1 -width 20 -height 35 \
-background white -borderwidth 2 -relief flat \
-linesfill gray -selectfill 1 -deltay 20 -deltax 20 \
-selectcommand [list twDebug::InspectorShowItem $w.info]
$w.pane add $w.tree -minsize 150
$w.pane add $w.info -minsize 100
# define highlight patterns (for the actual ctext widget...):
twDebug::setHighlightTcl $w.info.list
$w.info tag config err -foreground red
# change highlight patterns with other options than color:
$w.info tag configure cmds -font {courier 10 bold}
$w.info tag configure brackets -font {courier 10 bold}
$w.info tag configure comments -font {courier 10 italic}
twDebug::ButtonRow $w.btn \
"Apply changes" twDebug::InspectorApply \
"Save to file" twDebug::InspectorSave \
"Close window" [list twDebug::InspectorClose $w]
pack $w.btn -fill x -padx 10 -pady 10 -side bottom
pack $w.pane -fill both -expand yes -padx 10 -pady 10 -side top
# initialize the tree view with procs and vars ...
update idletasks
after idle [list twDebug::InspectorInit $w.tree.list]
}
proc twDebug::InspectorInit {win} {
$win delete [$win nodes root]
# procedures sorted by namespace:
after idle [list twDebug::InspectorInitNS $win ::]
# array variables:
after idle [list twDebug::InspectorInitArray $win ::]
# scalar variables:
after idle [list twDebug::InspectorInitScalar $win ::]
# widgets:
after idle [list $win insert end root widgets -text Widgets]
# bindings:
after idle [list $win insert end root bindings -text Bindings]
}
proc twDebug::InspectorInitNS {win ns} {
set parent "N[string map {: _} [namespace parent $ns]]"
set nodeText $ns
set nodeName "N[string map {: _} $ns]"
if {$parent == "N"} {
set parent "root"
set nodeText "Procedures"
}
# insert namespace:
$win insert end $parent $nodeName -fill blue -text $nodeText
# insert children:
foreach myNS [lsort -dictionary [namespace children $ns]] {
after idle [list after 0 [list twDebug::InspectorInitNS $win $myNS]]
}
# insert procedures:
foreach procedure [lsort -dictionary [namespace eval $ns {::info procs}]] {
$win insert end $nodeName "P$nodeName$procedure" -text $procedure -data P
}
}
proc twDebug::InspectorInitArray {win ns} {
set parent "NN[string map {: _} [namespace parent $ns]]"
set nodeText $ns
set nodeName "NN[string map {: _} $ns]"
if {$parent == "NN"} {
set parent "root"
set nodeText "Array variables"
}
# insert namespace:
$win insert end $parent $nodeName -fill green -text $nodeText
# insert children:
foreach myNS [lsort -dictionary [namespace children $ns]] {
after idle [list after 0 [list twDebug::InspectorInitArray $win $myNS]]
}
# insert variables:
foreach variable [lsort -dictionary [info vars ${ns}::*]] {
if {[array exists $variable]} {
set newNode "A$nodeName[string map {: _} $variable]"
$win insert end $nodeName $newNode -text $variable -data A
set i 0
#foreach el [array names $variable] {
# $win insert end $newNode "$newNode[incr i]" -text $el
#}
}
}
}
proc twDebug::InspectorInitScalar {win ns} {
set parent "NNN[string map {: _} [namespace parent $ns]]"
set nodeText $ns
set nodeName "NNN[string map {: _} $ns]"
if {$parent == "NNN"} {
set parent "root"
set nodeText "Scalar variables"
}
# insert namespace:
$win insert end $parent $nodeName -fill brown -text $nodeText
# insert children:
foreach myNS [lsort -dictionary [namespace children $ns]] {
after idle [list after 0 [list twDebug::InspectorInitScalar $win $myNS]]
}
# insert variables:
foreach variable [lsort -dictionary [info vars ${ns}::*]] {
if {![array exists $variable]} {
set newNode "S$nodeName[string map {: _} $variable]"
$win insert end $nodeName $newNode -text $variable -data S
}
}
}
proc twDebug::InspectorShowItem {info tree node} {
variable state
set data [$tree itemcget $node -data]
if {$data == ""} {return}
set state(itemType) $data
set name [$tree itemcget $node -text]
set NS [$tree itemcget [$tree parent $node] -text]
switch $data {
P {
if {$NS != "Procedures"} {set name "${NS}::$name"} else {set name "::$name"}
$info delete 1.0 end
$info fastinsert end "proc $name {[info args $name]} {"
$info fastinsert end [info body $name]
$info fastinsert end "}"
$info highlight 1.0 end
}
A {
$info delete 1.0 end
foreach el [array names $name] {
$info fastinsert end "$name\($el\) = [set ${name}($el)]\n"
}
}
S {
$info delete 1.0 end
$info fastinsert end "$name = [set ${name}]\n"
}
}
}
proc twDebug::InspectorApply {args} {
variable state
variable config
switch $state(itemType) {
P {
set w $config(win,ctext)
set data [$w get 1.0 "end - 1 char"]
if {[llength $data] != 4} {
tk_messageBox -message "The procedure seems to have a wrong format. Please verify that is has: 'proc name args body'."
return
}
if {[catch {uplevel #0 $data} error]} {
tk_messageBox -message "Saving failed:\n\n $error"
}
}
A - S {}
}
}
proc twDebug::InspectorClose {toplevel args} {
destroy $toplevel
}
proc twDebug::InspectorSave {args} {
variable config
set file [tk_getSaveFile]
if {$file == ""} {return}
set fh [open $file w]
puts $fh [$config(win,ctext) get 1.0 "end - 1 char"]
close $fh
}
# set hightlight patterns for the ctext widget
#
proc twDebug::setHighlightTcl {w} {
set color(widgets) red
set color(flags) orange
set color(vars) blue
set color(cmds) black
set color(brackets) DeepPink
set color(comments) black
set color(strings) #00bb00
ctext::addHighlightClass $w widgets $color(widgets) \
[list obutton button label text frame toplevel \
scrollbar checkbutton canvas listbox menu menubar menubutton \
radiobutton scale entry message spinbutton tk_chooseDir tk_getSaveFile \
tk_getOpenFile tk_chooseColor tk_optionMenu tk_dialog tk_messageBox \
panedwindow]
ctext::addHighlightClass $w flags $color(flags) \
[list -text -command -yscrollcommand \
-xscrollcommand -background -foreground -fg -bg \
-highlightbackground -y -x -highlightcolor -relief -width \
-height -wrap -font -fill -side -outline -style -insertwidth \
-textvariable -activebackground -activeforeground \
-insertbackground -anchor -orient -troughcolor -nonewline \
-expand -type -message -title -offset -in -after -yscroll \
-xscroll -forward -regexp -count -exact -padx -ipadx \
-filetypes -all -from -to -label -value -variable \
-regexp -backwards -forwards -bd -pady -ipady -state -row \
-column -cursor -highlightcolors -linemap -menu -tearoff \
-displayof -cursor -underline -tags -tag -length]
ctext::addHighlightClassWithOnlyCharStart $w vars $color(vars) "\$"
ctext::addHighlightClass $w cmds $color(cmds) \
[list break case continue exit for foreach if then elseif else \
return switch while file info concat join lappend lindex linsert \
list llength lrange lreplace lsearch lsort split array parray \
append binary format regexp regsub scan string subst \
cd clock exec glob pid pwd close eof fblocked fconfigure fcopy \
fileevent flush gets open puts read seek socket tell interp \
package namespace variable after auto_execok auto_load auto_mkindex \
auto_reset bgerror catch error eval expr global history incr load proc \
rename set source time trace unknown unset update uplevel upvar vwait \
winfo wm bind event pack place grid font bell clipboard destroy focus \
grab lower option raise selection send tk tkwait tk_bisque \
tk_focusNext tk_focusPrev tk_focusFollowsMouse tk_popup tk_setPalette]
ctext::addHighlightClassForSpecialChars $w brackets $color(brackets) {[]{}}
ctext::addHighlightClassForRegexp $w comments $color(comments) {\#[^\n\r]*}
ctext::addHighlightClassForRegexp $w strings $color(strings) {"(\\"|[^"])*"}
}
# build a row of buttons that are shown from left to right
#
# win -> frame that holds all buttons
# args -> list with pairs of: "button_text button_command"
#
# Returns: a list of all paths to the buttons
# in the order there where specified
#
# side-effect: the arguments of specified commands are also lappended
# with the paths of the buttons
#
proc twDebug::ButtonRow {win args} {
frame $win -relief groove
set index -1
set width 0
foreach {but cmd} $args {
incr index
if {[string length $but] > $width} {set width [string length $but]}
set b [button $win.but$index -text $but]
# remember command:
set cmdArray($index) $cmd
lappend blist $b
pack $win.but$index -side left -padx 5 -pady 5
}
# configure all commands:
for {set i 0} {$i <= $index} {incr i} {
set command $cmdArray($i)
foreach el $blist {lappend command $el}
$win.but$i configure -command $command
}
incr width 3
# second pass to make the button widths equal:
foreach widget $blist {$widget configure -width $width}
return $blist
}
# create a standard widget with scrollbars around
#
# wigdet -> name of the widget to be created
# parent -> path to the frame, in which the widget and the scrollbars should
# be created
# scrollx -> boolean; create horizontal scrollbar?
# scrolly -> boolean; create vertical scrollbar?
# args -> additional arguments passed on the the widget
#
# returns: the path to the created widget (frame)
#
proc twDebug::ScrolledWidget {widget parent scrollx scrolly args} {
# Create widget attached to scrollbars, pass thru $args
frame $parent
eval $widget $parent.list $args
# Create scrollbars attached to the listbox
if {$scrollx} {
scrollbar $parent.sx -orient horizontal \
-command [list $parent.list xview] -elementborderwidth 1
grid $parent.sx -column 0 -row 1 -sticky ew
$parent.list configure -xscrollcommand [list $parent.sx set]
}
if {$scrolly} {
scrollbar $parent.sy -orient vertical \
-command [list $parent.list yview] -elementborderwidth 1
grid $parent.sy -column 1 -row 0 -sticky ns
$parent.list configure -yscrollcommand [list $parent.sy set]
}
# Arrange them in the parent frame
grid $parent.list -column 0 -row 0 -sticky ewsn
grid columnconfigure $parent 0 -weight 1
grid rowconfigure $parent 0 -weight 1
# hide the original widget command from the interpreter:
interp hide {} $parent
# Install the alias:
interp alias {} $parent {} twDebug::ScrolledWidgetCmd $parent.list
# fix the bindings for the listbox:
bindtags $parent.list [lreplace [bindtags $parent.list] 0 0 $parent]
#set tags [lrange [bindtags $parent.list] 1 end]
#bindtags $parent.list "$parent $tags"
#
return $parent
}
proc twDebug::ScrolledWidgetCmd {self cmd args} {
switch -- $cmd {
widgetPath {return "$self.list"}
default {return [uplevel 1 [list $self $cmd] $args]}
}
}wcf3 This is really cool. I did find a minor problem when using the tDOM package. There is a ::dom::domDoc::info proc that messes up twDebug::InspectorInitNS when it runs info procs in that namespace. I modified that code to use ::info procs instead, and it works great now. -- TR Thanks for this improvement!
RLH That is neat.
MG This is extremely cool. The only problem I have with it is that, with my screen set to 1024x768, I was looking at a var with a very long value and found that most of it was off the screen, because the window was much bigger than my screen. Haven't looked for the problem yet (squinting too much atm to be likely to find it), though...
Category Application | Category Debugging | Category Dev. Tools