lib/maracasVisuLib/src/interface/tcl/tkwidgets/mclistbox.tcl

   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
  31 package require Tk 8.0
  32 package provide mclistbox 1.02
  33
  34 namespace 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
  64 proc ::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
 248 proc ::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
 301 proc ::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
 432 proc ::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
 514 proc ::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
 576 proc ::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
 597 proc ::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
 657 proc ::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
 749 proc ::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
 839 proc ::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
1023 proc ::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
1060 proc ::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
1100 proc ::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
1623 proc ::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
1683 proc ::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
1714 proc ::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
1741 proc ::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
1773 proc ::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
1906 proc ::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
2158 proc ::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
2198 proc ::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
2228 proc ::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
2281 proc ::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
2317 proc ::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
2390 proc ::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
2452 proc ::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