package require twDebugInspector
   twDebug::Inspector .newToplevel

  package ifneeded twDebugInspector 1.0 [list source [file join $dir twDebugInspector.tcl]]

 # 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]}
         }
 }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References