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