From: sls <sls>
Date: Thu, 2 Feb 1995 10:18:48 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: r5_1_1~78
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=4e9e302f317ec7774e3cc29aae362990d1653e7d;p=tkinspect

Initial revision
---

diff --git a/about.tcl b/about.tcl
new file mode 100644
index 0000000..c6dc49f
--- /dev/null
+++ b/about.tcl
@@ -0,0 +1,44 @@
+#
+# $Id$
+#
+# Handle the about box.
+#
+
+dialog about {
+    param obliqueFont -*-helvetica-medium-o-*-*-12-* Font
+    param font -*-helvetica-medium-r-*-*-12-* Font
+    param boldFont -*-helvetica-bold-r-*-*-18-* Font 
+    method create {} {
+	global tkinspect tkinspect_library
+	wm withdraw $self
+	wm transient $self .
+	pack [frame $self.border -relief ridge -bd 4]
+	label $self.title -text "tkinspect" -font $slot(boldFont)
+	label $self.ver \
+	    -text "Release $tkinspect(release) ($tkinspect(release_date))" \
+	    -font $slot(font)
+	label $self.com -text "Send comments, suggestions, bugs to:" \
+	    -font $slot(obliqueFont)
+	frame $self.mug -bd 4
+	label $self.mug.l -text "Sam Shen <slshen@lbl.gov>"
+	label $self.mug.bm -bitmap @$tkinspect_library/sls.xbm -bd 2 \
+	    -relief sunken
+	pack $self.mug.l $self.mug.bm -in $self.mug \
+	    -side left -fill both -expand yes
+	button $self.ok -text "Ok" -command "destroy $self"
+	pack $self.title $self.ver $self.com $self.mug \
+	    -in $self.border -side top -fill x
+	pack $self.ok -in $self.border -side bottom -pady 5
+	bind $self <Return> "destroy $self"
+    }
+    method reconfig {} {
+    }
+    method run {} {
+	wm deiconify $self
+	focus $self
+	center_window $self
+	tkwait visibility $self
+	grab set $self
+	tkwait window $self	
+    }
+}
diff --git a/defaults.tcl b/defaults.tcl
new file mode 100644
index 0000000..cc43e38
--- /dev/null
+++ b/defaults.tcl
@@ -0,0 +1,18 @@
+#
+# $Id$
+#
+
+proc tkinspect_default_options {} {
+    global tkinspect_default
+    option add *Scrollbar*width 12
+    option add *Label*padX 0
+    option add *Label*padY 0
+    option add *Label*borderWidth 0
+    option add *Frame.highlightThickness 0
+    option add *Frame.borderWidth 2
+    option add *Value*vname*font \
+	-adobe-courier-medium-r-*-*-*-130-*-*-*-*-iso8859-*
+    option add *Value*Text*font \
+	-adobe-courier-medium-r-*-*-*-130-*-*-*-*-iso8859-*
+    set tkinspect_default(lists) "procs_list globals_list windows_list"
+}
diff --git a/lists.tcl b/lists.tcl
new file mode 100644
index 0000000..8643e98
--- /dev/null
+++ b/lists.tcl
@@ -0,0 +1,182 @@
+#
+# $Id$
+#
+
+widget clickable_list {
+    param command {}
+    param title {}
+    param width 30
+    param height 12
+    param main
+    method create {} {
+	$self config -bd 2 -relief raised
+	pack [label $self.title -anchor w] -side top -fill x
+	scrollbar $self.sb -command "$self.list yview" -relief sunken -bd 1
+	listbox $self.list -relief sunken -exportselection 0 \
+	    -yscroll "$self.sb set" -selectmode single
+	bind $self.list <1> "$self click %x %y; continue"
+	pack $self.sb -side right -fill y
+	pack $self.list -side right -fill both -expand yes
+    }
+    method reconfig {} {
+	$self.title config -text $slot(title)
+	$self.list config -width $slot(width) -height $slot(height)
+    }
+    method list args {
+	eval $self.list $args
+    }
+    method click {x y} {
+	if [string length $slot(command)] {
+	    set item [$self.list get @$x,$y]
+	    if [string length $item] {
+		uplevel #0 [concat $slot(command) $item]
+	    }
+	}
+    }
+}
+
+widget procs_list {
+    object_include clickable_list
+    param title "Procs:"
+    method get_item_name {} { return proc }
+    method update {target} {
+	$self list delete 0 end
+	foreach proc [lsort [send $target info procs]] {
+	    $self list insert end $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
+    }
+}
+
+widget globals_list {
+    object_include clickable_list
+    param title "Globals:"
+    method get_item_name {} { return global }
+    method update {target} {
+	$self list delete 0 end
+	foreach var [lsort [send $target info globals]] {
+		$self list insert end $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
+    }
+}
+
+widget windows_list {
+    object_include clickable_list
+    param title "Windows:"
+    member mode {config}
+    method get_item_name {} { return window }
+    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 list delete 0 end
+	set windows {}
+	$self get_windows $target windows .
+	foreach w $windows {
+	    $self list insert end $w
+	}
+    }
+    method set_mode {mode} {
+	set slot(mode) $mode
+    }
+    method retrieve {target window} {
+	$self retrieve_$slot(mode) $target $window
+    }
+    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"
+	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_packing {target window} {
+	set result "# packing info for $window\n"
+	if [catch {send $target pack info $window} info] {
+	    append result "# $info\n"
+	} else {
+	    append result "pack $window $info\n"
+	}
+	return $result
+    }
+    method retrieve_slavepacking {target window} {
+	set result "# packing info for slaves of $window\n"
+	foreach slave [send $target pack slaves $window] {
+	    append result "pack $window [send $target pack info $slave]\n"
+	}
+	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(main) cget -filter_empty_window_configs] {
+	    regsub -all {[ \t]*-[^ \t]+[ \t]+{}([ \t]*\\?\n?)?} $value {\1} \
+		value
+	}
+	if [$slot(main) cget -filter_window_class_config] {
+	    regsub -all "(\n)\[ \t\]*-class\[ \t\]+\[^ \\\n\]*\n?" $value \
+		"\\1" value
+	}
+	return $value
+    }
+}
diff --git a/tkinspect.tcl b/tkinspect.tcl
new file mode 100644
index 0000000..0702cb1
--- /dev/null
+++ b/tkinspect.tcl
@@ -0,0 +1,180 @@
+#!@wish@ -f
+#
+# $Id$
+#
+
+set tkinspect(counter) -1
+set tkinspect(main_window_count) 0
+set tkinspect(release) 5
+set tkinspect(release_date) "Jan 30, 1995"
+
+wm withdraw .
+
+if [file exists @stl_library@/tclIndex] {
+    lappend auto_path @stl_library@
+} else {
+    lappend auto_path /usr/local/lib/stl
+    lappend auto_path /vol/pub/stl-0.2/lib/stl
+}
+
+if [file exists @tkinspect_library@/tclIndex] {
+    lappend auto_path [set tkinspect_library @tkinspect_library@]
+} else {
+    lappend auto_path [set tkinspect_library .]
+}
+
+
+proc tkinspect_exit {} {
+    destroy .
+    exit 0
+}
+
+proc tkinspect_widgets_init {} {
+    global tkinspect_library
+    foreach file {lists.tcl about.tcl value.tcl} {
+	source $tkinspect_library/$file
+    }
+}
+
+proc tkinspect_about {} {
+    catch {destroy .about}
+    about .about
+    .about run
+}
+
+dialog tkinspect_main {
+    member lists {}
+    member counter -1
+    member target
+    member window_info_type config
+    param filter_empty_window_configs 1
+    param get_window_info 1
+    param filter_window_class_config 1
+    method create {} {
+	global tkinspect_default
+	$self config -highlightthickness 0 -bd 2
+	pack [frame $self.menu -bd 2 -relief raised] -side top -fill x
+	menubutton $self.menu.file -menu $self.menu.file.m -text "File" \
+	    -bd 0
+	pack $self.menu.file -side left
+	set m [menu $self.menu.file.m]
+	$m add cascade -label "Select Interpreter" \
+	    -menu $self.menu.file.m.interps -command "$self fill_interp_menu"
+	$m add command -label "New Window" -command create_main_window
+	$m add command -label "Update Lists" -command "$self update_lists"
+	$m add separator
+	$m add command -label "Close Window" -command "$self close"
+	$m add command -label "Exit" -command tkinspect_exit
+	menu $self.menu.file.m.interps
+	menubutton $self.menu.options -menu $self.menu.options.m \
+	    -text "Options" -bd 0
+	set m [menu $self.menu.options.m]
+	$m add radiobutton -variable [object_slotname window_info_type] \
+	    -value config -label "Window Configuration" -underline 7 \
+            -command "$self change_window_info_type"
+        $m add radiobutton -variable [object_slotname window_info_type] \
+	    -value packing -label "Window Packing" -underline 7 \
+            -command "$self change_window_info_type"
+        $m add radiobutton -variable [object_slotname window_info_type] \
+	    -value slavepacking -label "Slave Window Packing" -underline 1 \
+            -command "$self change_window_info_type"
+        $m add radiobutton -variable [object_slotname window_info_type] \
+	    -value bindings -label "Window Bindings" -underline 7 \
+            -command "$self change_window_info_type"
+        $m add radiobutton -variable [object_slotname window_info_type] \
+	    -value classbindings -label "Window Class Bindings" -underline 8 \
+            -command "$self change_window_info_type"
+        $m add separator
+        $m add checkbutton \
+	    -variable [object_slotname filter_empty_window_configs] \
+            -label "Filter Empty Window Options" -underline 0
+        $m add checkbutton \
+	    -variable [object_slotname filter_window_class_config] \
+            -label "Filter Window -class Options" -underline 0
+        $m add checkbutton \
+	    -variable [object_slotname get_window_info] \
+            -label "Get Window Information" -underline 0
+	pack $self.menu.options -side left
+	menubutton $self.menu.help -menu $self.menu.help.m -text "Help" \
+	    -bd 0
+	pack $self.menu.help -side right
+	set m [menu $self.menu.help.m]
+	$m add command -label "About..." -command tkinspect_about
+	pack [frame $self.lists -bd 0] -side top -fill both -expand 1
+	set slot(lists) ""
+	set i -1
+	foreach list_class $tkinspect_default(lists) {
+	    set list $self.lists.l[incr i]
+	    $list_class $list -command "$self list_item_click $list" \
+		-main $self
+	    lappend slot(lists) $list
+	    pack $list -side left -fill y -expand 1
+	}
+	value $self.value -main $self
+	pack $self.value -side top -fill both -expand 1
+	pack [frame $self.status] -side top -fill x
+	label $self.status.l -bd 2 -relief sunken -anchor w
+	pack $self.status.l -side left -fill x -expand 1
+	wm iconname $self "Tkinspect"
+	wm title $self "Tkinspect:"
+	$self status "Ready."
+    }
+    method reconfig {} {
+    }
+    method close {} {
+	global tkinspect
+	after 0 destroy $self
+	if {[incr tkinspect(main_window_count) -1] == 0} tkinspect_exit
+    }
+    method set_target {target} {
+	set slot(target) $target
+	$self update_lists
+	$self status "Remote interpreter is \"$target\""
+	wm title $self "Tkinspect: $target"
+    }
+    method update_lists {} {
+	foreach list $slot(lists) {
+	    $list update $slot(target)
+	}
+    }
+    method change_window_info_type {} {
+	foreach list $slot(lists) {
+	    if {[$list cget -class] == "Windows_list"} {
+		$list set_mode $slot(window_info_type)
+	    }
+	}
+    }
+    method list_item_click {list item} {
+	$self.value set_value "[$list get_item_name] $item" \
+	    [$list retrieve $slot(target) $item]
+	$self.value set_send_filter [list $list send_filter]
+    }
+    method fill_interp_menu {} {
+	set m $self.menu.file.m.interps
+	catch {$m delete 0 last}
+	foreach interp [winfo interps] {
+	    $m add command -label $interp \
+		-command [list $self set_target $interp]
+	}
+    }
+    method status {msg} {
+	$self.status.l config -text $msg
+    }
+    method target {} {
+	return $slot(target)
+    }
+}
+
+proc create_main_window {} {
+    global tkinspect
+    tkinspect_main .main[incr tkinspect(counter)]
+    incr tkinspect(main_window_count)
+}
+
+widgets_init
+tkinspect_widgets_init
+tkinspect_default_options
+if [file exists ~/.tkinspect_opts] {
+    source ~/.tkinspect_opts
+}
+create_main_window
diff --git a/value.tcl b/value.tcl
new file mode 100644
index 0000000..1a49256
--- /dev/null
+++ b/value.tcl
@@ -0,0 +1,38 @@
+#
+# $Id$
+#
+
+widget value {
+    param width 80
+    param height 20
+    param main
+    method create {} {
+	$self config -bd 2 -relief raised -highlightthickness 0
+	pack [frame $self.title] -side top -fill x
+	pack [label $self.title.l -text "Value:  "] -side left
+	label $self.title.vname -anchor w \
+	    -textvariable [object_slotname value_name]
+	pack $self.title.vname -fill x
+	scrollbar $self.sb -relief sunken -bd 1 -command "$self.t yview"
+	text $self.t -yscroll "$self.sb set"
+	pack $self.sb -side right -fill y
+	pack $self.t -side right -fill both -expand 1
+	bind $self.t <Control-x><Control-s> "$self send_value"
+    }
+    method reconfig {} {
+	$self.t config -width $slot(width) -height $slot(height)
+    }
+    method set_value {name value} {
+	$self.t delete 1.0 end
+	$self.t insert 1.0 $value
+	set slot(value_name) $name
+    }
+    method set_send_filter {command} {
+	set slot(send_filter) $command
+    }
+    method send_value {} {
+	send [$slot(main) target] \
+	    [eval $slot(send_filter) [list [$self.t get 1.0 end]]]
+	$slot(main) status "Value sent"
+    }
+}