a debugger with syntax highlighting using ctext
TR - 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.16 2005-10-03 06:00:25 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 60 -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 20 \
-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
set argList [list]
foreach arg [info args $name] {
if {[info default $name $arg stdVar] == 1} {
lappend argList [list $arg $stdVar]
} else {
lappend argList $arg
}
}
$info fastinsert end "proc $name {$argList} {"
$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...
TR Hmm, interesting. Do you mean the debugger window is bigger than your screen? I modified the code above to give a smaller window now. Will it fit then?
MG I did, yes - though, looking at it closer now that I'm more awake, the problem is not with the toplevel. Even with the whole toplevel visible, the text widget appears to be larger than the area allocated to it inside the toplevel, so a large part of it just isn't visible on screen. I just clicked at the start of the first line of visible text, and kept pressing the right arrow key - after 80 keypresses, I got to the last character visible on the screen, but it took a further 83 keypresses (moving the cursor right another 83 characters, basically) before the text widget start to scroll right to make more characters visible. Even configuring the Ctext widget to be -width 1 -wrap char does not sort the problem - it wraps, but it's still far wider than the portion which shows on the screen. This is on ActiveTcl 8.4.9 (which has ctext 3.1) on Win XP SP2, by the way.
TR - I was not able to reproduce this behaviour. I found a box with Win XP and SP2 now and tried to follow your description (using a freshly installed ActiveTcl 8.4.9). The widget scrolled as expected and nothing weird happend ... I am a bit confused now !?
MG I've put three screenshots of it up on my website in this folder [L1 ] . The image d1.jpg is what I get when I fire up a wish console and paste your code straight in - perfect. d2.jpg is what I get when I paste the code into the console of a particular app (it comes up terribly small), and d3.jpg is that same small window when maximised - as you can see, there's no scrollbar showing up on the right.
The app I've been pasting it into (Potato MUSH (MUD) Client) doesn't alter the option database, or anything like that, so I'm not sure why it has such an adverse effect on the display of your code's window.. but I just tried pasting it into another app's console (TriPeaks Solitaire, this time) and it came up perfectly. Curious...
TR - OK. I think I know what might go on there. I had a look at your Potato MUSH Client and found that is uses Iwidgets. The widgets from the IWidgets set also have a panedwindow widget which shares the same class as the Tk core panedwindow. I would imagine that these two interfere in a way that makes my debugger do weird things. Have a look at this page about the iwidgets panedwindow to see what problems arise and how to probably fix them. Does this help'?
MG Ahh yes, that hadn't occurred to me. I'm pretty sure you're right, and that is the problem. (That app actually deletes all the Tk bindings for the panedwindow, so they don't interfere with the IWidgets ones, which probably makes things even worse when the Tk panedwindow is used.) Thanks very much for looking into it and finding the problem :)
See also Tkinspect