[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:

[http://tcl.typoscriptics.de/misc/ctext.gif]

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.13 2005-10-01 06:00:47 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
			 $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...

[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 !?

----

[Category Application] | [Category Debugging] | [Category Dev. Tools]