1## 2## megalist.tcl 3## 4## Copyright 1997-8 Jeffrey Hobbs 5## 6package require Widget 2.0 7package provide Megalist 1.0 8 9##------------------------------------------------------------------------ 10## PROCEDURE 11## megalist 12## 13## ARGUMENTS && DESCRIPTION 14## 15## megalist <window pathname> <options> 16## Implements a megalist which displays a sorted and filtered 17## list of lists. 18## 19## OPTIONS 20## 21## -sortby item DEFAULT: none 22## Specifies which item to sort on. 23## 24## -sort TCL_BOOLEAN DEFAULT: 1 25## If true the sort buttons appear and the lists are sorted 26## by the item specified by -sortby. If false the sort buttons 27## disappear and the lists are not sorted. 28## 29## 30## -showfilters TCL_BOOLEAN DEFAULT: 0 31## 32## -shownames TCL_BOOLEAN DEFAULT: 1 33## 34## METHODS 35## These are the methods that the megalist object recognizes. 36## (ie - megalist .m ; .m <method> <args>) 37## Any unique substring is acceptable 38## 39## load list 40## Each element in the list is displayed as a row in the widget. 41## Each element in the row is assigned to an item starting from the left. 42## If there are less item elements than items blanks are assigned. 43## If there are more item elements than items they are ignored. 44## 45## add item ?args? 46## Adds a display for the new item in the list. 47## 48## delete item ?item ...? 49## Deletes the item(s) and removes the display(s). 50## 51## itemconfigure item ?option? ?value option value ...? 52## Query or modify the configuration options of the item. 53## 54## itemcget item option 55## Returns the current value of the item's configuration option. 56## 57## names ?pattern? 58## Returns the item names that match pattern. Defaults to *. 59## 60## BINDINGS 61## 62## NAMESPACE & STATE 63## The megawidget creates a global array with the classname, and a 64## global array which is the name of each megawidget is created. The latter 65## array is deleted when the megawidget is destroyed. 66## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. 67## Other procs that begin with $CLASSNAME are private. For each widget, 68## commands named .$widgetname and $CLASSNAME$widgetname are created. 69## 70## 71##------------------------------------------------------------------------ 72## 73## 74 75# Create this to make sure there are registered in auto_mkindex 76# these must come before the [widget create ...] 77proc Megalist args {} 78proc megalist args {} 79 80widget create Megalist -type frame -base frame -components { 81 {frame hold hold {-height 200 -width 200 -bg pink}} 82 {scrollbar yscrollbar sy {-bd 1 -takefocus 0 -highlightthickness 0 \ 83 -orient v -command [namespace code [list lbset $w yview]]}} 84} -options { 85 {-sortby sortby SortBy {}} 86 {-sortcmd sortcmd SortCmd ::Widget::Megalist::sort} 87 {-shownames shownames ShowNames 1} 88 {-showfilters showfilters ShowFilters 0} 89 {-style style Style listbox} 90 {-font font Font fixed} 91 {-selectproc selectProc SelectProc {}} 92 {-dataproc dataProc DataProc {}} 93 {-filtercmd filtercmd FilterCmd ::Widget::Megalist::filter} 94} 95 96namespace eval ::Widget::Megalist {; 97 98;proc construct w { 99 upvar \#0 [namespace current]::$w data 100 101 ## Private variables 102 array set data [list \ 103 order {} \ 104 lists {} \ 105 count 0 \ 106 height 0 \ 107 reload {} \ 108 data {} \ 109 ] 110 111 grid $data(hold) $data(yscrollbar) -sticky news 112 grid config $data(yscrollbar) -sticky ns 113 grid columnconfig $w 0 -weight 1 114 grid rowconfig $w 0 -weight 1 115 116} 117 118;proc init w { 119} 120 121;proc destruct w { 122 upvar \#0 [namespace current]::$w data 123 catch {pane forget $data(hold)} 124} 125 126;proc configure {w args} { 127 upvar \#0 [namespace current]::$w data 128 129 set truth {^(1|yes|true|on)$} 130 set reload 0 131 foreach {key val} $args { 132 switch -- $key { 133 -sortby { 134 if {[llength $val]>1} { 135 return -code error "multiple sort fields not supported" 136 } 137 if {![string compare $val $data(-sortby)]} continue 138 foreach v $val { 139 if {[lsearch $data(order) $v] == -1} { 140 return -code error "unrecognized field \"$name\"" 141 } 142 } 143 if {[info exists set($v)]} { 144 return -code error "field \"$name\" set twice" 145 } 146 set set($v) 0 147 set reload 1 148 } 149 150 -showfilters { 151 set val [regexp -nocase $truth $val] 152 if {$data(-showfilters) == $val} continue 153 if $data(-showfilters) { 154 foreach name $data(order) { 155 pack forget $data(hold).$name.e 156 } 157 } else { 158 foreach name $data(order) { 159 pack $data(hold).$name.e -fill x \ 160 -before $data(hold).$name.c 161 } 162 } 163 } 164 -shownames { 165 set val [regexp -nocase $truth $val] 166 if { $data(-shownames) == $val } {continue} 167 if $data(-shownames) { 168 foreach name $data(order) { 169 pack forget $data(hold).$name.b 170 } 171 } else { 172 set x c 173 if [winfo exists $data(hold).$name.e] { 174 set x e 175 } 176 foreach name $data(order) { 177 pack $data(hold).$name.b -fill x \ 178 -before $data(hold).$name.$x 179 } 180 } 181 } 182 } 183 set data($key) $val 184 } 185 if {$reload} {_refresh $w} 186} 187 188;proc _load {w args} { 189 upvar \#0 [namespace current]::$w data 190 191 if {[string match {} $data(order)]} { 192 return -code error "no fields in megalist" 193 } 194 set data(data) $args 195 196 catch {$data(err) load $args} result 197 _refresh $w 198 199 return $result 200} 201 202#refresh or reload? 203;proc _refresh {w} { 204 upvar \#0 [namespace current]::$w data 205 after cancel $data(reload) 206 set data(reload) [after idle load $w] 207 return 208} 209 210;proc load {w} { 211 upvar \#0 [namespace current]::$w data 212 213 if {[string match {} $data(data)]} return 214 215 foreach name $data(order) { 216 set box $data(hold).$name.c 217 $box delete 0 end 218 eval $box insert end [$data(err) fldmsg $name] 219 } 220} 221 222;proc setsort {w b name} { 223 upvar \#0 [namespace current]::$w data 224 array set config $data(I:$name) 225 if {[string compare $name $data(-sortby)]} { 226 set data(-sortby) $name 227 set config(-order) increasing 228 } else { 229 if {[string compare increasing $config(-order)]} { 230 set config(-order) increasing 231 } else { 232 set config(-order) decreasing 233 } 234 } 235 set data(I:$name) [array get config] 236 _refresh $w 237} 238 239;proc _add {w name args} { 240 upvar \#0 [namespace current]::$w data 241 242 if {[info exists data(I:$name)]} { 243 # Ensure name doesn't already exist 244 return -code error "field \"$name\" already exists" 245 } 246 if {[regexp {(^[\.A-Z]|[ \.])} $name]} { 247 return -code error "invalid item name \"$name\": it cannot begin\ 248 with a capital letter, or contain spaces or \".\"" 249 } 250 if {[llength $args]&1} { 251 return -code error "wrong \# of args to add method \"$args\"" 252 } 253 254 get_opts2 config $args { 255 -filtertype match 256 -match * 257 -sort ascii 258 } 259 set data(I:$name) [array get config] 260 set data(IF:$name) $config(-match) 261 262 lappend data(order) $name 263 264 if {[catch {additem $w} result]} { 265 set data(order) [lreplace $data(order) end end] 266 unset data(I:$name) data(IF:$name) 267 return -code error $result 268 } 269 270 add $w $name 271 272 return $name 273} 274 275;proc additem {w args} { 276 upvar \#0 [namespace current]::$w data 277 278 foreach name $data(order) { 279 array set config $data(I:$name) 280 set field [list $name -sort $config(-sort)] 281 lappend fields $field 282 unset config 283 } 284} 285 286;proc add {w name} { 287 upvar \#0 [namespace current]::$w data 288 289 array set config $data(I:$name) 290 set f [frame $data(hold).$name] 291 button $f.b -text $name -bd 1 -highlightthickness 0 \ 292 -takefocus 0 -padx 6 -pady 2 \ 293 -command [namespace code [list setsort $w $f.b $name]] 294 entry $f.e -textvariable ${w}(IF:$name) -bd 1 \ 295 -highlightthickness 0 -takefocus 0 -justify center 296 set box [listbox $f.c -highlightthickness 0 -bd 0 -takefocus 0 \ 297 -yscrollcommand [namespace code [list scroll $w]] -exportsel 0] 298 $f.c xview moveto 0 299 if $data(-shownames) { pack $f.b -fill x} 300 if $data(-showfilters) {pack $f.e -fill x} 301 pack $f.c -fill both -expand 1 302 pane $f -parent $data(hold) -handlelook {-bd 1 -width 2} 303 304 bind $f.c <ButtonRelease-1> [namespace code [list select $w $f.c]] 305 bind $f.e <Return> [namespace code [list _refresh $w]] 306 307 set $data(IF:$name) $config(-match) 308} 309 310;proc select {w p} { 311 upvar \#0 [namespace current]::$w data 312 if [string match {} [set idx [$p curselection]]] {return} 313 foreach i $data(order) { 314 $w.hold.$i.c selection clear 0 end 315 $w.hold.$i.c selection set $idx 316 } 317 if {[string compare {} $data(-selectproc)]} { 318 foreach i $data(order) { 319 lappend select [$w.hold.$i.c get $idx] 320 } 321 ## No $select here! 322 if {[string compare {} $select]} { 323 eval $data(-selectproc) $w $select 324 } 325 } 326} 327 328;proc _delete {w args} { 329 upvar \#0 [namespace current]::$w data 330 331 foreach name $args { 332 ## Don't complain about unknown items when deleting 333 set wid $data(hold).$name 334 catch { 335 unset data(I:$name) data(IF:$name) 336 pane forget $data(hold) $wid 337 destroy $wid 338 } 339 if {[set i [lsearch -exact $data(order) $name]] != -1} { 340 set data(order) [lreplace $data(order) $i $i] 341 } 342 if {[set i [lsearch -exact $data(-sortby) $name]] != -1} { 343 set data(-sortby) [lreplace $data(-sortby) $i $i] 344 } 345 } 346} 347 348## _itemconfigure 349## configure a progressbar constituent item 350## 351;proc _itemconfigure {w name args} { 352 upvar \#0 [namespace current]::$w data 353 354 if {![info exists data(I:$name)]} { 355 return -code error "unknown field \"$name\"" 356 } 357 358 array set config $data(I:$name) 359 if {[catch {$data(err) field $name $args} result]} { 360 $data(err) field $name [array get config] 361 return -code error $result 362 } 363 364 if {[llength $args] > 1} { 365 array set config $args 366 set data(IF:$name) $config(match) 367 set data(I:$name) $args 368 _refresh $w 369 } 370 return $result 371} 372 373## _itemcget 374## Returns a single item option 375## 376;proc _itemcget {w name opt} { 377 upvar \#0 [namespace current]::$w data 378 379 if {![info exists data(I:$name)]} { 380 return -code error "unknown item \"$name\"" 381 } 382 array set config $data(I:$name) 383 ## Ensure that we are getting a -'ed value 384 if {![info exists config(-[string range $opt 1 end])]} { 385 return -code error "unknown option \"$opt\"" 386 } 387 return $config($opt) 388} 389 390## _names 391## Return a list of item names 392## 393;proc _names {w {pattern *}} { 394 upvar \#0 [namespace current]::$w data 395 396 set names {} 397 foreach name $data(order) { 398 if {[string match $pattern $name]} { 399 lappend names $name 400 } 401 } 402 return $names 403} 404 405;proc lbset {w args} { 406 upvar \#0 [namespace current]::$w data 407 408 foreach name $data(order) { 409 eval [list $data(hold).$name.c] $args 410 } 411} 412 413;proc scroll {w args} { 414 upvar \#0 [namespace current]::$w data 415 416 eval $data(yscrollbar) set $args 417 lbset $w yview moveto [lindex $args 0] 418} 419 420}; # end namespace ::Widget::Megalist 421