source: tol/tolbase/lib/toltk/mclistbox.tcl @ b83b8ed3

1941-docker-image-to-testdevel
Last change on this file since b83b8ed3 was 6d7779d, checked in by Jorge Pérez <josp.jorge@…>, 18 years ago

initial import

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@1 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 74.3 KB
Line 
1# Copyright (c) 1999, Bryan Oakley
2# All Rights Reservered
3#
4# Bryan Oakley
5# oakley@channelpoint.com
6#
7# mclistbox v1.02 March 30, 1999
8#
9# a multicolumn listbox written in pure tcl
10#
11# this code is freely distributable without restriction, but is
12# provided as-is with no waranty expressed or implied.
13#
14# basic usage:
15#   
16#    mclistbox::mclistbox .listbox
17#    .listbox column add col1 -label "Column 1"
18#    .listbox column add col2 -label "Column 2"
19#    .listbox insert end [list "some stuff" "some more stuff"]
20#    .listbox insert end [list "a second row of stuff" "blah blah blah"]
21#
22# see the documentation for more, uh, documentation.
23#
24# Something to think about: implement a "-optimize" option, with two
25# values: speed and memory. If set to speed, keep a copy of the data
26# in our hidden listbox so retrieval of data doesn't require us to
27# do all the getting and splitting and so forth. If set to "memory",
28# bag saving a duplicate copy of the data, which means data retrieval
29# will be slower, but memory requirements will be reduced.
30
31package require Tk 8.0
32package provide mclistbox 1.02
33
34namespace eval ::mclistbox {
35
36    # this is the public interface
37    namespace export mclistbox
38
39    # these contain references to available options
40    variable widgetOptions
41    variable columnOptions
42
43    # these contain references to available commands and subcommands
44    variable widgetCommands
45    variable columnCommands
46    variable labelCommands
47}
48
49# ::mclistbox::Init --
50#
51#     Initialize the global (well, namespace) variables. This should
52#     only be called once, immediately prior to creating the first
53#     instance of the widget
54#
55# Results:
56#
57#     All state variables are set to their default values; all of
58#     the option database entries will exist.
59#
60# Returns:
61#
62#     empty string
63
64proc ::mclistbox::Init {} {
65    variable widgetOptions
66    variable columnOptions
67    variable widgetCommands
68    variable columnCommands
69    variable labelCommands
70
71    # here we match up command line options with option database names
72    # and classes. As it turns out, this is a handy reference of all of the
73    # available options. Note that if an item has a value with only one
74    # item (like -bd, for example) it is a synonym and the value is the
75    # actual item.
76
77    array set widgetOptions [list \
78            -background          {background          Background} \
79            -bd                  -borderwidth \
80            -bg                  -background \
81            -borderwidth         {borderWidth         BorderWidth} \
82            -columnbd            -columnborderwidth \
83            -columnborderwidth   {columnBorderWidth   BorderWidth} \
84            -columnrelief        {columnRelief        Relief} \
85            -cursor              {cursor              Cursor} \
86            -exportselection     {exportSelection     ExportSelection} \
87            -fg                  -foreground \
88            -fillcolumn          {fillColumn          FillColumn} \
89            -font                {font                Font} \
90            -foreground          {foreground          Foreground} \
91            -height              {height              Height} \
92            -highlightbackground {highlightBackground HighlightBackground} \
93            -highlightcolor      {highlightColor      HighlightColor} \
94            -highlightthickness  {highlightThickness  HighlightThickness} \
95            -labelanchor         {labelAnchor         Anchor} \
96            -labelbackground     {labelBackground     Background} \
97            -labelbd             -labelborderwidth \
98            -labelbg             -labelbackground \
99            -labelborderwidth    {labelBorderWidth    BorderWidth} \
100            -labelfg             -labelforeground \
101            -labelfont           {labelFont           Font} \
102            -labelforeground     {labelForeground     Foreground} \
103            -labelheight         {labelHeight         Height} \
104            -labelimage          {labelImage          Image} \
105            -labelrelief         {labelRelief         Relief} \
106            -labels              {labels              Labels} \
107            -relief              {relief              Relief} \
108            -resizablecolumns    {resizableColumns    ResizableColumns} \
109            -selectbackground    {selectBackground    Foreground} \
110            -selectborderwidth   {selectBorderWidth   BorderWidth} \
111            -selectcommand       {selectCommand       Command} \
112            -selectforeground    {selectForeground    Background} \
113            -selectmode          {selectMode          SelectMode} \
114            -setgrid             {setGrid             SetGrid} \
115            -takefocus           {takeFocus           TakeFocus} \
116            -width               {width               Width} \
117            -xscrollcommand      {xScrollCommand      ScrollCommand} \
118            -yscrollcommand      {yScrollCommand      ScrollCommand} \
119            ]
120
121    # and likewise for column-specific stuff.
122    array set columnOptions [list \
123            -background         {background           Background} \
124            -bitmap             {bitmap               Bitmap} \
125            -font               {font                 Font} \
126            -foreground         {foreground           Foreground} \
127            -image              {image                Image} \
128            -label              {label                Label} \
129            -position           {position             Position} \
130            -resizable          {resizable            Resizable} \
131            -visible            {visible              Visible} \
132            -width              {width                Width} \
133            ]
134
135    # this defines the valid widget commands. It's important to
136    # list them here; we use this list to validate commands and
137    # expand abbreviations.
138    set widgetCommands [list \
139            activate     bbox       cget     column    configure  \
140            curselection delete     get      index     insert \
141            label        nearest    scan     see       selection  \
142            size         xview      yview
143    ]
144
145    set columnCommands [list add cget configure delete names nearest]
146    set labelCommands  [list bind]
147
148    ######################################################################
149    #- this initializes the option database. Kinda gross, but it works
150    #- (I think).
151    ######################################################################
152
153    set packages [package names]
154
155    # why check for the Tk package? This lets us be sourced into
156    # an interpreter that doesn't have Tk loaded, such as the slave
157    # interpreter used by pkg_mkIndex. In theory it should have no
158    # side effects when run
159    if {[lsearch -exact [package names] "Tk"] != -1} {
160
161        # compute a widget name we can use to create a temporary widget
162        set tmpWidget ".__tmp__"
163        set count 0
164        while {[winfo exists $tmpWidget] == 1} {
165            set tmpWidget ".__tmp__$count"
166            incr count
167        }
168
169        # steal options from the listbox
170        # we want darn near all options, so we'll go ahead and do
171        # them all. No harm done in adding the one or two that we
172        # don't use.
173        listbox $tmpWidget
174        foreach foo [$tmpWidget configure] {
175            if {[llength $foo] == 5} {
176                set option [lindex $foo 1]
177                set value [lindex $foo 4]
178                option add *Mclistbox.$option $value widgetDefault
179
180                # these options also apply to the individual columns...
181                if {[string compare $option "foreground"] == 0 \
182                        || [string compare $option "background"] == 0 \
183                        || [string compare $option "font"] == 0} {
184                    option add *Mclistbox*MclistboxColumn.$option $value \
185                            widgetDefault
186                }
187            }
188        }
189        destroy $tmpWidget
190
191        # steal some options from label widgets; we only want a subset
192        # so we'll use a slightly different method. No harm in *not*
193        # adding in the one or two that we don't use... :-)
194        label $tmpWidget
195        foreach option [list Anchor Background Font \
196                Foreground Height Image  ] {
197            set values [$tmpWidget configure -[string tolower $option]]
198            option add *Mclistbox.label$option [lindex $values 3]
199        }
200        destroy $tmpWidget
201
202        # these are unique to us...
203        option add *Mclistbox.columnBorderWidth   0      widgetDefault
204        option add *Mclistbox.columnRelief        flat   widgetDefault
205        option add *Mclistbox.labelBorderWidth    1      widgetDefault
206        option add *Mclistbox.labelRelief         raised widgetDefault
207        option add *Mclistbox.labels              1      widgetDefault
208        option add *Mclistbox.resizableColumns    1      widgetDefault
209        option add *Mclistbox.selectcommand       {}     widgetDefault
210        option add *Mclistbox.fillcolumn          {}     widgetDefault
211
212        # column options
213        option add *Mclistbox*MclistboxColumn.visible       1      widgetDefault
214        option add *Mclistbox*MclistboxColumn.resizable     1      widgetDefault
215        option add *Mclistbox*MclistboxColumn.position      end    widgetDefault
216        option add *Mclistbox*MclistboxColumn.label         ""     widgetDefault
217        option add *Mclistbox*MclistboxColumn.width         0      widgetDefault
218        option add *Mclistbox*MclistboxColumn.bitmap        ""     widgetDefault
219        option add *Mclistbox*MclistboxColumn.image         ""     widgetDefault
220    }
221
222    ######################################################################
223    # define the class bindings
224    ######################################################################
225   
226    SetClassBindings
227
228}
229
230# ::mclistbox::mclistbox --
231#
232#     This is the command that gets exported. It creates a new
233#     mclistbox widget.
234#
235# Arguments:
236#
237#     w        path of new widget to create
238#     args     additional option/value pairs (eg: -background white, etc.)
239#
240# Results:
241#
242#     It creates the widget and sets up all of the default bindings
243#
244# Returns:
245#
246#     The name of the newly create widget
247
248proc ::mclistbox::mclistbox {args} {
249    variable widgetOptions
250
251    # perform a one time initialization
252    if {![info exists widgetOptions]} {
253        Init
254    }
255
256    # make sure we at least have a widget name
257    if {[llength $args] == 0} {
258        error "wrong # args: should be \"mclistbox pathName ?options?\""
259    }
260
261    # ... and make sure a widget doesn't already exist by that name
262    if {[winfo exists [lindex $args 0]]} {
263        error "window name \"[lindex $args 0]\" already exists"
264    }
265
266    # and check that all of the args are valid
267    foreach {name value} [lrange $args 1 end] {
268        Canonize [lindex $args 0] option $name
269    }
270
271    # build it...
272    set w [eval Build $args]
273
274    # set some bindings...
275    SetBindings $w
276
277    # and we are done!
278    return $w
279}
280
281# ::mclistbox::Build --
282#
283#    This does all of the work necessary to create the basic
284#    mclistbox.
285#
286# Arguments:
287#
288#    w        widget name
289#    args     additional option/value pairs
290#
291# Results:
292#
293#    Creates a new widget with the given name. Also creates a new
294#    namespace patterened after the widget name, as a child namespace
295#    to ::mclistbox
296#
297# Returns:
298#
299#    the name of the widget
300
301proc ::mclistbox::Build {w args} {
302    variable widgetOptions
303
304    # create the namespace for this instance, and define a few
305    # variables
306    namespace eval ::mclistbox::$w {
307
308        variable options
309        variable widgets
310        variable misc
311    }
312
313    # this gives us access to the namespace variables within
314    # this proc
315    upvar ::mclistbox::${w}::widgets widgets
316    upvar ::mclistbox::${w}::options options
317    upvar ::mclistbox::${w}::misc    misc
318
319    # initially we start out with no columns
320    set misc(columns) {}
321
322    # this is our widget -- a frame of class Mclistbox. Naturally,
323    # it will contain other widgets. We create it here because
324    # we need it to be able to set our default options.
325    set widgets(this)   [frame  $w -class Mclistbox -takefocus 1]
326
327    # this defines all of the default options. We get the
328    # values from the option database. Note that if an array
329    # value is a list of length one it is an alias to another
330    # option, so we just ignore it
331    foreach name [array names widgetOptions] {
332        if {[llength $widgetOptions($name)] == 1} continue
333        set optName  [lindex $widgetOptions($name) 0]
334        set optClass [lindex $widgetOptions($name) 1]
335        set options($name) [option get $w $optName $optClass]
336    }
337
338    # now apply any of the options supplied on the command
339    # line. This may overwrite our defaults, which is OK
340    if {[llength $args] > 0} {
341        array set options $args
342    }
343   
344    # the columns all go into a text widget since it has the
345    # ability to scroll.
346    set widgets(text) [text $w.text \
347            -width 0 \
348            -height 0 \
349            -padx 0 \
350            -pady 0 \
351            -wrap none \
352            -borderwidth 0 \
353            -highlightthickness 0 \
354            -takefocus 0 \
355            -cursor {} \
356            ]
357
358    $widgets(text) configure -state disabled
359
360    # here's the tricky part (shhhh... don't tell anybody!)
361    # we are going to create column that completely fills
362    # the base frame. We will use it to control the sizing
363    # of the widget. The trick is, we'll pack it in the frame
364    # and then place the text widget over it so it is never
365    # seen.
366
367    set columnWidgets [NewColumn $w {__hidden__}]
368    set widgets(hiddenFrame)   [lindex $columnWidgets 0]
369    set widgets(hiddenListbox) [lindex $columnWidgets 1]
370    set widgets(hiddenLabel)   [lindex $columnWidgets 2]
371
372    # by default geometry propagation is turned off, but for this
373    # super-secret widget we want it turned on. The idea is, we
374    # resize the listbox which resizes the frame which resizes the
375    # whole shibang.
376    pack propagate $widgets(hiddenFrame) on
377
378    pack $widgets(hiddenFrame) -side top -fill both -expand y
379    place $widgets(text) -x 0 -y 0 -relwidth 1.0 -relheight 1.0
380    raise $widgets(text)
381
382    # we will later rename the frame's widget proc to be our
383    # own custom widget proc. We need to keep track of this
384    # new name, so we'll define and store it here...
385    set widgets(frame) ::mclistbox::${w}::$w
386
387    # this moves the original frame widget proc into our
388    # namespace and gives it a handy name
389    rename ::$w $widgets(frame)
390
391    # now, create our widget proc. Obviously (?) it goes in
392    # the global namespace. All mclistbox widgets will actually
393    # share the same widget proc to cut down on the amount of
394    # bloat.
395    proc ::$w {command args} \
396            "eval ::mclistbox::WidgetProc {$w} \$command \$args"
397
398    # ok, the thing exists... let's do a bit more configuration.
399    if {[catch "Configure $widgets(this) [array get options]" error]} {
400        catch {destroy $w}
401    }
402
403    # and be prepared to handle selections.. (this, for -exportselection
404    # support)
405    selection handle $w [list ::mclistbox::SelectionHandler $w get]
406
407    return $w
408}
409
410# ::mclistbox::SelectionHandler --
411#
412#    handle reqests to set or retrieve the primary selection. This is
413#    the "guts" of the implementation of the -exportselection option.
414#    What a pain! Note that this command is *not* called as a result
415#    of the widget's "selection" command, but rather as a result of
416#    the global selection being set or cleared.
417#
418#    If I read the ICCCM correctly (which is doubtful; who has time to
419#    read that thing thoroughly?), this should return each row as a tab
420#    separated list of values, and the whole as a newline separated
421#    list of rows.
422#
423# Arguments:
424#
425#    w       pathname of the widget
426#    type    one of "own", "lose" or "get"
427#    offset  only used if type is "get"; offset into the selection
428#            buffer where the returned data should begin
429#    length  number of bytes to return
430#
431
432proc ::mclistbox::SelectionHandler {w type {offset ""} {length ""}} {
433    upvar ::mclistbox::${w}::options   options
434    upvar ::mclistbox::${w}::misc      misc
435    upvar ::mclistbox::${w}::widgets   widgets
436
437    switch -exact $type {
438
439        own {
440            selection own \
441                    -command [list ::mclistbox::SelectionHandler $w lose] \
442                    -selection PRIMARY \
443                    $w
444        }
445
446        lose {
447            if {$options(-exportselection)} {
448                foreach id $misc(columns) {
449                    $widgets(listbox$id) selection clear 0 end
450                }
451            }
452        }
453
454        get {
455            set end [expr {$length + $offset - 1}]
456
457            set column [lindex $misc(columns) 0]
458            set curselection [$widgets(listbox$column) curselection]
459
460            # this is really, really slow (relatively speaking).
461            # but the only way I can think of to speed this up
462            # is to duplicate all the data in our hidden listbox,
463            # which I really don't want to do because of memory
464            # considerations.
465            set data ""
466            foreach index $curselection {
467                set rowdata [join [::mclistbox::WidgetProc-get $w $index]  "\t"]
468                lappend data $rowdata
469            }
470            set data [join $data "\n"]
471            return [string range $data $offset $end]
472        }
473
474    }
475}
476
477# ::mclistbox::convert --
478#
479#     public routine to convert %x, %y and %W binding substitutions.
480#     Given an x, y and or %W value relative to a given widget, this
481#     routine will convert the values to be relative to the mclistbox
482#     widget. For example, it could be used in a binding like this:
483#
484#     bind .mclistbox <blah> {doSomething [::mclistbox::convert %W -x %x]}
485#
486#     Note that this procedure is *not* exported, but is indented for
487#     public use. It is not exported because the name could easily
488#     clash with existing commands.
489#
490# Arguments:
491#
492#     w     a widget path; typically the actual result of a %W
493#           substitution in a binding. It should be either a
494#           mclistbox widget or one of its subwidgets
495#
496#     args  should one or more of the following arguments or
497#           pairs of arguments:
498#
499#           -x <x>      will convert the value <x>; typically <x> will
500#                       be the result of a %x substitution
501#           -y <y>      will convert the value <y>; typically <y> will
502#                       be the result of a %y substitution
503#           -W (or -w)  will return the name of the mclistbox widget
504#                       which is the parent of $w
505#
506# Returns:
507#
508#     a list of the requested values. For example, a single -w will
509#     result in a list of one items, the name of the mclistbox widget.
510#     Supplying "-x 10 -y 20 -W" (in any order) will return a list of
511#     three values: the converted x and y values, and the name of
512#     the mclistbox widget.
513
514proc ::mclistbox::convert {w args} {
515    set result {}
516    if {![winfo exists $w]} {
517        error "window \"$w\" doesn't exist"
518    }
519
520    while {[llength $args] > 0} {
521        set option [lindex $args 0]
522        set args [lrange $args 1 end]
523
524        switch -exact -- $option {
525            -x {
526                set value [lindex $args 0]
527                set args [lrange $args 1 end]
528                set win $w
529                while {[winfo class $win] != "Mclistbox"} {
530                    incr value [winfo x $win]
531                    set win [winfo parent $win]
532                    if {$win == "."} break
533                }
534                lappend result $value
535            }
536
537            -y {
538                set value [lindex $args 0]
539                set args [lrange $args 1 end]
540                set win $w
541                while {[winfo class $win] != "Mclistbox"} {
542                    incr value [winfo y $win]
543                    set win [winfo parent $win]
544                    if {$win == "."} break
545                }
546                lappend result $value
547            }
548
549            -w -
550            -W {
551                set win $w
552                while {[winfo class $win] != "Mclistbox"} {
553                    set win [winfo parent $win]
554                    if {$win == "."} break;
555                }
556                lappend result $win
557            }
558        }
559    }
560    return $result
561}
562
563# ::mclistbox::SetBindings --
564#
565#    Sets up the default bindings for the named widget
566#
567# Arguments:
568#
569#    w   the widget pathname for which the bindings should be assigned
570#
571# Results:
572#
573#    The named widget will inheirit all of the default Mclistbox
574#    bindings.
575
576proc ::mclistbox::SetBindings {w} {
577    upvar ::mclistbox::${w}::widgets widgets
578    upvar ::mclistbox::${w}::options options
579    upvar ::mclistbox::${w}::misc    misc
580
581    # we must do this so that the columns fill the text widget in
582    # the y direction
583    bind $widgets(text) <Configure> \
584            [list ::mclistbox::AdjustColumns $w %h]
585
586}
587
588# ::mclistbox::SetClassBindings --
589#
590#    Sets up the default bindings for the widget class
591#
592# Arguments:
593#
594#    none
595#
596
597proc ::mclistbox::SetClassBindings {} {
598    # this allows us to clean up some things when we go away
599    bind Mclistbox <Destroy> [list ::mclistbox::DestroyHandler %W]
600
601    # steal all of the standard listbox bindings. Note that if a user
602    # clicks in a column, %W will return that column. This is bad,
603    # so we have to make a substitution in all of the bindings to
604    # compute the real widget name (ie: the name of the topmost
605    # frame)
606    foreach event [bind Listbox] {
607        set binding [bind Listbox $event]
608        regsub -all {%W} $binding {[::mclistbox::convert %W -W]} binding
609        regsub -all {%x} $binding {[::mclistbox::convert %W -x %x]} binding
610        regsub -all {%y} $binding {[::mclistbox::convert %W -y %y]} binding
611        bind Mclistbox $event $binding
612    }
613
614    # these define bindings for the column labels for resizing. Note
615    # that we need both the name of this widget (calculated by $this)
616    # as well as the specific widget that the event occured over.
617    # Also note that $this is a constant string that gets evaluated
618    # when the binding fires.
619    # What a pain.
620    set this {[::mclistbox::convert %W -W]}
621    bind MclistboxMouseBindings <ButtonPress-1> \
622            "::mclistbox::ResizeEvent $this buttonpress %W %x %X %Y"
623    bind MclistboxMouseBindings <ButtonRelease-1> \
624            "::mclistbox::ResizeEvent $this buttonrelease %W %x %X %Y"
625    bind MclistboxMouseBindings <Enter> \
626            "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
627    bind MclistboxMouseBindings <Motion> \
628            "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
629    bind MclistboxMouseBindings <B1-Motion> \
630            "::mclistbox::ResizeEvent $this drag %W %x %X %Y"
631}
632
633# ::mclistbox::NewColumn --
634#
635#    Adds a new column to the mclistbox widget
636#
637# Arguments:
638#
639#    w     the widget pathname
640#    id    the id for the new column
641#
642# Results:
643#
644#    Creates a set of widgets which defines the column. Adds
645#    appropriate entries to the global array widgets for the
646#    new column.
647#
648#    Note that this column is not added to the listbox by
649#    this proc.
650#
651# Returns:
652#
653#    A list of three elements: the path to the column frame,
654#    the path to the column listbox, and the path to the column
655#    label, in that order.
656
657proc ::mclistbox::NewColumn {w id} {
658    upvar ::mclistbox::${w}::widgets   widgets
659    upvar ::mclistbox::${w}::options   options
660    upvar ::mclistbox::${w}::misc      misc
661    upvar ::mclistbox::${w}::columnID  columnID
662
663    # the columns are all children of the text widget we created...
664    set frame     \
665            [frame $w.frame$id \
666            -takefocus 0 \
667            -highlightthickness 0 \
668            -class MclistboxColumn \
669            -background $options(-background) \
670            ]
671
672    set listbox   \
673            [listbox $frame.listbox \
674            -takefocus 0 \
675            -bd 0 \
676            -setgrid $options(-setgrid) \
677            -exportselection false \
678            -selectmode $options(-selectmode) \
679            -highlightthickness 0 \
680            ]
681
682    set label     \
683            [label $frame.label \
684            -takefocus 0 \
685            -relief raised \
686            -bd 1 \
687            -highlightthickness 0 \
688            ]
689
690    # define mappings from widgets to columns
691    set columnID($label) $id
692    set columnID($frame) $id
693    set columnID($listbox) $id
694
695    # we're going to associate a new bindtag for the label to
696    # handle our resize bindings. Why? We want the bindings to
697    # be specific to this widget but we don't want to use the
698    # widget name. If we use the widget name then the bindings
699    # could get mixed up with user-supplied bindigs (via the
700    # "label bind" command).
701    set tag MclistboxLabel
702    bindtags $label  [list MclistboxMouseBindings $label]
703
704    # reconfigure the label based on global options
705    foreach option [list bd image height relief font anchor \
706            background foreground borderwidth] {
707        if {[info exists options(-label$option)] \
708                && $options(-label$option) != ""} {
709            $label configure -$option $options(-label$option)
710        }
711    }
712
713    # reconfigure the column based on global options
714    foreach option [list borderwidth relief] {
715        if {[info exists options(-column$option)] \
716                && $options(-column$option) != ""} {
717            $frame configure -$option $options(-column$option)
718        }
719    }
720
721    # geometry propagation must be off so we can control the size
722    # of the listbox by setting the size of the containing frame
723    pack propagate $frame off
724
725    pack $label   -side top -fill x -expand n
726    pack $listbox -side top -fill both -expand y -pady 2
727
728    # any events that happen in the listbox gets handled by the class
729    # bindings. This has the unfortunate side effect
730    bindtags $listbox [list $w Mclistbox all]
731
732    # return a list of the widgets we created.
733    return [list $frame $listbox $label]
734}
735
736# ::mclistbox::Column-add --
737#
738#    Implements the "column add" widget command
739#
740# Arguments:
741#
742#    w      the widget pathname
743#    args   additional option/value pairs which define the column
744#
745# Results:
746#
747#    A column gets created and added to the listbox
748
749proc ::mclistbox::Column-add {w args} {
750    upvar ::mclistbox::${w}::widgets widgets
751    upvar ::mclistbox::${w}::options options
752    upvar ::mclistbox::${w}::misc    misc
753
754    variable widgetOptions
755
756    set id "column-[llength $misc(columns)]" ;# a suitable default
757
758    # if the first argument doesn't have a "-" as the first
759    # character, it is an id to associate with this column
760    if {![string match {-*} [lindex $args 0]]} {
761        # the first arg must be an id.
762        set id [lindex $args 0]
763        set args [lrange $args 1 end]
764        if {[lsearch -exact $misc(columns) $id] != -1} {
765            error "column \"$id\" already exists"
766        }
767    }
768
769    # define some reasonable defaults, then add any specific
770    # values supplied by the user
771    set opts(-bitmap)     {}
772    set opts(-image)      {}
773    set opts(-visible)    1
774    set opts(-resizable)  1
775    set opts(-position)   "end"
776    set opts(-width)      20
777    set opts(-background) $options(-background)
778    set opts(-foreground) $options(-foreground)
779    set opts(-font)       $options(-font)
780    set opts(-label)      $id
781
782    if {[expr {[llength $args]%2}] == 1} {
783        # hmmm. An odd number of elements in args
784        # if the last item is a valid option we'll give a different
785        # error than if its not
786        set option [::mclistbox::Canonize $w "column option" [lindex $args end]]
787        error "value for \"[lindex $args end]\" missing"
788    }
789    array set opts $args
790
791    # figure out if we have any data in the listbox yet; we'll need
792    # this information in a minute...
793    if {[llength $misc(columns)] > 0} {
794        set col0 [lindex $misc(columns) 0]
795        set existingRows [$widgets(listbox$col0) size]
796    } else {
797        set existingRows 0
798    }
799
800    # create the widget and assign the associated paths to our array
801    set widgetlist [NewColumn $w $id]
802
803    set widgets(frame$id)   [lindex $widgetlist 0]
804    set widgets(listbox$id) [lindex $widgetlist 1]
805    set widgets(label$id)   [lindex $widgetlist 2]
806   
807    # add this column to the list of known columns
808    lappend misc(columns) $id
809
810    # configure the options. As a side effect, it will be inserted
811    # in the text widget
812    eval ::mclistbox::Column-configure {$w} {$id} [array get opts]
813
814    # now, if there is any data already in the listbox, we need to
815    # add a corresponding number of blank items. At least, I *think*
816    # that's the right thing to do.
817    if {$existingRows > 0} {
818        set blanks {}
819        for {set i 0} {$i < $existingRows} {incr i} {
820            lappend blanks {}
821        }
822        eval {$widgets(listbox$id)} insert end $blanks
823    }
824
825    InvalidateScrollbars $w
826    return $id
827}
828
829# ::mclistbox::Column-configure --
830#
831#    Implements the "column configure" widget command
832#
833# Arguments:
834#
835#    w     widget pathname
836#    id    column identifier
837#    args  list of option/value pairs
838
839proc ::mclistbox::Column-configure {w id args} {
840    variable widgetOptions
841    variable columnOptions
842
843    upvar ::mclistbox::${w}::widgets widgets
844    upvar ::mclistbox::${w}::options options
845    upvar ::mclistbox::${w}::misc    misc
846
847    # bail if they gave us a bogus id
848    set index [CheckColumnID $w $id]
849
850    # define some shorthand
851    set listbox $widgets(listbox$id)
852    set frame   $widgets(frame$id)
853    set label   $widgets(label$id)
854
855    if {[llength $args] == 0} {
856        # hmmm. User must be wanting all configuration information
857        # note that if the value of an array element is of length
858        # one it is an alias, which needs to be handled slightly
859        # differently
860        set results {}
861        foreach opt [lsort [array names columnOptions]] {
862            if {[llength $columnOptions($opt)] == 1} {
863                set alias $columnOptions($opt)
864                set optName $columnOptions($alias)
865                lappend results [list $opt $optName]
866            } else {
867                set optName  [lindex $columnOptions($opt) 0]
868                set optClass [lindex $columnOptions($opt) 1]
869                set default [option get $frame $optName $optClass]
870                lappend results [list $opt $optName $optClass \
871                        $default $options($id:$opt)]
872            }
873        }
874
875        return $results
876
877
878    } elseif {[llength $args] == 1} {
879
880        # the user must be querying something... I need to get this
881        # to return a bona fide list like the "real" configure
882        # command, but it's not a priority at the moment. I still
883        # have to work on the option database support foo.
884        set option [::mclistbox::Canonize $w "column option" [lindex $args 0]]
885
886        set value $options($id:$option)
887        set optName  [lindex $columnOptions($option) 0]
888        set optClass [lindex $columnOptions($option) 1]
889        set default  [option get $frame $optName $optClass]
890        set results  [list $option $optName $optClass $default $value]
891        return $results
892
893    }
894
895    # if we have an odd number of values, bail.
896    if {[expr {[llength $args]%2}] == 1} {
897        # hmmm. An odd number of elements in args
898        error "value for \"[lindex $args end]\" missing"
899    }
900   
901    # Great. An even number of options. Let's make sure they
902    # are all valid before we do anything. Note that Canonize
903    # will generate an error if it finds a bogus option; otherwise
904    # it returns the canonical option name
905    foreach {name value} $args {
906        set name [::mclistbox::Canonize $w "column option" $name]
907        set opts($name) $value
908    }
909
910    # if we get to here, the user is wanting to set some options
911    foreach option [array names opts] {
912        set value $opts($option)
913        set options($id:$option) $value
914
915        switch -- $option {
916            -label {
917                $label configure -text $value
918            }
919           
920            -image -
921            -bitmap {
922                $label configure $option $value
923            }
924
925            -width {
926                set font [$listbox cget -font]
927                set factor [font measure $options(-font) "0"]
928                set width [expr {$value * $factor}]
929
930                $widgets(frame$id) configure -width $width
931                set misc(min-$widgets(frame$id)) $width
932                AdjustColumns $w
933            }
934            -font -
935            -foreground -
936            -background {
937                if {[string length $value] == 0} {set value $options($option)}
938                $listbox configure $option $value
939            }
940
941            -resizable {
942                if {[catch {
943                    if {$value} {
944                        set options($id:-resizable) 1
945                    } else {
946                        set options($id:-resizable) 0
947                    }
948                } msg]} {
949                    error "expected boolean but got \"$value\""
950                }
951            }
952
953            -visible {
954                if {[catch {
955                    if {$value} {
956                        set options($id:-visible) 1
957                        $widgets(text) configure -state normal
958                        $widgets(text) window configure 1.$index -window $frame
959                        $widgets(text) configure -state disabled
960
961                    } else {
962                        set options($id:-visible) 0
963                        $widgets(text) configure -state normal
964                        $widgets(text) window configure 1.$index -window {}
965                        $widgets(text) configure -state disabled
966                    }
967                    InvalidateScrollbars $w
968                } msg]} {
969                    error "expected boolean but got \"$value\""
970                }
971
972            }
973
974            -position {
975                if {[string compare $value "start"] == 0} {
976                    set position 0
977
978                } elseif {[string compare $value "end"] == 0} {
979
980                    set position [expr {[llength $misc(columns)] -1}]
981                } else {
982
983                    # ought to check for a legal value here, but I'm
984                    # lazy
985                    set position $value
986                }
987
988                if {$position >= [llength $misc(columns)]} {
989                    set max [expr {[llength $misc(columns)] -1}]
990                    error "bad position; must be in the range of 0-$max"
991                }
992
993                # rearrange misc(columns) to reflect the new ordering
994                set current [lsearch -exact $misc(columns) $id]
995                set misc(columns) [lreplace $misc(columns) $current $current]
996                set misc(columns) [linsert $misc(columns) $position $id]
997               
998                set frame $widgets(frame$id)
999                $widgets(text) configure -state normal
1000                $widgets(text) window create 1.$position \
1001                        -window $frame -stretch 1
1002                $widgets(text) configure -state disabled
1003            }
1004
1005        }
1006    }
1007}
1008
1009
1010# ::mclistbox::DestroyHandler {w} --
1011#
1012#    Cleans up after a mclistbox widget is destroyed
1013#
1014# Arguments:
1015#
1016#    w    widget pathname
1017#
1018# Results:
1019#
1020#    The namespace that was created for the widget is deleted,
1021#    and the widget proc is removed.
1022
1023proc ::mclistbox::DestroyHandler {w} {
1024
1025    # kill off any idle event we might have pending
1026    if {[info exists ::mclistbox::${w}::misc(afterid)]} {
1027        catch {
1028            after cancel $::mclistbox::${w}::misc(afterid)
1029            unset ::mclistbox::${w}::misc(afterid)
1030        }
1031    }
1032
1033    # if the widget actually being destroyed is of class Mclistbox,
1034    # crush the namespace and kill the proc. Get it? Crush. Kill.
1035    # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
1036    # brings tears to my eyes.
1037    if {[string compare [winfo class $w] "Mclistbox"] == 0} {
1038        namespace delete ::mclistbox::$w
1039        rename $w {}
1040    }
1041
1042}
1043
1044# ::mclistbox::MassageIndex --
1045#
1046#    this proc massages indicies of the form @x,y such that
1047#    the coordinates are relative to the first listbox rather
1048#    than relative to the topmost frame.
1049#
1050# Arguments:
1051#
1052#    w       widget pathname
1053#    index   an index of the form @x,y
1054#
1055# Results:
1056#
1057#    Returns a new index with translated coordinates. This index
1058#    may be used directly by an internal listbox.
1059
1060proc ::mclistbox::MassageIndex {w index} {
1061    upvar ::mclistbox::${w}::widgets   widgets
1062    upvar ::mclistbox::${w}::misc      misc
1063
1064    if {[regexp {@([0-9]+),([0-9]+)} $index matchvar x y]} {
1065        set id [lindex $misc(columns) 0]
1066       
1067        incr y -[winfo y $widgets(listbox$id)]
1068        incr y -[winfo y $widgets(frame$id)]
1069        incr x [winfo x $widgets(listbox$id)]
1070        incr x [winfo x $widgets(frame$id)]
1071
1072        set index @${x},${y}
1073    }
1074
1075    return $index
1076}
1077
1078# ::mclistbox::WidgetProc --
1079#
1080#    This gets uses as the widgetproc for an mclistbox widget.
1081#    Notice where the widget is created and you'll see that the
1082#    actual widget proc merely evals this proc with all of the
1083#    arguments intact.
1084#
1085#    Note that some widget commands are defined "inline" (ie:
1086#    within this proc), and some do most of their work in
1087#    separate procs. This is merely because sometimes it was
1088#    easier to do it one way or the other.
1089#
1090# Arguments:
1091#
1092#    w         widget pathname
1093#    command   widget subcommand
1094#    args      additional arguments; varies with the subcommand
1095#
1096# Results:
1097#
1098#    Performs the requested widget command
1099
1100proc ::mclistbox::WidgetProc {w command args} {
1101    variable widgetOptions
1102
1103    upvar ::mclistbox::${w}::widgets   widgets
1104    upvar ::mclistbox::${w}::options   options
1105    upvar ::mclistbox::${w}::misc      misc
1106    upvar ::mclistbox::${w}::columnID  columnID
1107
1108    set command [::mclistbox::Canonize $w command $command]
1109
1110    # some commands have subcommands. We'll check for that here
1111    # and mung the command and args so that we can treat them as
1112    # distinct commands in the following switch statement
1113    if {[string compare $command "column"] == 0} {
1114        set subcommand [::mclistbox::Canonize $w "column command" \
1115                [lindex $args 0]]
1116        set command "$command-$subcommand"
1117        set args [lrange $args 1 end]
1118
1119    } elseif {[string compare $command "label"] == 0} {
1120        set subcommand [::mclistbox::Canonize $w "label command" \
1121                [lindex $args 0]]
1122        set command "$command-$subcommand"
1123        set args [lrange $args 1 end]
1124    }
1125
1126    set result ""
1127    catch {unset priorSelection}
1128
1129    # here we go. Error checking be damned!
1130    switch $command {
1131        xview {
1132            # note that at present, "xview <index>" is broken. I'm
1133            # not even sure how to do it. Unless I attach our hidden
1134            # listbox to the scrollbar and use it. Hmmm..... I'll
1135            # try that later. (FIXME)
1136            set result [eval {$widgets(text)} xview $args]
1137            InvalidateScrollbars $w
1138        }
1139
1140        yview {
1141            if {[llength $args] == 0} {
1142                # length of zero means to fetch the yview; we can
1143                # get this from a single listbox
1144                set result [$widgets(hiddenListbox) yview]
1145
1146            } else {
1147
1148                # if it's one argument, it's an index. We'll pass that
1149                # index through the index command to properly translate
1150                # @x,y indicies, and place the value back in args
1151                if {[llength $args] == 1} {
1152                    set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1153                    set args [list $index]
1154                }
1155
1156                # run the yview command on every column.
1157                foreach id $misc(columns) {
1158                    eval {$widgets(listbox$id)} yview $args
1159                }
1160                eval {$widgets(hiddenListbox)} yview $args
1161
1162                InvalidateScrollbars $w
1163
1164                set result ""
1165            }
1166        }
1167
1168        activate {
1169            if {[llength $args] != 1} {
1170                error "wrong \# of args: should be $w activate index"
1171            }
1172            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1173
1174            foreach id $misc(columns) {
1175                $widgets(listbox$id) activate $index
1176            }
1177            set result ""
1178        }
1179
1180        bbox {
1181            if {[llength $args] != 1} {
1182                error "wrong \# of args: should be $w bbox index"
1183            }
1184            # get a real index. This will adjust @x,y indicies
1185            # to account for the label, if any.
1186            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1187
1188            set id [lindex $misc(columns) 0]
1189
1190            # we can get the x, y, and height from the first
1191            # column.
1192            set bbox [$widgets(listbox$id) bbox $index]
1193            if {[string length $bbox] == 0} {return ""}
1194
1195            foreach {x y w h} $bbox {}
1196           
1197            # the x and y coordinates have to be adjusted for the
1198            # fact that the listbox is inside a frame, and the
1199            # frame is inside a text widget. All of those add tiny
1200            # offsets. Feh.
1201            incr y [winfo y $widgets(listbox$id)]
1202            incr y [winfo y $widgets(frame$id)]
1203            incr x [winfo x $widgets(listbox$id)]
1204            incr x [winfo x $widgets(frame$id)]
1205
1206            # we can get the width by looking at the relative x
1207            # coordinate of the right edge of the last column
1208            set id [lindex $misc(columns) end]
1209            set w [expr {[winfo width $widgets(frame$id)] + \
1210                    [winfo x $widgets(frame$id)]}]
1211            set bbox [list $x $y [expr {$x + $w}] $h]
1212            set result $bbox
1213        }
1214
1215        label-bind {
1216            # we are just too clever for our own good. (that's a
1217            # polite way of saying this is more complex than it
1218            # needs to be)
1219
1220            set id [lindex $args 0]
1221            set index [CheckColumnID $w $id]
1222
1223            set args [lrange $args 1 end]
1224            if {[llength $args] == 0} {
1225                set result [bind $widgets(label$id)]
1226            } else {
1227
1228                # when we create a binding, we'll actually have the
1229                # binding run our own command with the user's command
1230                # as an argument. This way we can do some sanity checks
1231                # before running the command. So, when querying a binding
1232                # we need to only return the user's code
1233                set sequence [lindex $args 0]
1234                if {[llength $args] == 1} {
1235                    set result [lindex [bind $widgets(label$id) $sequence] end]
1236                } else {
1237               
1238                    # replace %W with our toplevel frame, then
1239                    # do the binding
1240                    set code [lindex $args 1]
1241                    regsub -all {%W} $code $w code
1242                   
1243                    set result [bind $widgets(label$id) $sequence \
1244                            [list ::mclistbox::LabelEvent $w $id $code]]
1245                }
1246            }
1247        }
1248
1249        column-add {
1250            eval ::mclistbox::Column-add {$w} $args
1251            AdjustColumns $w
1252            set result ""
1253        }
1254
1255        column-delete {
1256            foreach id $args {
1257                set index [CheckColumnID $w $id]
1258
1259                # remove the reference from our list of columns
1260                set misc(columns) [lreplace $misc(columns) $index $index]
1261
1262                # whack the widget
1263                destroy $widgets(frame$id)
1264
1265                # clear out references to the individual widgets
1266                unset widgets(frame$id)
1267                unset widgets(listbox$id)
1268                unset widgets(label$id)
1269            }
1270            InvalidateScrollbars $w
1271            set result ""
1272        }
1273
1274        column-cget {
1275            if {[llength $args] != 2} {
1276                error "wrong # of args: should be \"$w column cget name option\""
1277            }
1278            set id [::mclistbox::Canonize $w column [lindex $args 0]]
1279            set option [lindex $args 1]
1280            set data [::mclistbox::Column-configure $w $id $option]
1281            set result [lindex $data 4]
1282        }
1283
1284        column-configure {
1285            set id [::mclistbox::Canonize $w column [lindex $args 0]]
1286            set args [lrange $args 1 end]
1287            set result [eval ::mclistbox::Column-configure {$w} {$id} $args]
1288        }
1289
1290        column-names {
1291            if {[llength $args] != 0} {
1292                error "wrong # of args: should be \"$w column names\""
1293            }
1294            set result $misc(columns)
1295        }
1296
1297        column-nearest {
1298            if {[llength $args] != 1} {
1299                error "wrong # of args: should be \"$w column nearest x\""
1300            }
1301
1302            set x [lindex $args 0]
1303            set tmp [$widgets(text) index @$x,0]
1304            set tmp [split $tmp "."]
1305            set index [lindex $tmp 1]
1306
1307            set result [lindex $misc(columns) $index]
1308        }
1309
1310        cget {
1311            if {[llength $args] != 1} {
1312                error "wrong # args: should be $w cget option"
1313            }
1314            set opt [::mclistbox::Canonize $w option [lindex $args 0]]
1315
1316            set result $options($opt)
1317        }
1318
1319
1320        configure {
1321            set result [eval ::mclistbox::Configure {$w} $args]
1322
1323        }
1324
1325        curselection {
1326            set id [lindex $misc(columns) 0]
1327            set result [$widgets(listbox$id) curselection]
1328        }
1329
1330        delete {
1331            if {[llength $args] < 1 || [llength $args] > 2} {
1332                error "wrong \# of args: should be $w delete first ?last?"
1333            }
1334
1335            # it's possible that the selection will change because
1336            # of something we do. So, grab the current selection before
1337            # we do anything. Just before returning we'll see if the
1338            # selection has changed. If so, we'll call our selectcommand
1339            if {$options(-selectcommand) != ""} {
1340                set col0 [lindex $misc(columns) 0]
1341                set priorSelection [$widgets(listbox$col0) curselection]
1342            }
1343
1344            set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
1345            if {[llength $args] == 2} {
1346                set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
1347            } else {
1348                set index2 ""
1349            }
1350
1351            # note we do an eval here to make index2 "disappear" if it
1352            # is set to an empty string.
1353            foreach id $misc(columns) {
1354                eval {$widgets(listbox$id)} delete $index1 $index2
1355            }
1356            eval {$widgets(hiddenListbox)} delete $index1 $index2
1357
1358            InvalidateScrollbars $w
1359
1360            set result ""
1361        }
1362
1363        get {
1364            if {[llength $args] < 1 || [llength $args] > 2} {
1365                error "wrong \# of args: should be $w get first ?last?"
1366            }
1367            set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
1368            if {[llength $args] == 2} {
1369                set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
1370            } else {
1371                set index2 ""
1372            }
1373
1374            set result [eval ::mclistbox::WidgetProc-get {$w} $index1 $index2]
1375
1376        }
1377
1378        index {
1379
1380            if {[llength $args] != 1} {
1381                error "wrong \# of args: should be $w index index"
1382            }
1383
1384            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1385            set id [lindex $misc(columns) 0]
1386
1387            set result [$widgets(listbox$id) index $index]
1388        }
1389
1390        insert {
1391            if {[llength $args] < 1} {
1392                error "wrong \# of args: should be $w insert ?element \
1393                      element...?"
1394            }
1395
1396            # it's possible that the selection will change because
1397            # of something we do. So, grab the current selection before
1398            # we do anything. Just before returning we'll see if the
1399            # selection has changed. If so, we'll call our selectcommand
1400            if {$options(-selectcommand) != ""} {
1401                set col0 [lindex $misc(columns) 0]
1402                set priorSelection [$widgets(listbox$col0) curselection]
1403            }
1404
1405            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1406
1407            ::mclistbox::Insert $w $index [lrange $args 1 end]
1408
1409            InvalidateScrollbars $w
1410            set result ""
1411        }
1412
1413        nearest {
1414            if {[llength $args] != 1} {
1415                error "wrong \# of args: should be $w nearest y"
1416            }
1417
1418            # translate the y coordinate into listbox space
1419            set id [lindex $misc(columns) 0]
1420            set y [lindex $args 0]
1421            incr y -[winfo y $widgets(listbox$id)]
1422            incr y -[winfo y $widgets(frame$id)]
1423
1424            set col0 [lindex $misc(columns) 0]
1425
1426            set result [$widgets(listbox$col0) nearest $y]
1427        }
1428
1429        scan {
1430            foreach {subcommand x y} $args {}
1431            switch $subcommand {
1432                mark {
1433                    # we have to treat scrolling in x and y differently;
1434                    # scrolling in the y direction affects listboxes and
1435                    # scrolling in the x direction affects the text widget.
1436                    # to facilitate that, we need to keep a local copy
1437                    # of the scan mark.
1438                    set misc(scanmarkx) $x
1439                    set misc(scanmarky) $y
1440                   
1441                    # set the scan mark for each column
1442                    foreach id $misc(columns) {
1443                        $widgets(listbox$id) scan mark $x $y
1444                    }
1445
1446                    # we can't use the x coordinate given us, since it
1447                    # is relative to whatever column we are over. So,
1448                    # we'll just usr the results of [winfo pointerx].
1449                    $widgets(text) scan mark [winfo pointerx $w]  $y
1450                }
1451                dragto {
1452                    # we want the columns to only scan in the y direction,
1453                    # so we'll force the x componant to remain constant
1454                    foreach id $misc(columns) {
1455                        $widgets(listbox$id) scan dragto $misc(scanmarkx) $y
1456                    }
1457
1458                    # since the scan mark of the text widget was based
1459                    # on the pointer location, so must be the x
1460                    # coordinate to the dragto command. And since we
1461                    # want the text widget to only scan in the x
1462                    # direction, the y componant will remain constant
1463                    $widgets(text) scan dragto \
1464                            [winfo pointerx $w] $misc(scanmarky)
1465
1466                    # make sure the scrollbars reflect the changes.
1467                    InvalidateScrollbars $w
1468                }
1469
1470                set result ""
1471            }
1472        }
1473
1474        see {
1475            if {[llength $args] != 1} {
1476                error "wrong \# of args: should be $w see index"
1477            }
1478            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1479
1480            foreach id $misc(columns) {
1481                $widgets(listbox$id) see $index
1482            }
1483            InvalidateScrollbars $w
1484            set result {}
1485        }
1486
1487        selection {
1488            # it's possible that the selection will change because
1489            # of something we do. So, grab the current selection before
1490            # we do anything. Just before returning we'll see if the
1491            # selection has changed. If so, we'll call our selectcommand
1492            if {$options(-selectcommand) != ""} {
1493                set col0 [lindex $misc(columns) 0]
1494                set priorSelection [$widgets(listbox$col0) curselection]
1495            }
1496
1497            set subcommand [lindex $args 0]
1498            set args [lrange $args 1 end]
1499
1500            set prefix "wrong \# of args: should be $w"
1501            switch $subcommand {
1502                includes {
1503                    if {[llength $args] != 1} {
1504                        error "$prefix selection $subcommand index"
1505                    }
1506                    set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1507                    set id [lindex $misc(columns) 0]
1508                    set result [$widgets(listbox$id) selection includes $index]
1509                }
1510
1511                set {
1512                    switch [llength $args] {
1513                        1 {
1514                            set index1 [::mclistbox::MassageIndex $w \
1515                                    [lindex $args 0]]
1516                            set index2 ""
1517                        }
1518                        2 {
1519                            set index1 [::mclistbox::MassageIndex $w \
1520                                    [lindex $args 0]]
1521                            set index2 [::mclistbox::MassageIndex $w \
1522                                    [lindex $args 1]]
1523                        }
1524                        default {
1525                            error "$prefix selection clear first ?last?"
1526                        }
1527                    }
1528
1529                    if {$options(-exportselection)} {
1530                        SelectionHandler $w own
1531                    }
1532                    if {$index1 != ""} {
1533                        foreach id $misc(columns) {
1534                            eval {$widgets(listbox$id)} selection set \
1535                                    $index1 $index2
1536                        }
1537                    }
1538
1539                    set result ""
1540                }
1541
1542                anchor {
1543                    if {[llength $args] != 1} {
1544                        error "$prefix selection $subcommand index"
1545                    }
1546                    set index [::mclistbox::MassageIndex $w [lindex $args 0]]
1547
1548                    if {$options(-exportselection)} {
1549                        SelectionHandler $w own
1550                    }
1551                    foreach id $misc(columns) {
1552                        $widgets(listbox$id) selection anchor $index
1553                    }
1554                    set result ""
1555                }
1556
1557                clear {
1558                    switch [llength $args] {
1559                        1 {
1560                            set index1 [::mclistbox::MassageIndex $w \
1561                                    [lindex $args 0]]
1562                            set index2 ""
1563                        }
1564                        2 {
1565                            set index1 [::mclistbox::MassageIndex $w \
1566                                    [lindex $args 0]]
1567                            set index2 [::mclistbox::MassageIndex $w \
1568                                    [lindex $args 1]]
1569                        }
1570                        default {
1571                            error "$prefix selection clear first ?last?"
1572                        }
1573                    }
1574
1575                    if {$options(-exportselection)} {
1576                        SelectionHandler $w own
1577                    }
1578                    foreach id $misc(columns) {
1579                        eval {$widgets(listbox$id)} selection clear \
1580                                $index1 $index2
1581                    }
1582                    set result ""
1583                }
1584            }
1585        }
1586
1587        size {
1588            set id [lindex $misc(columns) 0]
1589            set result [$widgets(listbox$id) size]
1590        }
1591    }
1592
1593    # if the user has a selectcommand defined and the selection changed,
1594    # run the selectcommand
1595    if {[info exists priorSelection] && $options(-selectcommand) != ""} {
1596        set column [lindex $misc(columns) 0]
1597        set currentSelection [$widgets(listbox$column) curselection]
1598        if {[string compare $priorSelection $currentSelection] != 0} {
1599            # this logic keeps us from getting into some sort of
1600            # infinite loop of the selectcommand changes the selection
1601            # (not particularly well tested, but it seems like the
1602            # right thing to do...)
1603            if {![info exists misc(skipRecursiveCall)]} {
1604                set misc(skipRecursiveCall) 1
1605                uplevel \#0 $options(-selectcommand) $currentSelection
1606                catch {unset misc(skipRecursiveCall)}
1607            }
1608        }
1609    }
1610
1611    return $result
1612}
1613
1614# ::mclistbox::WidgetProc-get --
1615#
1616#    Implements the "get" widget command
1617#
1618# Arguments:
1619#
1620#    w      widget path
1621#    args   additional arguments to the get command
1622
1623proc ::mclistbox::WidgetProc-get {w args} {
1624    upvar ::mclistbox::${w}::widgets widgets
1625    upvar ::mclistbox::${w}::options options
1626    upvar ::mclistbox::${w}::misc    misc
1627
1628    set returnType "list"
1629    # the listbox "get" command returns different things
1630    # depending on whether it has one or two args. Internally
1631    # we *always* want a valid list, so we'll force a second
1632    # arg which in turn forces the listbox to return a list,
1633    # even if its a list of one element
1634    if {[llength $args] == 1} {
1635        lappend args [lindex $args 0]
1636        set returnType "listOfLists"
1637    }
1638
1639    # get all the data from each column
1640    foreach id $misc(columns) {
1641        set data($id) [eval {$widgets(listbox$id)} get $args]
1642    }
1643
1644    # now join the data together one row at a time. Ugh.
1645    set result {}
1646    set rows [llength $data($id)]
1647    for {set i 0} {$i < $rows} {incr i} {
1648        set this {}
1649        foreach column $misc(columns) {
1650            lappend this [lindex $data($column) $i]
1651        }
1652        lappend result $this
1653    }
1654   
1655    # now to unroll the list if necessary. If the user gave
1656    # us only one indicie we want to return a single list
1657    # of values. If they gave use two indicies we want to return
1658    # a list of lists.
1659    if {[string compare $returnType "list"] == 0} {
1660        return $result
1661    } else {
1662        return [lindex $result 0]
1663    }
1664}
1665
1666# ::mclistbox::CheckColumnID --
1667#
1668#    returns the index of the id within our list of columns, or
1669#    reports an error if the id is invalid
1670#
1671# Arguments:
1672#
1673#    w    widget pathname
1674#    id   a column id
1675#
1676# Results:
1677#
1678#   Will compute and return the index of the column within the
1679#   list of columns (which happens to be it's -position, as it
1680#   turns out) or returns an error if the named column doesn't
1681#   exist.
1682
1683proc ::mclistbox::CheckColumnID {w id} {
1684    upvar ::mclistbox::${w}::misc    misc
1685
1686    set id [::mclistbox::Canonize $w column $id]
1687    set index [lsearch -exact $misc(columns) $id]
1688    return $index
1689}
1690
1691# ::mclistbox::LabelEvent --
1692#
1693#    Handle user events on the column labels for the Mclistbox
1694#    class.
1695#
1696# Arguments:
1697#
1698#    w        widget pathname
1699#    id       a column identifier
1700#    code     tcl code to be evaluated.
1701#
1702# Results:
1703#
1704#    Executes the code associate with an event, but only if the
1705#    event wouldn't otherwise potentially trigger a resize event.
1706#
1707#    We use the cursor of the label to let us know whether the
1708#    code should be executed. If it is set to the cursor of the
1709#    mclistbox widget, the code will be executed. It is assumed
1710#    that if it is not the same cursor, it is the resize cursor
1711#    which should only be set if the cursor is very near a border
1712#    of a label and the column is resizable.
1713
1714proc ::mclistbox::LabelEvent {w id code} {
1715    upvar ::mclistbox::${w}::widgets widgets
1716    upvar ::mclistbox::${w}::options options
1717
1718    # only fire the binding if the cursor is our default cursor
1719    # (ie: if we aren't in a "resize zone")
1720    set cursor [$widgets(label$id) cget -cursor]
1721    if {[string compare $cursor $options(-cursor)] == 0} {
1722        uplevel \#0 $code
1723    }
1724}
1725
1726# ::mclistbox::HumanizeList --
1727#
1728#    Returns a human-readable form of a list by separating items
1729#    by columns, but separating the last two elements with "or"
1730#    (eg: foo, bar or baz)
1731#
1732# Arguments:
1733#
1734#    list    a valid tcl list
1735#
1736# Results:
1737#
1738#    A string which as all of the elements joined with ", " or
1739#    the word " or "
1740
1741proc ::mclistbox::HumanizeList {list} {
1742
1743    if {[llength $list] == 1} {
1744        return [lindex $list 0]
1745    } else {
1746        set list [lsort $list]
1747        set secondToLast [expr {[llength $list] -2}]
1748        set most [lrange $list 0 $secondToLast]
1749        set last [lindex $list end]
1750
1751        return "[join $most {, }] or $last"
1752    }
1753}
1754
1755# ::mclistbox::Canonize --
1756#
1757#    takes a (possibly abbreviated) option or command name and either
1758#    returns the canonical name or an error
1759#
1760# Arguments:
1761#
1762#    w        widget pathname
1763#    object   type of object to canonize; must be one of "command",
1764#             "option", "column" or "column option".
1765#    opt      the option (or command) to be canonized
1766#
1767# Returns:
1768#
1769#    Returns either the canonical form of an option or command,
1770#    or raises an error if the option or command is unknown or
1771#    ambiguous.
1772
1773proc ::mclistbox::Canonize {w object opt} {
1774    variable widgetOptions
1775    variable columnOptions
1776    variable widgetCommands
1777    variable columnCommands
1778    variable labelCommands
1779
1780    switch $object {
1781        command {
1782            if {[lsearch -exact $widgetCommands $opt] >= 0} {
1783                return $opt
1784            }
1785
1786            # command names aren't stored in an array, and there
1787            # isn't a way to get all the matches in a list, so
1788            # we'll stuff the columns in a temporary array so
1789            # we can use [array names]
1790            set list $widgetCommands
1791            foreach element $list {
1792                set tmp($element) ""
1793            }
1794            set matches [array names tmp ${opt}*]
1795        }
1796
1797        {label command} {
1798            if {[lsearch -exact $labelCommands $opt] >= 0} {
1799                return $opt
1800            }
1801
1802            # command names aren't stored in an array, and there
1803            # isn't a way to get all the matches in a list, so
1804            # we'll stuff the columns in a temporary array so
1805            # we can use [array names]
1806            set list $labelCommands
1807            foreach element $list {
1808                set tmp($element) ""
1809            }
1810            set matches [array names tmp ${opt}*]
1811        }
1812
1813        {column command} {
1814            if {[lsearch -exact $columnCommands $opt] >= 0} {
1815                return $opt
1816            }
1817
1818            # command names aren't stored in an array, and there
1819            # isn't a way to get all the matches in a list, so
1820            # we'll stuff the columns in a temporary array so
1821            # we can use [array names]
1822            set list $columnCommands
1823            foreach element $list {
1824                set tmp($element) ""
1825            }
1826            set matches [array names tmp ${opt}*]
1827        }
1828
1829        option {
1830            if {[info exists widgetOptions($opt)] \
1831                    && [llength $widgetOptions($opt)] == 3} {
1832                return $opt
1833            }
1834            set list [array names widgetOptions]
1835            set matches [array names widgetOptions ${opt}*]
1836        }
1837
1838        {column option} {
1839            if {[info exists columnOptions($opt)]} {
1840                return $opt
1841            }
1842            set list [array names columnOptions]
1843            set matches [array names columnOptions ${opt}*]
1844        }
1845
1846        column {
1847            upvar ::mclistbox::${w}::misc    misc
1848
1849            if {[lsearch -exact $misc(columns) $opt] != -1} {
1850                return $opt
1851            }
1852           
1853            # column names aren't stored in an array, and there
1854            # isn't a way to get all the matches in a list, so
1855            # we'll stuff the columns in a temporary array so
1856            # we can use [array names]
1857            set list $misc(columns)
1858            foreach element $misc(columns) {
1859                set tmp($element) ""
1860            }
1861            set matches [array names tmp ${opt}*]
1862        }
1863    }
1864    if {[llength $matches] == 0} {
1865        set choices [HumanizeList $list]
1866        error "unknown $object \"$opt\"; must be one of $choices"
1867
1868    } elseif {[llength $matches] == 1} {
1869        # deal with option aliases
1870        set opt [lindex $matches 0]
1871        switch $object {
1872            option {
1873                if {[llength $widgetOptions($opt)] == 1} {
1874                    set opt $widgetOptions($opt)
1875                }
1876            }
1877
1878            {column option} {
1879                if {[llength $columnOptions($opt)] == 1} {
1880                    set opt $columnOptions($opt)
1881                }
1882            }
1883        }
1884
1885        return $opt
1886
1887    } else {
1888        set choices [HumanizeList $list]
1889        error "ambiguous $object \"$opt\"; must be one of $choices"
1890    }
1891}
1892
1893# ::mclistbox::Configure --
1894#
1895#    Implements the "configure" widget subcommand
1896#
1897# Arguments:
1898#
1899#    w      widget pathname
1900#    args   zero or more option/value pairs (or a single option)
1901#
1902# Results:
1903#   
1904#    Performs typcial "configure" type requests on the widget
1905 
1906proc ::mclistbox::Configure {w args} {
1907    variable widgetOptions
1908
1909    upvar ::mclistbox::${w}::widgets widgets
1910    upvar ::mclistbox::${w}::options options
1911    upvar ::mclistbox::${w}::misc    misc
1912   
1913    if {[llength $args] == 0} {
1914        # hmmm. User must be wanting all configuration information
1915        # note that if the value of an array element is of length
1916        # one it is an alias, which needs to be handled slightly
1917        # differently
1918        set results {}
1919        foreach opt [lsort [array names widgetOptions]] {
1920            if {[llength $widgetOptions($opt)] == 1} {
1921                set alias $widgetOptions($opt)
1922                set optName $widgetOptions($alias)
1923                lappend results [list $opt $optName]
1924            } else {
1925                set optName  [lindex $widgetOptions($opt) 0]
1926                set optClass [lindex $widgetOptions($opt) 1]
1927                set default [option get $w $optName $optClass]
1928                lappend results [list $opt $optName $optClass \
1929                        $default $options($opt)]
1930            }
1931        }
1932
1933        return $results
1934    }
1935   
1936    # one argument means we are looking for configuration
1937    # information on a single option
1938    if {[llength $args] == 1} {
1939        set opt [::mclistbox::Canonize $w option [lindex $args 0]]
1940
1941        set optName  [lindex $widgetOptions($opt) 0]
1942        set optClass [lindex $widgetOptions($opt) 1]
1943        set default [option get $w $optName $optClass]
1944        set results [list $opt $optName $optClass \
1945                $default $options($opt)]
1946        return $results
1947    }
1948
1949    # if we have an odd number of values, bail.
1950    if {[expr {[llength $args]%2}] == 1} {
1951        # hmmm. An odd number of elements in args
1952        error "value for \"[lindex $args end]\" missing"
1953    }
1954   
1955    # Great. An even number of options. Let's make sure they
1956    # are all valid before we do anything. Note that Canonize
1957    # will generate an error if it finds a bogus option; otherwise
1958    # it returns the canonical option name
1959    foreach {name value} $args {
1960        set name [::mclistbox::Canonize $w option $name]
1961        set opts($name) $value
1962    }
1963
1964    # process all of the configuration options
1965    foreach option [array names opts] {
1966
1967        set newValue $opts($option)
1968        if {[info exists options($option)]} {
1969            set oldValue $options($option)
1970#           set options($option) $newValue
1971        }
1972
1973        switch -- $option {
1974            -exportselection {
1975                if {$newValue} {
1976                    SelectionHandler $w own
1977                    set options($option) 1
1978                } else {
1979                    set options($option) 0
1980                }
1981            }
1982
1983            -fillcolumn {
1984                # if the fill column changed, we need to adjust
1985                # the columns.
1986                AdjustColumns $w
1987                set options($option) $newValue
1988            }
1989
1990            -takefocus {
1991                $widgets(frame) configure -takefocus $newValue
1992                set options($option) [$widgets(frame) cget $option]
1993            }
1994
1995            -background {
1996                foreach id $misc(columns) {
1997                    $widgets(listbox$id) configure -background $newValue
1998                    $widgets(frame$id) configure   -background $newValue
1999                }
2000                $widgets(frame) configure -background $newValue
2001
2002                $widgets(text) configure -background $newValue
2003                set options($option) [$widgets(frame) cget $option]
2004            }
2005
2006            # { the following all must be applied to each listbox }
2007            -foreground -
2008            -font -
2009            -selectborderwidth -
2010            -selectforeground -
2011            -selectbackground -
2012            -setgrid {
2013                foreach id $misc(columns) {
2014                    $widgets(listbox$id) configure $option $newValue
2015                }
2016                $widgets(hiddenListbox) configure $option $newValue
2017                set options($option) [$widgets(hiddenListbox) cget $option]
2018            }
2019
2020            # { the following all must be applied to each listbox and frame }
2021            -cursor {
2022                foreach id $misc(columns) {
2023                    $widgets(listbox$id) configure $option $newValue
2024                    $widgets(frame$id) configure -cursor $newValue
2025                }
2026
2027                # -cursor also needs to be applied to the
2028                # frames of each column
2029                foreach id $misc(columns) {
2030                    $widgets(frame$id) configure -cursor $newValue
2031                }
2032
2033                $widgets(hiddenListbox) configure $option $newValue
2034                set options($option) [$widgets(hiddenListbox) cget $option]
2035            }
2036
2037            # { this just requires to pack or unpack the labels }
2038            -labels {
2039                if {$newValue} {
2040                    set newValue 1
2041                    foreach id $misc(columns) {
2042                        pack $widgets(label$id) \
2043                                -side top -fill x -expand n \
2044                                -before $widgets(listbox$id)
2045                    }
2046                    pack $widgets(hiddenLabel) \
2047                            -side top -fill x -expand n \
2048                            -before $widgets(hiddenListbox)
2049
2050                } else {
2051                    set newValue
2052                    foreach id $misc(columns) {
2053                        pack forget $widgets(label$id)
2054                    }
2055                    pack forget $widgets(hiddenLabel)
2056                }
2057                set options($option) $newValue
2058            }
2059
2060            -height {
2061                $widgets(hiddenListbox) configure -height $newValue
2062                InvalidateScrollbars $w
2063                set options($option) [$widgets(hiddenListbox) cget $option]
2064            }
2065
2066            -width {
2067                if {$newValue == 0} {
2068                    error "a -width of zero is not supported. "
2069                }
2070
2071                $widgets(hiddenListbox) configure -width $newValue
2072                InvalidateScrollbars $w
2073                set options($option) [$widgets(hiddenListbox) cget $option]
2074            }
2075
2076            # { the following all must be applied to each column frame }
2077            -columnborderwidth -
2078            -columnrelief {
2079                regsub {column} $option {} listboxoption
2080                foreach id $misc(columns) {
2081                    $widgets(listbox$id) configure $listboxoption $newValue
2082                }
2083                $widgets(hiddenListbox) configure $listboxoption $newValue
2084                set options($option) [$widgets(hiddenListbox) cget \
2085                        $listboxoption]
2086            }
2087
2088            -resizablecolumns {
2089                if {$newValue} {
2090                    set options($option) 1
2091                } else {
2092                    set options($option) 0
2093                }
2094            }
2095           
2096            # { the following all must be applied to each column header }
2097            -labelimage -
2098            -labelheight -
2099            -labelrelief -
2100            -labelfont -
2101            -labelanchor -
2102            -labelbackground -
2103            -labelforeground -
2104            -labelborderwidth {
2105                regsub {label} $option {} labeloption
2106                foreach id $misc(columns) {
2107                    $widgets(label$id) configure $labeloption $newValue
2108                }
2109                $widgets(hiddenLabel) configure $labeloption $newValue
2110                set options($option) [$widgets(hiddenLabel) cget $labeloption]
2111            }
2112
2113            # { the following apply only to the topmost frame}
2114            -borderwidth -
2115            -highlightthickness -
2116            -highlightcolor -
2117            -highlightbackground -
2118            -relief {
2119                $widgets(frame) configure $option $newValue
2120                set options($option) [$widgets(frame) cget $option]
2121            }
2122
2123            -selectmode {
2124                set options($option) $newValue
2125            }
2126
2127            -selectcommand {
2128                set options($option) $newValue
2129            }
2130
2131            -xscrollcommand {
2132                InvalidateScrollbars $w
2133                set options($option) $newValue
2134            }
2135
2136            -yscrollcommand {
2137                InvalidateScrollbars $w
2138                set options($option) $newValue
2139            }
2140        }
2141    }
2142}
2143
2144# ::mclistbox::UpdateScrollbars --
2145#
2146#    This proc does the work of actually update the scrollbars to
2147#    reflect the current view
2148#
2149# Arguments:
2150#
2151#    w      widget pathname
2152#
2153# Results:
2154#
2155#    Potentially changes the size or placement of the scrollbars
2156#    (if any) based on changes to the widget
2157
2158proc ::mclistbox::UpdateScrollbars {w} {
2159    upvar ::mclistbox::${w}::widgets widgets
2160    upvar ::mclistbox::${w}::options options
2161    upvar ::mclistbox::${w}::misc    misc
2162
2163    if {![winfo ismapped $w]} {
2164        catch {unset misc(afterid)}
2165        return
2166    }
2167
2168    update idletasks
2169    if {[llength $misc(columns)] > 0} {
2170        if {[string length $options(-yscrollcommand)] != 0} {
2171            set col0 [lindex $misc(columns) 0]
2172            set yview [$widgets(listbox$col0) yview]
2173            eval $options(-yscrollcommand) $yview
2174        }
2175
2176        if {[string length $options(-xscrollcommand)] != 0} {
2177            set col0 [lindex $misc(columns) 0]
2178            set xview [$widgets(text) xview]
2179            eval $options(-xscrollcommand) $xview
2180        }
2181    }
2182    catch {unset misc(afterid)}
2183}
2184
2185# ::mclistbox::InvalidateScrollbars --
2186#
2187#    Schedules the scrollbars to be updated the next time
2188#    we are idle.
2189#
2190# Arguments:
2191#
2192#    w     widget pathname
2193#
2194# Results:
2195#
2196#    sets up a proc to be run in the idle event handler
2197
2198proc ::mclistbox::InvalidateScrollbars {w} {
2199
2200    upvar ::mclistbox::${w}::widgets widgets
2201    upvar ::mclistbox::${w}::options options
2202    upvar ::mclistbox::${w}::misc    misc
2203
2204    if {![info exists misc(afterid)]} {
2205        set misc(afterid) \
2206                [after idle "catch {::mclistbox::UpdateScrollbars $w}"]
2207    }
2208}
2209
2210# ::mclistbox::Insert --
2211#
2212#    This implements the "insert" widget command; it arranges for
2213#    one or more elements to be inserted into the listbox.
2214#
2215# Arguments:
2216#
2217#    w         widget pathname
2218#    index     a valid listbox index to designate where the data is
2219#              to be inserted
2220#    arglist   A list of values to be inserted. Each element of the
2221#              list will itself be treated as a list, one element for
2222#              each column.
2223#
2224# Results:
2225#
2226#    Inserts the data into the list and updates the scrollbars
2227
2228proc ::mclistbox::Insert {w index arglist} {
2229
2230    upvar ::mclistbox::${w}::widgets widgets
2231    upvar ::mclistbox::${w}::options options
2232    upvar ::mclistbox::${w}::misc    misc
2233
2234    foreach list $arglist {
2235        # make sure we have enough elements for each column
2236        for {set i [llength $list]} {$i < [llength $misc(columns)]} {incr i} {
2237            lappend list {}
2238        }
2239
2240        set column 0
2241        foreach id $misc(columns) {
2242            $widgets(listbox$id) insert $index [lindex $list $column]
2243            incr column
2244        }
2245
2246        # we also want to add a bogus item to the hidden listbox. Why?
2247        # For standard listboxes, if you specify a height of zero the
2248        # listbox will resize to be just big enough to hold all the lines.
2249        # Since we use a hidden listbox to regulate the size of the widget
2250        # and we want this same behavior, this listbox needs the same number
2251        # of elements as the visible listboxes
2252        #
2253        # (NB: we might want to make this listbox contain the contents
2254        # of all columns as a properly formatted list; then the get
2255        # command can query this listbox instead of having to query
2256        # each individual listbox. The disadvantage is that it doubles
2257        # the memory required to hold all the data)
2258        $widgets(hiddenListbox) insert $index "x"
2259    }
2260    return ""
2261}
2262
2263# ::mclistbox::ColumnIsHidden --
2264#
2265#    Returns a boolean representing whether a column is visible or
2266#    not
2267#
2268# Arguments:
2269#
2270#    w     widget pathname
2271#    id    a column identifier
2272#
2273# Results:
2274#
2275#    returns 1 if the column is visible (ie: not hidden), or 0
2276#    if invisible. Note that the result doesn't consider whether
2277#    the column is actually viewable. Even if it has been scrolled
2278#    off screen, 1 will be returned as long as the column hasn't
2279#    been hidden by turning the visibility off.
2280
2281proc ::mclistbox::ColumnIsHidden {w id} {
2282    upvar ::mclistbox::${w}::widgets widgets
2283    upvar ::mclistbox::${w}::misc    misc
2284   
2285    set retval 1
2286    set col [lsearch -exact $misc(columns) $id]
2287
2288    if {$col != ""} {
2289        set index "1.$col"
2290        catch {
2291            set window [$widgets(text) window cget $index -window]
2292            if {[string length $window] > 0 && [winfo exists $window]} {
2293                set retval 0
2294            }
2295        }
2296    }
2297    return $retval
2298}
2299
2300# ::mclistbox::AdjustColumns --
2301#
2302#    Adjusts the height and width of the individual columns.
2303#
2304# Arguments:
2305#
2306#    w       widget pathname
2307#    height  height, in pixels, that the columns should be adjusted
2308#            to. If null, the height will be the height of the text
2309#            widget that underlies our columns.
2310#
2311# Results:
2312#
2313#    All columns will be adjusted to fill the text widget in the y
2314#    direction. Also, if a -fillcolumn is defined, that column will
2315#    be grown, if necessary, to fill the widget in the x direction.
2316
2317proc ::mclistbox::AdjustColumns {w {height ""}} {
2318    upvar ::mclistbox::${w}::widgets widgets
2319    upvar ::mclistbox::${w}::options options
2320    upvar ::mclistbox::${w}::misc    misc
2321
2322    if {[string length $height] == 0} {
2323        set height [winfo height $widgets(text)]
2324    }
2325
2326    # resize the height of each column so it matches the height
2327    # of the text widget, minus a few pixels.
2328    incr height -4
2329    foreach id $misc(columns) {
2330        $widgets(frame$id) configure -height $height
2331    }
2332   
2333    # if we have a fillcolumn, change its width accordingly
2334    if {$options(-fillcolumn) != ""} {
2335
2336        # make sure the column has been defined. If not, bail (?)
2337        if {![info exists widgets(frame$options(-fillcolumn))]} {
2338            return
2339        }
2340        set frame $widgets(frame$options(-fillcolumn))
2341        set minwidth $misc(min-$frame)
2342
2343        # compute current width of all columns
2344        set colwidth 0
2345        set col 0
2346        foreach id $misc(columns) {
2347            if {![ColumnIsHidden $w $id] && $id != $options(-fillcolumn)} {
2348                incr colwidth [winfo reqwidth $widgets(frame$id)]
2349            }
2350        }
2351
2352        # this is just shorthand for later use...
2353        set id $options(-fillcolumn)
2354
2355        # compute optimal width
2356        set optwidth [expr {[winfo width $widgets(text)] - \
2357                (2 * [$widgets(text) cget -padx])}]
2358
2359        # compute the width of our fill column
2360        set newwidth [expr {$optwidth - $colwidth}]
2361
2362        if {$newwidth < $minwidth} {
2363            set newwidth $minwidth
2364        }
2365
2366        # adjust the width of our fill column frame
2367        $widgets(frame$id) configure -width $newwidth
2368           
2369    }
2370    InvalidateScrollbars $w
2371}
2372
2373# ::mclistbox::FindResizableNeighbor --
2374#
2375#    Returns the nearest resizable column to the left or right
2376#    of the named column.
2377#
2378# Arguments:
2379#
2380#    w          widget pathname
2381#    id         column identifier
2382#    direction  should be one of "right" or "left". Actually, anything
2383#               that doesn't match "right" will be treated as "left"
2384#
2385# Results:
2386#
2387#    Will return the column identifier of the nearest resizable
2388#    column, or an empty string if none exists.
2389
2390proc ::mclistbox::FindResizableNeighbor {w id {direction right}} {
2391    upvar ::mclistbox::${w}::widgets       widgets
2392    upvar ::mclistbox::${w}::options       options
2393    upvar ::mclistbox::${w}::misc          misc
2394
2395
2396    if {$direction == "right"} {
2397        set incr 1
2398        set stop [llength $misc(columns)]
2399        set start [expr {[lsearch -exact $misc(columns) $id] + 1}]
2400    } else {
2401        set incr -1
2402        set stop -1
2403        set start [expr {[lsearch -exact $misc(columns) $id] - 1}]
2404    }
2405
2406    for {set i $start} {$i != $stop} {incr i $incr} {
2407        set col [lindex $misc(columns) $i]
2408        if {![ColumnIsHidden $w $col] && $options($col:-resizable)} {
2409            return $col
2410        }
2411    }
2412    return ""
2413}
2414
2415# ::mclistbox::ResizeEvent --
2416#
2417#    Handles the events which implement interactive column resizing
2418#    using the mouse.
2419#
2420# Arguments:
2421#
2422#    w        widget pathname
2423#    type     type of event; must be one of "buttonpress", "drag",
2424#             "motion", or "buttonrelease"
2425#    widget   the actual widget that the event occured over
2426#    x        the x coordinate of the mouse, relative to $widget
2427#    X        the root x coordinate of the mouse
2428#    Y        the root y coordinate of the mouse
2429#
2430# The basic idea is this:
2431#
2432# whenever the cursor moves over the label, we examine it's x
2433# coordinate to determine if its within a fixed amount of
2434# pixels from the left or right edge. If it is, we reconfigure
2435# the cursor to be a suitable "this thing is resizable" cursor.
2436#
2437# On a buttonclick, if the cursor is not the default cursor
2438# (and thus, presumably the resize cursor), we set up some
2439# state for an eventual resize. We figure out which columns
2440# are to the left and right and base a maximum resize amount
2441# for each direction. We also define the absolute X coordinate
2442# of the buttonpress as a reference point for the drag.
2443#
2444# on a b1-motion, if the drag state exists, we look at the
2445# absolute X value and use it to compute a delta value from
2446# the reference (the X of the button press). We then resize the
2447# left and right column frames by the delta amount.
2448#
2449# on a button release, we unset the state and the cursor, which
2450# cancels all of the above.
2451
2452proc ::mclistbox::ResizeEvent {w type widget x X Y} {
2453
2454    upvar ::mclistbox::${w}::widgets       widgets
2455    upvar ::mclistbox::${w}::options       options
2456    upvar ::mclistbox::${w}::misc          misc
2457    upvar ::mclistbox::${w}::columnID      columnID
2458
2459    # if the widget doesn't allow resizable cursors, there's
2460    # nothing here to do...
2461    if {!$options(-resizablecolumns)} {
2462        return
2463    }
2464
2465    # this lets us keep track of some internal state while
2466    # the user is dragging the mouse
2467    variable drag
2468
2469    # this lets us define a small window around the edges of
2470    # the column.
2471    set threshold [expr {$options(-labelborderwidth) + 4}]
2472
2473    # this is what we use for the "this is resizable" cursor
2474    set resizeCursor sb_h_double_arrow
2475
2476    # if we aren't over an area that we care about, bail.
2477    if {![info exists columnID($widget)]} {
2478        return
2479    }
2480
2481    # id refers to the column name
2482    set id $columnID($widget)
2483
2484    switch $type {
2485
2486        buttonpress {
2487            # we will do all the work of initiating a drag only if
2488            # the cursor is not the defined cursor. In theory this
2489            # will only be the case if the mouse moves over the area
2490            # in which a drag can happen.
2491            if {[$widgets(label$id) cget -cursor] == $resizeCursor} {
2492                if {$x <= $threshold} {
2493                    set lid [::mclistbox::FindResizableNeighbor $w $id left]
2494                    if {$lid == ""} return
2495                    set drag(leftFrame)  $widgets(frame$lid)
2496                    set drag(rightFrame) $widgets(frame$id)
2497
2498                    set drag(leftListbox)  $widgets(listbox$lid)
2499                    set drag(rightListbox) $widgets(listbox$id)
2500
2501                } else {
2502                    set rid [::mclistbox::FindResizableNeighbor $w $id right]
2503                    if {$rid == ""} return
2504                    set drag(leftFrame)  $widgets(frame$id)
2505                    set drag(rightFrame) $widgets(frame$rid)
2506
2507                    set drag(leftListbox)  $widgets(listbox$id)
2508                    set drag(rightListbox) $widgets(listbox$rid)
2509
2510                }
2511               
2512
2513                set drag(leftWidth)  [winfo width $drag(leftFrame)]
2514                set drag(rightWidth) [winfo width $drag(rightFrame)]
2515
2516                # it seems to be a fact that windows can never be
2517                # less than one pixel wide. So subtract that one pixel
2518                # from our max deltas...
2519                set drag(maxDelta)   [expr {$drag(rightWidth) - 1}]
2520                set drag(minDelta)  -[expr {$drag(leftWidth) - 1}]
2521
2522                set drag(x) $X
2523            }
2524        }
2525
2526        motion {
2527            if {[info exists drag(x)]} {return}
2528
2529            # this is just waaaaay too much work for a motion
2530            # event, IMO.
2531
2532            set resizable 0
2533
2534            # is the column the user is over resizable?
2535            if {!$options($id:-resizable)} {return}
2536
2537            # did the user click on the left of a column?
2538            if {$x < $threshold} {
2539                set leftColumn [::mclistbox::FindResizableNeighbor $w $id left]
2540                if {$leftColumn != ""} {
2541                    set resizable 1
2542                }
2543
2544            } elseif {$x > [winfo width $widget] - $threshold} {
2545                set rightColumn [::mclistbox::FindResizableNeighbor $w $id \
2546                        right]
2547                if {$rightColumn != ""} {
2548                    set resizable 1
2549                }
2550            }
2551
2552            # if it's resizable, change the cursor
2553            set cursor [$widgets(label$id) cget -cursor]
2554            if {$resizable && $cursor != $resizeCursor} {
2555                $widgets(label$id) configure -cursor $resizeCursor
2556
2557            } elseif {!$resizable && $cursor == $resizeCursor} {
2558                $widgets(label$id) configure -cursor $options(-cursor)
2559            }
2560        }
2561
2562        drag {
2563            # if the state is set up, do the drag...
2564            if {[info exists drag(x)]} {
2565
2566                set delta [expr {$X - $drag(x)}]
2567                if {$delta >= $drag(maxDelta)} {
2568                    set delta $drag(maxDelta)
2569
2570                } elseif {$delta <= $drag(minDelta)} {
2571                    set delta $drag(minDelta)
2572                }
2573
2574                set lwidth [expr {$drag(leftWidth) + $delta}]
2575                set rwidth [expr {$drag(rightWidth) - $delta}]
2576
2577                $drag(leftFrame)   configure -width $lwidth
2578                $drag(rightFrame)  configure -width $rwidth
2579
2580            }
2581        }
2582
2583        buttonrelease {
2584            set fillColumnID $options(-fillcolumn)
2585            if {[info exists drag(x)] && $fillColumnID != {}} {
2586                set fillColumnFrame $widgets(frame$fillColumnID)
2587                if {[string compare $drag(leftFrame) $fillColumnFrame] == 0 \
2588                        || [string compare $drag(rightFrame) $fillColumnFrame] == 0} {
2589                    set width [$fillColumnFrame cget -width]
2590                    set misc(minFillColumnSize) $width
2591                }
2592                set misc(min-$drag(leftFrame))  [$drag(leftFrame) cget -width]
2593                set misc(min-$drag(rightFrame)) [$drag(rightFrame) cget -width]
2594            }
2595
2596            # reset the state and the cursor
2597            catch {unset drag}
2598            $widgets(label$id) configure -cursor $options(-cursor)
2599
2600        }
2601    }
2602}
2603
2604# end of mclistbox.tcl
Note: See TracBrowser for help on using the repository browser.