Initial revision

diff --git a/globals_list.tcl b/globals_list.tcl
new file mode 100644 (file)
index 0000000..fe23513
--- /dev/null
+++ b/globals_list.tcl
@@ -0,0 +1,130 @@
+#
+# $Id$
+#
+
+set variable_trace_priv(counter) -1
+set variable_trace_priv(trace_text) {
+    send %s 
+}
+dialog variable_trace {
+    param target ""
+    param variable ""
+    param width 50
+    param height 5
+    param savelines 50
+    member is_array 0
+    member trace_cmd ""
+    method create {} {
+       scrollbar $self.sb -relief sunken -bd 1 -command "$self.t yview"
+       text $self.t -yscroll "$self.sb set" -setgrid 1
+       pack $self.sb -side right -fill y
+       pack $self.t -side right -fill both -expand 1
+       if {[send $slot(target) array size $slot(variable)] == 0} {
+           set slot(trace_cmd) "send [winfo name .] $self update_scalar"
+           $self update_scalar "" "" w
+           set slot(is_array) 0
+           set title "Trace Scalar"
+       } else {
+           set slot(trace_cmd) "send [winfo name .] $self update_array"
+           set slot(is_array) 1
+           set title "Trace Array"
+       }
+       send $slot(target) \
+           [list trace variable $slot(variable) wu $slot(trace_cmd)]
+       wm title $self "$title: $slot(target)/$slot(variable)"
+       wm iconname $self "$title: $slot(target)/$slot(variable)"
+    }
+    method reconfig {} {
+       $self.t config -width $slot(width) -height $slot(height)
+    }
+    method destroy {} {
+       send $slot(target) \
+           [list trace vdelete $slot(variable) wu $slot(trace_cmd)]
+    }
+    method update_scalar {name op} {
+       if {$op == "w"} {
+           $self.t insert end-1c \
+               [list set $slot(variable) \
+                [send $slot(target) [list set $slot(variable)]]]
+       } else {
+           $self.t insert end-1c [list unset $slot(variable)]
+       }
+       $self.t insert end-1c "\n"
+       $self scroll
+    }
+    method update_array {args} {
+       if {[set len [llength $args]] == 3} {
+           set n1 [lindex $args 0]
+           set n2 [lindex $args 1]
+           set op [lindex $args 2]
+       } else {
+           set n1 [lindex $args 0]
+           set op [lindex $args 1]
+       }
+       if {$op == "w"} {
+           $self.t insert end-1c \
+               [list set [set n1]([set n2]) \
+                [send $slot(target) [list set [set slot(variable)]([set n2])]]]
+       } elseif {[info exists n2]} {
+           $self.t insert end-1c [list unset [set slot(variable)]([set n2])]
+       } else {
+           $self.t insert end-1c [list unset $slot(variable)]
+       }
+       $self.t insert end-1c "\n"
+       $self scroll
+    }
+    method scroll {} {
+       scan [$self.t index end] "%d.%d" line col
+       if {$line > $slot(savelines)} {
+           $self.t delete 1.0 1.10000
+       }
+       $self.t see end
+    }
+}
+
+proc create_variable_trace {target var} {
+    global variable_trace_priv
+    variable_trace .vt[incr variable_trace_priv(counter)] -target $target \
+       -variable $var
+}
+
+widget globals_list {
+    object_include tkinspect_list
+    param title "Globals"
+    method get_item_name {} { return global }
+    method create {} {
+       tkinspect_list:create $self
+       $slot(menu) add separator
+       $slot(menu) add command -label "Trace Variable" \
+           -command "$self trace_variable"
+    }
+    method update {target} {
+       $self clear
+       foreach var [lsort [send $target info globals]] {
+           $self append $var
+       }
+    }
+    method retrieve {target var} {
+       if ![send $target [list array size $var]] {
+           return [list set $var [send $target [list set $var]]]
+       }
+       set result {}
+       foreach elt [lsort [send $target [list array names $var]]] {
+           append result [list set [set var]($elt) \
+                          [send $target [list set [set var]($elt)]]]
+           append result "\n"
+       }
+       return $result
+    }
+    method send_filter {value} {
+       return $value
+    }
+    method trace_variable {} {
+       set target [$slot(main) target]
+       if ![string length $slot(current_item)] {
+           tkinspect_failure \
+            "No global variable has been selected.  Please select one first."
+       }
+       create_variable_trace $target $slot(current_item)
+    }
+}

diff --git a/procs_list.tcl b/procs_list.tcl
new file mode 100644 (file)
index 0000000..a2da5fa
--- /dev/null
+++ b/procs_list.tcl
@@ -0,0 +1,34 @@
+#
+# $Id$
+#
+
+widget procs_list {
+    object_include tkinspect_list
+    param title "Procs"
+    method get_item_name {} { return proc }
+    method update {target} {
+       $self clear
+       foreach proc [lsort [send $target info procs]] {
+           $self append $proc
+       }
+    }
+    method retrieve {target proc} {
+       set result [list proc $proc]
+       set formals {}
+       foreach arg [send $target [list info args $proc]] {
+           if [send $target [list info default $proc $arg __tkinspect_default_arg__]] {
+               lappend formals [list $arg [send $target \
+                                   [list set __tkinspect_default_arg__]]]
+           } else {
+               lappend formals $arg
+           }
+       }
+       send $target catch {unset __tkinspect_default_arg__}
+       lappend result $formals
+       lappend result [send $target [list info body $proc]]
+       return $result
+    }
+    method send_filter {value} {
+       return $value
+    }
+}

diff --git a/windows_list.tcl b/windows_list.tcl
new file mode 100644 (file)
index 0000000..182154f
--- /dev/null
+++ b/windows_list.tcl
@@ -0,0 +1,144 @@
+#
+# $Id$
+#
+
+widget windows_list {
+    object_include tkinspect_list
+    param title "Windows"
+    member filter_empty_window_configs 1
+    member filter_window_class_config 1
+    member filter_window_pack_in 1
+    member mode config
+    method get_item_name {} { return window }
+    method create {} {
+       tkinspect_list:create $self
+       $slot(menu) add separator
+       $slot(menu) add radiobutton -variable [object_slotname mode] \
+           -value config -label "Window Configuration" -underline 7 \
+            -command "$self change_mode"
+        $slot(menu) add radiobutton -variable [object_slotname mode] \
+           -value packing -label "Window Packing" -underline 7 \
+            -command "$self change_mode"
+        $slot(menu) add radiobutton -variable [object_slotname mode] \
+           -value slavepacking -label "Slave Window Packing" -underline 1 \
+            -command "$self change_mode"
+        $slot(menu) add radiobutton -variable [object_slotname mode] \
+           -value bindings -label "Window Bindings" -underline 7 \
+            -command "$self change_mode"
+        $slot(menu) add radiobutton -variable [object_slotname mode] \
+           -value classbindings -label "Window Class Bindings" -underline 8 \
+            -command "$self change_mode"
+        $slot(menu) add separator
+        $slot(menu) add checkbutton \
+           -variable [object_slotname filter_empty_window_configs] \
+            -label "Filter Empty Window Options" -underline 0
+        $slot(menu) add checkbutton \
+           -variable [object_slotname filter_window_class_config] \
+            -label "Filter Window -class Options" -underline 0
+        $slot(menu) add checkbutton \
+           -variable [object_slotname filter_window_pack_in] \
+            -label "Filter Pack -in Options" -underline 0
+    }
+    method get_windows {target result_var parent} {
+       upvar $result_var result
+       foreach w [send $target winfo children $parent] {
+           lappend result $w
+           $self get_windows $target result $w
+       }
+    }
+    method update {target} {
+       $self clear
+       set windows .
+       $self get_windows $target windows .
+       foreach w $windows {
+           $self append $w
+       }
+    }
+    method set_mode {mode} {
+       set slot(mode) $mode
+       $self change_mode
+    }
+    method change_mode {} {
+       if {[$slot(main) last_list] == $self} {
+           $slot(main) select_list_item $self $slot(current_item)
+       }
+    }
+    method retrieve {target window} {
+       set result [$self retrieve_$slot(mode) $target $window]
+       set old_bg [send $target [list $window cget -background]]
+       send $target [list $window config -background #ff69b4]
+       send $target [list after 200 \
+                     [list catch [list $window config -background $old_bg]]]
+       return $result
+    }
+    method retrieve_config {target window} {
+       set result "# window configuration of $window\n"
+       append result "$window config"
+       foreach spec [send $target [list $window config]] {
+           if {[llength $spec] == 2} continue
+           append result " \\\n\t[lindex $spec 0] [list [lindex $spec 4]]"
+       }
+       append result "\n"
+       return $result
+    }
+    method format_packing_info {result_var window info} {
+       upvar $result_var result
+       append result "pack configure $window"
+       set len [llength $info]
+       for {set i 0} {$i < $len} {incr i 2} {
+           append result " \\\n\t[lindex $info $i] [lindex $info [expr $i+1]]"
+       }
+       append result "\n"
+    }
+    method retrieve_packing {target window} {
+       set result "# packing info for $window\n"
+       if [catch {send $target pack info $window} info] {
+           append result "# $info\n"
+       } else {
+           $self format_packing_info result $window $info
+       }
+       return $result
+    }
+    method retrieve_slavepacking {target window} {
+       set result "# packing info for slaves of $window\n"
+       foreach slave [send $target pack slaves $window] {
+           $self format_packing_info result $slave \
+               [send $target pack info $slave]
+       }
+       return $result
+    }
+    method retrieve_bindings {target window} {
+       set result "# bindings of $window"
+       foreach sequence [send $target bind $window] {
+           append result "\nbind $window $sequence "
+           lappend result [send $target bind $window $sequence]
+       }
+       append result "\n"
+       return $result
+    }
+    method retrieve_classbindings {target window} {
+       set class [send $target winfo class $window]
+       set result "# class bindings for $window\n# class: $class"
+       foreach sequence [send $target bind $class] {
+           append result "\nbind $class $sequence "
+           lappend result [send $target bind $class $sequence]
+       }
+       append result "\n"
+       return $result
+    }
+    method send_filter {value} {
+       if $slot(filter_empty_window_configs) {
+           regsub -all {[ \t]*-[^ \t]+[ \t]+{}([ \t]*\\?\n?)?} $value {\1} \
+               value
+       }
+       if $slot(filter_window_class_config) {
+           regsub -all "(\n)\[ \t\]*-class\[ \t\]+\[^ \\\n\]*\n?" $value \
+               "\\1" value
+       }
+       if $slot(filter_window_pack_in) {
+           regsub -all "(\n)\[ \t\]*-in\[ \t\]+\[^ \\\n\]*\n?" $value \
+               "\\1" value
+       }
+       return $value
+    }
+}