# $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
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
}
}
projects / tkinspect / commitdiff