From: sls <sls>
Date: Tue, 7 Feb 1995 08:24:06 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: r5_1_1~74
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=9c94383c0f17352d596ce77a15d8d4df6284822d;p=tkinspect

Initial revision
---

diff --git a/globals_list.tcl b/globals_list.tcl
new file mode 100644
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
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
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
+    }
+}