From: sls <sls>
Date: Tue, 7 Feb 1995 08:27:26 +0000 (+0000)
Subject: Move implementation of various lists to separate files.  Implement
X-Git-Tag: r5_1_1~72
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=c1da7a252fc23cb33eb1729e42af84574592bbae;p=tkinspect

Move implementation of various lists to separate files.  Implement
filter editing.  Add menus.  Move menu defs that were in tkinspect.tcl
to here.
---

diff --git a/lists.tcl b/lists.tcl
index 483d3e7..578f7da 100644
--- a/lists.tcl
+++ b/lists.tcl
@@ -2,12 +2,83 @@
 # $Id$
 #
 
-widget clickable_list {
+dialog filter_editor {
+    param list
+    member patterns
+    member filter_type exclude
+    method create {} {
+        frame $self.top
+        label $self.l -text "Pattern:"
+        entry $self.e -width 40 -relief sunken
+        pack $self.l -in $self.top -side left
+        pack $self.e -in $self.top -side left -fill x
+        pack $self.top -side top -fill x -pady .25c
+        frame $self.buttons -bd 3
+        button $self.ok -text "Apply" -command "$self apply"
+        button $self.close -text "Close" -command "wm withdraw $self"
+        button $self.add -text "Add Pattern" \
+	    -command "$self add_pattern"
+        button $self.del -text "Delete Pattern(s)" \
+	    -command "$self delete_patterns"
+        radiobutton $self.inc -variable [object_slotname filter_type] \
+	    -value include -relief flat -text "Include Patterns"
+        radiobutton $self.exc -variable [object_slotname filter_type] \
+	    -value exclude -relief flat -text "Exclude Patterns"
+        pack $self.inc $self.exc $self.add $self.del -in $self.buttons \
+	    -side top -fill x -pady .1c -anchor w
+        pack $self.close $self.ok -in $self.buttons \
+	    -side bottom -fill x -pady .1c
+        pack $self.buttons -in $self -side left -fill y
+        frame $self.lframe
+        scrollbar $self.sb -command "$self.list yview"
+        listbox $self.list -yscroll "$self.sb set" -relief raised \
+            -width 40 -height 10 -selectmode multiple
+        pack $self.sb -in $self.lframe -side right -fill y
+        pack $self.list -in $self.lframe -side right -fill both -expand yes
+        pack $self.lframe -in $self -side right -fill both -expand yes
+	set title "Edit [$slot(list) cget -title] Filter"
+	wm title $self $title
+	wm iconname $self $title
+	foreach pat [$slot(list) cget -patterns] {
+	    $self.list insert end $pat
+	    lappend slot(patterns) $pat
+	}
+    }
+    method reconfig {} {
+    }
+    method apply {} {
+	$slot(list) config -patterns $slot(patterns) \
+	    -filter_type $slot(filter_type)
+	$slot(list) update_needed
+    }
+    method add_pattern {} {
+	set pat [$self.e get]
+	if {[string length $pat]} {
+	    lappend slot(patterns) $pat
+	    $self.list insert end $pat
+	}
+    }
+    method delete_patterns {} {
+	while {[string length [set s [$self.list curselection]]]} {
+	    set pat [$self.list get [lindex $s 0]]
+	    set ndx [lsearch -exact $slot(patterns) $pat]
+	    set slot(patterns) [lreplace $slot(patterns) $ndx $ndx]
+	    $self.list delete [lindex $s 0]
+	}
+    }
+}
+
+widget tkinspect_list {
     param command {}
     param title {}
     param width 30
     param height 12
     param main
+    param patterns {}
+    param filter_type exclude
+    member current_item
+    member menu
+    member contents {}
     method create {} {
 	$self config -bd 2 -relief raised
 	pack [label $self.title -anchor w] -side top -fill x
@@ -17,181 +88,68 @@ widget clickable_list {
 	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
+	set slot(menu) [$slot(main) add_menu $slot(title)]
+	$slot(menu) add command -label "Edit Filter..." \
+	    -command "$self edit_filter"
+	$slot(menu) add command -label "Remove List" \
+	    -command "$self remove" -state disabled
     }
     method reconfig {} {
-	$self.title config -text $slot(title)
+	$self.title config -text "$slot(title):"
 	$self.list config -width $slot(width) -height $slot(height)
     }
-    method list args {
-	eval $self.list $args
+    method clear {} {
+	set slot(contents) ""
     }
-    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]
-	    }
-	}
+    method append {item} {
+	lappend slot(contents) $item
+	$self update_needed
     }
-}
-
-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 update_needed {} {
+	if ![info exists slot(update_pending)] {
+	    set slot(update_pending) 1
+	    after 0 $self do_update
+	}	
     }
-    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
+    method do_update {} {
+	unset slot(update_pending)
+	$self.list delete 0 end
+	if {$slot(filter_type) == "exclude"} {
+	    set x 1
+	} else {
+	    set x 0
+	}
+	foreach item $slot(contents) {
+	    set include $x
+	    foreach pattern $slot(patterns) {
+		if [regexp -- $pattern $item] {
+		    set include [expr !$x]
+		    break
+		}
+	    }
+	    if $include {
+		$self.list insert end $item
 	    }
-	}
-	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} {
-	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]]"
+    method click {x y} {
+	if [string length $slot(command)] {
+	    set slot(current_item) [$self.list get @$x,$y]
+	    if [string length $slot(current_item)] {
+		uplevel #0 [concat $slot(command) $slot(current_item)]
+	    }
 	}
-	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 remove {} {
+	$slot(main) destroy_menu $slot(title)
+	object_delete $self
     }
-    method retrieve_packing {target window} {
-	set result "# packing info for $window\n"
-	if [catch {send $target pack info $window} info] {
-	    append result "# $info\n"
+    method edit_filter {} {
+	if [winfo exists $self.editor] {
+	    wm deiconify $self.editor
 	} 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(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
-	}
-	if [$slot(main) cget -filter_window_pack_in] {
-	    regsub -all "(\n)\[ \t\]*-in\[ \t\]+\[^ \\\n\]*\n?" $value \
-		"\\1" value
+	    filter_editor $self.editor -list $self
+	    center_window $self.editor
 	}
-	return $value
     }
 }