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

   1 # Copyright (c) 1998-1999, Bryan Oakley
   2 # All Rights Reservered
   3 #
   4 # Bryan Oakley
   5 # oakley@channelpoint.com
   6 #
   7 # combobox v2.0b2 April 14, 1999
   8 #
   9 # a combobox / dropdown listbox (pick your favorite name) widget
  10 # written in pure tcl
  11 #
  12 # this code is freely distributable without restriction, but is
  13 # provided as-is with no waranty expressed or implied.
  14 #
  15 # thanks to the following people who provided beta test support or
  16 # patches to the code (in no particular order):
  17 #
  18 # Scott Beasley     Alexandre Ferrieux      Todd Helfter
  19 # Matt Gushee       Laurent Duperval        John Jackson
  20 # Fred Rapp         Christopher Nelson
  21 # Eric Galluzzo     Jean-Francois Moine
  22
  23 # A special thanks to Martin M. Hunt who provided several good ideas,
  24 # and always with a patch to implement them. Jean-Francois Moine,
  25 # Todd Helfter and John Jackson were also kind enough to send in some
  26 # code patches.
  27
  28 package require Tk 8.0
  29 package provide combobox 2.0
  30
  31 namespace eval ::combobox {
  32
  33     # this is the public interface
  34     namespace export combobox
  35
  36     # these contain references to available options
  37     variable widgetOptions
  38
  39     # these contain references to available commands and subcommands
  40     variable widgetCommands
  41     variable scanCommands
  42     variable listCommands
  43
  44 }
  45
  46 # ::combobox::combobox --
  47 #
  48 #     This is the command that gets exported. It creates a new
  49 #     combobox widget.
  50 #
  51 # Arguments:
  52 #
  53 #     w        path of new widget to create
  54 #     args     additional option/value pairs (eg: -background white, etc.)
  55 #
  56 # Results:
  57 #
  58 #     It creates the widget and sets up all of the default bindings
  59 #
  60 # Returns:
  61 #
  62 #     The name of the newly create widget
  63
  64 proc ::combobox::combobox {w args} {
  65     variable widgetOptions
  66     variable widgetCommands
  67     variable scanCommands
  68     variable listCommands
  69
  70     # perform a one time initialization
  71     if {![info exists widgetOptions]} {
  72         Init
  73     }
  74
  75     # build it...
  76     eval Build $w $args
  77
  78     # set some bindings...
  79     SetBindings $w
  80
  81     # and we are done!
  82     return $w
  83 }
  84
  85
  86 # ::combobox::Init --
  87 #
  88 #     Initialize the global (well, namespace) variables. This should
  89 #     only be called once, immediately prior to creating the first
  90 #     instance of the widget
  91 #
  92 # Arguments:
  93 #
  94 #    none
  95 #
  96 # Results:
  97 #
  98 #     All state variables are set to their default values; all of
  99 #     the option database entries will exist.
 100 #
 101 # Returns:
 102 #
 103 #     empty string
 104
 105 proc ::combobox::Init {} {
 106     variable widgetOptions
 107     variable widgetCommands
 108     variable scanCommands
 109     variable listCommands
 110     variable defaultEntryCursor
 111
 112     array set widgetOptions [list \
 113             -background          {background          Background} \
 114             -bd                  -borderwidth \
 115             -bg                  -background \
 116             -borderwidth         {borderWidth         BorderWidth} \
 117             -command             {command             Command} \
 118             -commandstate        {commandState        State} \
 119             -cursor              {cursor              Cursor} \
 120             -editable            {editable            Editable} \
 121             -fg                  -foreground \
 122             -font                {font                Font} \
 123             -foreground          {foreground          Foreground} \
 124             -height              {height              Height} \
 125             -highlightbackground {highlightBackground HighlightBackground} \
 126             -highlightcolor      {highlightColor      HighlightColor} \
 127             -highlightthickness  {highlightThickness  HighlightThickness} \
 128             -image               {image               Image} \
 129             -maxheight           {maxHeight           Height} \
 130             -relief              {relief              Relief} \
 131             -selectbackground    {selectBackground    Foreground} \
 132             -selectborderwidth   {selectBorderWidth   BorderWidth} \
 133             -selectforeground    {selectForeground    Background} \
 134             -state               {state               State} \
 135             -takefocus           {takeFocus           TakeFocus} \
 136             -textvariable        {textVariable        Variable} \
 137             -value               {value               Value} \
 138             -width               {width               Width} \
 139             -xscrollcommand      {xScrollCommand      ScrollCommand} \
 140     ]
 141
 142
 143     set widgetCommands [list \
 144             bbox      cget     configure    curselection \
 145             delete    get      icursor      index        \
 146             insert    list     scan         selection    \
 147             xview     select   toggle       open         \
 148             close \
 149     ]
 150
 151     set listCommands [list \
 152             delete       get      \
 153             index        insert       size \
 154     ]
 155
 156     set scanCommands [list mark dragto]
 157
 158     # why check for the Tk package? This lets us be sourced into
 159     # an interpreter that doesn't have Tk loaded, such as the slave
 160     # interpreter used by pkg_mkIndex. In theory it should have no
 161     # side effects when run
 162     if {[lsearch -exact [package names] "Tk"] != -1} {
 163
 164         ##################################################################
 165         #- this initializes the option database. Kinda gross, but it works
 166         #- (I think).
 167         ##################################################################
 168
 169         # the image used for the button...
 170         if {$::tcl_platform(platform) == "windows"} {
 171             image create bitmap ::combobox::bimage -data {
 172                 #define down_arrow_width 12
 173                 #define down_arrow_height 12
 174                 static char down_arrow_bits[] = {
 175                     0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
 176                     0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0,
 177                     0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00;
 178                 }
 179             }
 180         } else {
 181             image create bitmap ::combobox::bimage -data  {
 182                 #define down_arrow_width 15
 183                 #define down_arrow_height 15
 184                 static char down_arrow_bits[] = {
 185                     0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,
 186                     0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83,
 187                     0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,
 188                     0x00,0x80,0x00,0x80,0x00,0x80
 189                 }
 190             }
 191         }
 192
 193         # compute a widget name we can use to create a temporary widget
 194         set tmpWidget ".__tmp__"
 195         set count 0
 196         while {[winfo exists $tmpWidget] == 1} {
 197             set tmpWidget ".__tmp__$count"
 198             incr count
 199         }
 200
 201         # get the scrollbar width. Because we try to be clever and draw our
 202         # own button instead of using a tk widget, we need to know what size
 203         # button to create. This little hack tells us the width of a scroll
 204         # bar.
 205         #
 206         # NB: we need to be sure and pick a window  that doesn't already
 207         # exist...
 208         scrollbar $tmpWidget
 209         set sb_width [winfo reqwidth $tmpWidget]
 210         destroy $tmpWidget
 211
 212         # steal options from the entry widget
 213         # we want darn near all options, so we'll go ahead and do
 214         # them all. No harm done in adding the one or two that we
 215         # don't use.
 216         entry $tmpWidget
 217         foreach foo [$tmpWidget configure] {
 218             # the cursor option is special, so we'll save it in
 219             # a special way
 220             if {[lindex $foo 0] == "-cursor"} {
 221                 set defaultEntryCursor [lindex $foo 4]
 222             }
 223             if {[llength $foo] == 5} {
 224                 set option [lindex $foo 1]
 225                 set value [lindex $foo 4]
 226                 option add *Combobox.$option $value widgetDefault
 227
 228                 # these options also apply to the dropdown listbox
 229                 if {[string compare $option "foreground"] == 0 \
 230                         || [string compare $option "background"] == 0 \
 231                         || [string compare $option "font"] == 0} {
 232                     option add *Combobox*ComboboxListbox.$option $value \
 233                             widgetDefault
 234                 }
 235             }
 236         }
 237         destroy $tmpWidget
 238
 239         # these are unique to us...
 240         option add *Combobox.cursor              {}
 241         option add *Combobox.commandState        normal widgetDefault
 242         option add *Combobox.editable            1      widgetDefault
 243         option add *Combobox.maxHeight           10     widgetDefault
 244         option add *Combobox.height              0
 245     }
 246
 247     # set class bindings
 248     SetClassBindings
 249 }
 250
 251 # ::combobox::SetClassBindings --
 252 #
 253 #    Sets up the default bindings for the widget class
 254 #
 255 #    this proc exists since it's The Right Thing To Do, but
 256 #    I haven't had the time to figure out how to do all the
 257 #    binding stuff on a class level. The main problem is that
 258 #    the entry widget must have focus for the insertion cursor
 259 #    to be visible. So, I either have to have the entry widget
 260 #    have the Combobox bindtag, or do some fancy juggling of
 261 #    events or some such. What a pain.
 262 #
 263 # Arguments:
 264 #
 265 #    none
 266 #
 267 # Returns:
 268 #
 269 #    empty string
 270
 271 proc ::combobox::SetClassBindings {} {
 272
 273     # make sure we clean up after ourselves...
 274     bind Combobox <Destroy> [list ::combobox::DestroyHandler %W]
 275
 276     # this will (hopefully) close (and lose the grab on) the
 277     # listbox if the user clicks anywhere outside of it. Note
 278     # that on Windows, you can click on some other app and
 279     # the listbox will still be there, because tcl won't see
 280     # that button click
 281     set this {[::combobox::convert %W -W]}
 282     bind Combobox <Any-ButtonPress>   "$this close"
 283     bind Combobox <Any-ButtonRelease> "$this close"
 284
 285     # this helps (but doesn't fully solve) focus issues. The general
 286     # idea is, whenever the frame gets focus it gets passed on to
 287     # the entry widget
 288     bind Combobox <FocusIn> {tkTabToWindow [::combobox::convert %W -W].entry}
 289
 290     # this closes the listbox if we get hidden
 291     bind Combobox <Unmap> {[::combobox::convert %W -W] close}
 292
 293     return ""
 294 }
 295
 296 # ::combobox::SetBindings --
 297 #
 298 #    here's where we do most of the binding foo. I think there's probably
 299 #    a few bindings I ought to add that I just haven't thought
 300 #    about...
 301 #
 302 #    I'm not convinced these are the proper bindings. Ideally all
 303 #    bindings should be on "Combobox", but because of my juggling of
 304 #    bindtags I'm not convinced thats what I want to do. But, it all
 305 #    seems to work, its just not as robust as it could be.
 306 #
 307 # Arguments:
 308 #
 309 #    w    widget pathname
 310 #
 311 # Returns:
 312 #
 313 #    empty string
 314
 315 proc ::combobox::SetBindings {w} {
 316     upvar ::combobox::${w}::widgets  widgets
 317     upvar ::combobox::${w}::options  options
 318
 319     # juggle the bindtags. The basic idea here is to associate the
 320     # widget name with the entry widget, so if a user does a bind
 321     # on the combobox it will get handled properly since it is
 322     # the entry widget that has keyboard focus.
 323     bindtags $widgets(entry) \
 324             [concat $widgets(this) [bindtags $widgets(entry)]]
 325
 326     bindtags $widgets(button) \
 327             [concat $widgets(this) [bindtags $widgets(button)]]
 328
 329     # override the default bindings for tab and shift-tab. The
 330     # focus procs take a widget as their only parameter and we
 331     # want to make sure the right window gets used (for shift-
 332     # tab we want it to appear as if the event was generated
 333     # on the frame rather than the entry. I
 334
 335     bind $widgets(entry) <Tab> \
 336             "tkTabToWindow \[tk_focusNext $widgets(entry)\]; break"
 337     bind $widgets(entry) <Shift-Tab> \
 338             "tkTabToWindow \[tk_focusPrev $widgets(this)\]; break"
 339
 340     # this makes our "button" (which is actually a label)
 341     # do the right thing
 342     bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle]
 343
 344     # this lets the autoscan of the listbox work, even if they
 345     # move the cursor over the entry widget.
 346     bind $widgets(entry) <B1-Enter> "break"
 347
 348     bind $widgets(listbox) <ButtonRelease-1> \
 349             "::combobox::Select $widgets(this) \[$widgets(listbox) nearest %y\]; break"
 350
 351     bind $widgets(vsb) <ButtonPress-1>   {continue}
 352     bind $widgets(vsb) <ButtonRelease-1> {continue}
 353
 354     bind $widgets(listbox) <Any-Motion> {
 355         %W selection clear 0 end
 356         %W activate @%x,%y
 357         %W selection anchor @%x,%y
 358         %W selection set @%x,%y @%x,%y
 359         # need to do a yview if the cursor goes off the top
 360         # or bottom of the window... (or do we?)
 361     }
 362
 363     # these events need to be passed from the entry
 364     # widget to the listbox, or need some sort of special
 365     # handling....
 366     foreach event [list <Up> <Down> <Tab> <Return> <Escape> \
 367             <Next> <Prior> <Double-1> <1> <Any-KeyPress> \
 368             <FocusIn> <FocusOut>] {
 369         bind $widgets(entry) $event \
 370                 "::combobox::HandleEvent $widgets(this) $event"
 371     }
 372
 373 }
 374
 375 # ::combobox::Build --
 376 #
 377 #    This does all of the work necessary to create the basic
 378 #    combobox.
 379 #
 380 # Arguments:
 381 #
 382 #    w        widget name
 383 #    args     additional option/value pairs
 384 #
 385 # Results:
 386 #
 387 #    Creates a new widget with the given name. Also creates a new
 388 #    namespace patterened after the widget name, as a child namespace
 389 #    to ::combobox
 390 #
 391 # Returns:
 392 #
 393 #    the name of the widget
 394
 395 proc ::combobox::Build {w args } {
 396     variable widgetOptions
 397
 398     if {[winfo exists $w]} {
 399         error "window name \"$w\" already exists"
 400     }
 401
 402     # create the namespace for this instance, and define a few
 403     # variables
 404     namespace eval ::combobox::$w {
 405
 406         variable ignoreTrace 0
 407         variable oldFocus    {}
 408         variable oldGrab     {}
 409         variable oldValue    {}
 410         variable options
 411         variable this
 412         variable widgets
 413
 414         set widgets(foo) foo  ;# coerce into an array
 415         set options(foo) foo  ;# coerce into an array
 416
 417         unset widgets(foo)
 418         unset options(foo)
 419     }
 420
 421     # import the widgets and options arrays into this proc so
 422     # we don't have to use fully qualified names, which is a
 423     # pain.
 424     upvar ::combobox::${w}::widgets widgets
 425     upvar ::combobox::${w}::options options
 426
 427     # this is our widget -- a frame of class Combobox. Naturally,
 428     # it will contain other widgets. We create it here because
 429     # we need it to be able to set our default options.
 430     set widgets(this)   [frame  $w -class Combobox -takefocus 0]
 431     set widgets(entry)  [entry  $w.entry -takefocus 1]
 432     set widgets(button) [label  $w.button -takefocus 0]
 433
 434     # this defines all of the default options. We get the
 435     # values from the option database. Note that if an array
 436     # value is a list of length one it is an alias to another
 437     # option, so we just ignore it
 438     foreach name [array names widgetOptions] {
 439         if {[llength $widgetOptions($name)] == 1} continue
 440         set optName  [lindex $widgetOptions($name) 0]
 441         set optClass [lindex $widgetOptions($name) 1]
 442         set value [option get $w $optName $optClass]
 443         set options($name) $value
 444     }
 445
 446     # if -value is set to null, we'll remove it from our
 447     # local array. The assumption is, if the user sets it from
 448     # the option database, they will set it to something other
 449     # than null (since it's impossible to determine the difference
 450     # between a null value and no value at all).
 451     if {[info exists options(-value)] \
 452             && [string length $options(-value)] == 0} {
 453         unset options(-value)
 454     }
 455
 456     # we will later rename the frame's widget proc to be our
 457     # own custom widget proc. We need to keep track of this
 458     # new name, so we'll define and store it here...
 459     set widgets(frame) ::combobox::${w}::$w
 460
 461     # gotta do this sooner or later. Might as well do it now
 462     pack $widgets(entry)  -side left  -fill both -expand yes
 463     pack $widgets(button) -side right -fill y    -expand no
 464
 465     # I should probably do this in a catch, but for now it's
 466     # good enough... What it does, obviously, is put all of
 467     # the option/values pairs into an array. Make them easier
 468     # to handle later on...
 469     array set options $args
 470
 471     # now, the dropdown list... the same renaming nonsense
 472     # must go on here as well...
 473     set widgets(popup)   [toplevel  $w.top]
 474     set widgets(listbox) [listbox   $w.top.list]
 475     set widgets(vsb)     [scrollbar $w.top.vsb]
 476
 477     pack $widgets(listbox) -side left -fill both -expand y
 478
 479     # fine tune the widgets based on the options (and a few
 480     # arbitrary values...)
 481
 482     # NB: we are going to use the frame to handle the relief
 483     # of the widget as a whole, so the entry widget will be
 484     # flat. This makes the button which drops down the list
 485     # to appear "inside" the entry widget.
 486
 487     $widgets(vsb) configure \
 488             -command "$widgets(listbox) yview" \
 489             -highlightthickness 0
 490
 491     $widgets(button) configure \
 492             -highlightthickness 0 \
 493             -borderwidth 1 \
 494             -relief raised \
 495             -width [expr {[winfo reqwidth $widgets(vsb)] - 2}]
 496
 497     $widgets(entry) configure \
 498             -borderwidth 0 \
 499             -relief flat \
 500             -highlightthickness 0
 501
 502     $widgets(popup) configure \
 503             -borderwidth 1 \
 504             -relief sunken
 505
 506     $widgets(listbox) configure \
 507             -selectmode browse \
 508             -background [$widgets(entry) cget -bg] \
 509             -yscrollcommand "$widgets(vsb) set" \
 510             -exportselection false \
 511             -borderwidth 0
 512
 513
 514 #    trace variable ::combobox::${w}::entryTextVariable w \
 515 #           [list ::combobox::EntryTrace $w]
 516
 517     # do some window management foo on the dropdown window
 518     wm overrideredirect $widgets(popup) 1
 519     wm transient        $widgets(popup) [winfo toplevel $w]
 520     wm group            $widgets(popup) [winfo parent $w]
 521     wm resizable        $widgets(popup) 0 0
 522     wm withdraw         $widgets(popup)
 523
 524     # this moves the original frame widget proc into our
 525     # namespace and gives it a handy name
 526     rename ::$w $widgets(frame)
 527
 528     # now, create our widget proc. Obviously (?) it goes in
 529     # the global namespace. All combobox widgets will actually
 530     # share the same widget proc to cut down on the amount of
 531     # bloat.
 532     proc ::$w {command args} \
 533             "eval ::combobox::WidgetProc $w \$command \$args"
 534
 535
 536     # ok, the thing exists... let's do a bit more configuration.
 537     if {[catch "::combobox::Configure $widgets(this) [array get options]" error]} {
 538         catch {destroy $w}
 539         error $error
 540     }
 541
 542     return ""
 543
 544 }
 545
 546 # ::combobox::HandleEvent --
 547 #
 548 #    this proc handles events from the entry widget that we want
 549 #    handled specially (typically, to allow navigation of the list
 550 #    even though the focus is in the entry widget)
 551 #
 552 # Arguments:
 553 #
 554 #    w       widget pathname
 555 #    event   a string representing the event (not necessarily an
 556 #            actual event)
 557
 558 proc ::combobox::HandleEvent {w event} {
 559     upvar ::combobox::${w}::widgets  widgets
 560     upvar ::combobox::${w}::options  options
 561     upvar ::combobox::${w}::oldValue oldValue
 562
 563     # for all of these events, if we have a special action we'll
 564     # do that and do a "return -code break" to keep additional
 565     # bindings from firing. Otherwise we'll let the event fall
 566     # on through.
 567     switch $event {
 568
 569         "<Any-KeyPress>" {
 570             # if the widget is editable, clear the selection.
 571             # this makes it more obvious what will happen if the
 572             # user presses <Return> (and helps our code know what
 573             # to do if the user presses return)
 574             if {$options(-editable)} {
 575                 $widgets(listbox) see 0
 576                 $widgets(listbox) selection clear 0 end
 577                 $widgets(listbox) selection anchor 0
 578                 $widgets(listbox) activate 0
 579             }
 580         }
 581
 582         "<FocusIn>" {
 583             set oldValue [$widgets(entry) get]
 584         }
 585
 586         "<FocusOut>" {
 587             if {![winfo ismapped $widgets(popup)]} {
 588                 # did the value change?
 589 #               set newValue [set ::combobox::${w}::entryTextVariable]
 590                 set newValue [$widgets(entry) get]
 591                 if {$oldValue != $newValue} {
 592                     CallCommand $widgets(this) $newValue
 593                 }
 594             }
 595         }
 596
 597         "<1>" {
 598             set editable [::combobox::GetBoolean $options(-editable)]
 599             if {!$editable} {
 600                 if {[winfo ismapped $widgets(popup)]} {
 601                     $widgets(this) close
 602                     return -code break;
 603
 604                 } else {
 605                     if {$options(-state) != "disabled"} {
 606                         $widgets(this) open
 607                         return -code break;
 608                     }
 609                 }
 610             }
 611         }
 612
 613         "<Double-1>" {
 614             if {$options(-state) != "disabled"} {
 615                 $widgets(this) toggle
 616                 return -code break;
 617             }
 618         }
 619
 620         "<Tab>" {
 621             if {[winfo ismapped $widgets(popup)]} {
 622                 ::combobox::Find $widgets(this) 0
 623                 return -code break;
 624             } else {
 625                 ::combobox::SetValue $widgets(this) [$widgets(this) get]
 626             }
 627         }
 628
 629         "<Escape>" {
 630 #           $widgets(entry) delete 0 end
 631 #           $widgets(entry) insert 0 $oldValue
 632             if {[winfo ismapped $widgets(popup)]} {
 633                 $widgets(this) close
 634                 return -code break;
 635             }
 636         }
 637
 638         "<Return>" {
 639             # did the value change?
 640 #           set newValue [set ::combobox::${w}::entryTextVariable]
 641             set newValue [$widgets(entry) get]
 642             if {$oldValue != $newValue} {
 643                 CallCommand $widgets(this) $newValue
 644             }
 645
 646             if {[winfo ismapped $widgets(popup)]} {
 647                 ::combobox::Select $widgets(this) \
 648                         [$widgets(listbox) curselection]
 649                 return -code break;
 650             }
 651
 652         }
 653
 654         "<Next>" {
 655             $widgets(listbox) yview scroll 1 pages
 656             set index [$widgets(listbox) index @0,0]
 657             $widgets(listbox) see $index
 658             $widgets(listbox) activate $index
 659             $widgets(listbox) selection clear 0 end
 660             $widgets(listbox) selection anchor $index
 661             $widgets(listbox) selection set $index
 662
 663         }
 664
 665         "<Prior>" {
 666             $widgets(listbox) yview scroll -1 pages
 667             set index [$widgets(listbox) index @0,0]
 668             $widgets(listbox) activate $index
 669             $widgets(listbox) see $index
 670             $widgets(listbox) selection clear 0 end
 671             $widgets(listbox) selection anchor $index
 672             $widgets(listbox) selection set $index
 673         }
 674
 675         "<Down>" {
 676             if {[winfo ismapped $widgets(popup)]} {
 677                 tkListboxUpDown $widgets(listbox) 1
 678                 return -code break;
 679
 680             } else {
 681                 if {$options(-state) != "disabled"} {
 682                     $widgets(this) open
 683                     return -code break;
 684                 }
 685             }
 686         }
 687         "<Up>" {
 688             if {[winfo ismapped $widgets(popup)]} {
 689                 tkListboxUpDown $widgets(listbox) -1
 690                 return -code break;
 691
 692             } else {
 693                 if {$options(-state) != "disabled"} {
 694                     $widgets(this) open
 695                     return -code break;
 696                 }
 697             }
 698         }
 699     }
 700
 701     return ""
 702 }
 703
 704 # ::combobox::DestroyHandler {w} --
 705 #
 706 #    Cleans up after a combobox widget is destroyed
 707 #
 708 # Arguments:
 709 #
 710 #    w    widget pathname
 711 #
 712 # Results:
 713 #
 714 #    The namespace that was created for the widget is deleted,
 715 #    and the widget proc is removed.
 716
 717 proc ::combobox::DestroyHandler {w} {
 718
 719     # if the widget actually being destroyed is of class Combobox,
 720     # crush the namespace and kill the proc. Get it? Crush. Kill.
 721     # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
 722     # brings tears to my eyes.
 723     if {[string compare [winfo class $w] "Combobox"] == 0} {
 724         upvar ::combobox::${w}::widgets  widgets
 725         upvar ::combobox::${w}::options  options
 726
 727         # delete the namespace and the proc which represents
 728         # our widget
 729         namespace delete ::combobox::$w
 730         rename $w {}
 731     }
 732
 733     return ""
 734 }
 735
 736 # ::combobox::Find
 737 #
 738 #    finds something in the listbox that matches the pattern in the
 739 #    entry widget and selects it
 740 #
 741 #    N.B. I'm not convinced this is working the way it ought to. It
 742 #    works, but is the behavior what is expected? I've also got a gut
 743 #    feeling that there's a better way to do this, but I'm too lazy to
 744 #    figure it out...
 745 #
 746 # Arguments:
 747 #
 748 #    w      widget pathname
 749 #    exact  boolean; if true an exact match is desired
 750 #
 751 # Returns:
 752 #
 753 #    Empty string
 754
 755 proc ::combobox::Find {w {exact 0}} {
 756     upvar ::combobox::${w}::widgets widgets
 757     upvar ::combobox::${w}::options options
 758
 759     ## *sigh* this logic is rather gross and convoluted. Surely
 760     ## there is a more simple, straight-forward way to implement
 761     ## all this. As the saying goes, I lack the time to make it
 762     ## shorter...
 763
 764     # use what is already in the entry widget as a pattern
 765     set pattern [$widgets(entry) get]
 766
 767     if {[string length $pattern] == 0} {
 768         # clear the current selection
 769         $widgets(listbox) see 0
 770         $widgets(listbox) selection clear 0 end
 771         $widgets(listbox) selection anchor 0
 772         $widgets(listbox) activate 0
 773         return
 774     }
 775
 776     # we're going to be searching this list...
 777     set list [$widgets(listbox) get 0 end]
 778
 779     # if we are doing an exact match, try to find,
 780     # well, an exact match
 781     set exactMatch -1
 782     if {$exact} {
 783         set exactMatch [lsearch -exact $list $pattern]
 784     }
 785
 786     # search for it. We'll try to be clever and not only
 787     # search for a match for what they typed, but a match for
 788     # something close to what they typed. We'll keep removing one
 789     # character at a time from the pattern until we find a match
 790     # of some sort.
 791     set index -1
 792     while {$index == -1 && [string length $pattern]} {
 793         set index [lsearch -glob $list "$pattern*"]
 794         if {$index == -1} {
 795             regsub {.$} $pattern {} pattern
 796         }
 797     }
 798
 799     # this is the item that most closely matches...
 800     set thisItem [lindex $list $index]
 801
 802     # did we find a match? If so, do some additional munging...
 803     if {$index != -1} {
 804
 805         # we need to find the part of the first item that is
 806         # unique WRT the second... I know there's probably a
 807         # simpler way to do this...
 808
 809         set nextIndex [expr {$index + 1}]
 810         set nextItem [lindex $list $nextIndex]
 811
 812         # we don't really need to do much if the next
 813         # item doesn't match our pattern...
 814         if {[string match $pattern* $nextItem]} {
 815             # ok, the next item matches our pattern, too
 816             # now the trick is to find the first character
 817             # where they *don't* match...
 818             set marker [string length $pattern]
 819             while {$marker <= [string length $pattern]} {
 820                 set a [string index $thisItem $marker]
 821                 set b [string index $nextItem $marker]
 822                 if {[string compare $a $b] == 0} {
 823                     append pattern $a
 824                     incr marker
 825                 } else {
 826                     break
 827                 }
 828             }
 829         } else {
 830             set marker [string length $pattern]
 831         }
 832
 833     } else {
 834         set marker end
 835         set index 0
 836     }
 837
 838     # ok, we know the pattern and what part is unique;
 839     # update the entry widget and listbox appropriately
 840     if {$exact && $exactMatch == -1} {
 841         # this means we didn't find an exact match
 842         $widgets(listbox) selection clear 0 end
 843         $widgets(listbox) see $index
 844
 845     } elseif {!$exact}  {
 846         # this means we found something, but it isn't an exact
 847         # match. If we find something that *is* an exact match we
 848         # don't need to do the following, since it would merely
 849         # be replacing the data in the entry widget with itself
 850         set oldstate [$widgets(entry) cget -state]
 851         $widgets(entry) configure -state normal
 852         $widgets(entry) delete 0 end
 853         $widgets(entry) insert end $thisItem
 854         $widgets(entry) selection clear
 855         $widgets(entry) selection range $marker end
 856         $widgets(listbox) activate $index
 857         $widgets(listbox) selection clear 0 end
 858         $widgets(listbox) selection anchor $index
 859         $widgets(listbox) selection set $index
 860         $widgets(listbox) see $index
 861         $widgets(entry) configure -state $oldstate
 862     }
 863 }
 864
 865 # ::combobox::Select --
 866 #
 867 #    selects an item from the list and sets the value of the combobox
 868 #    to that value
 869 #
 870 # Arguments:
 871 #
 872 #    w      widget pathname
 873 #    index  listbox index of item to be selected
 874 #
 875 # Returns:
 876 #
 877 #    empty string
 878
 879 proc ::combobox::Select {w index} {
 880     upvar ::combobox::${w}::widgets widgets
 881     upvar ::combobox::${w}::options options
 882
 883     catch {
 884         set data [$widgets(listbox) get [lindex $index 0]]
 885         ::combobox::SetValue $widgets(this) $data
 886
 887         $widgets(listbox) selection clear 0 end
 888         $widgets(listbox) selection anchor $index
 889         $widgets(listbox) selection set $index
 890
 891         $widgets(entry) selection range 0 end
 892     }
 893
 894     $widgets(this) close
 895
 896     return ""
 897 }
 898
 899 # ::combobox::HandleScrollbar --
 900 #
 901 #    causes the scrollbar of the dropdown list to appear or disappear
 902 #    based on the contents of the dropdown listbox
 903 #
 904 # Arguments:
 905 #
 906 #    w       widget pathname
 907 #    action  the action to perform on the scrollbar
 908 #
 909 # Returns:
 910 #
 911 #    an empty string
 912
 913 proc ::combobox::HandleScrollbar {w {action "unknown"}} {
 914     upvar ::combobox::${w}::widgets widgets
 915     upvar ::combobox::${w}::options options
 916
 917     if {$options(-height) == 0} {
 918         set hlimit $options(-maxheight)
 919     } else {
 920         set hlimit $options(-height)
 921     }
 922
 923     switch $action {
 924         "grow" {
 925             if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
 926                 pack $widgets(vsb) -side right -fill y -expand n
 927             }
 928         }
 929
 930         "shrink" {
 931             if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} {
 932                 pack forget $widgets(vsb)
 933             }
 934         }
 935
 936         "crop" {
 937             # this means the window was cropped and we definitely
 938             # need a scrollbar no matter what the user wants
 939             pack $widgets(vsb) -side right -fill y -expand n
 940         }
 941
 942         default {
 943             if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
 944                 pack $widgets(vsb) -side right -fill y -expand n
 945             } else {
 946                 pack forget $widgets(vsb)
 947             }
 948         }
 949     }
 950
 951     return ""
 952 }
 953
 954 # ::combobox::ComputeGeometry --
 955 #
 956 #    computes the geometry of the popup list based on the size of the
 957 #    combobox...
 958 #
 959 # Arguments:
 960 #
 961 #    w     widget pathname
 962 #
 963 # Returns:
 964 #
 965 #    the desired geometry of the listbox
 966
 967 proc ::combobox::ComputeGeometry {w} {
 968     upvar ::combobox::${w}::widgets widgets
 969     upvar ::combobox::${w}::options options
 970
 971     if {$options(-height) == 0 && $options(-maxheight) != "0"} {
 972         # if this is the case, count the items and see if
 973         # it exceeds our maxheight. If so, set the listbox
 974         # size to maxheight...
 975         set nitems [$widgets(listbox) size]
 976         if {$nitems > $options(-maxheight)} {
 977             # tweak the height of the listbox
 978             $widgets(listbox) configure -height $options(-maxheight)
 979         } else {
 980             # un-tweak the height of the listbox
 981             $widgets(listbox) configure -height 0
 982         }
 983         update idletasks
 984     }
 985
 986     # compute height and width of the dropdown list
 987     set bd [$widgets(popup) cget -borderwidth]
 988     set height [expr {[winfo reqheight $widgets(popup)] + $bd + $bd}]
 989     set width [winfo width $widgets(this)]
 990
 991     # figure out where to place it on the screen, trying to take into
 992     # account we may be running under some virtual window manager
 993     set screenWidth  [winfo screenwidth $widgets(this)]
 994     set screenHeight [winfo screenheight $widgets(this)]
 995     set rootx        [winfo rootx $widgets(this)]
 996     set rooty        [winfo rooty $widgets(this)]
 997     set vrootx       [winfo vrootx $widgets(this)]
 998     set vrooty       [winfo vrooty $widgets(this)]
 999
1000     # the x coordinate is simply the rootx of our widget, adjusted for
1001     # the virtual window. We won't worry about whether the window will
1002     # be offscreen to the left or right -- we want the illusion that it
1003     # is part of the entry widget, so if part of the entry widget is off-
1004     # screen, so will the list. If you want to change the behavior,
1005     # simply change the if statement... (and be sure to update this
1006     # comment!)
1007     set x  [expr {$rootx + $vrootx}]
1008     if {0} {
1009         set rightEdge [expr {$x + $width}]
1010         if {$rightEdge > $screenWidth} {
1011             set x [expr {$screenWidth - $width}]
1012         }
1013         if {$x < 0} {set x 0}
1014     }
1015
1016     # the y coordinate is the rooty plus vrooty offset plus
1017     # the height of the static part of the widget plus 1 for a
1018     # tiny bit of visual separation...
1019     set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}]
1020     set bottomEdge [expr {$y + $height}]
1021
1022     if {$bottomEdge >= $screenHeight} {
1023         # ok. Fine. Pop it up above the entry widget isntead of
1024         # below.
1025         set y [expr {($rooty - $height - 1) + $vrooty}]
1026
1027         if {$y < 0} {
1028             # this means it extends beyond our screen. How annoying.
1029             # Now we'll try to be real clever and either pop it up or
1030             # down, depending on which way gives us the biggest list.
1031             # then, we'll trim the list to fit and force the use of
1032             # a scrollbar
1033
1034             # (sadly, for windows users this measurement doesn't
1035             # take into consideration the height of the taskbar,
1036             # but don't blame me -- there isn't any way to detect
1037             # it or figure out its dimensions. The same probably
1038             # applies to any window manager with some magic windows
1039             # glued to the top or bottom of the screen)
1040
1041             if {$rooty > [expr {$screenHeight / 2}]} {
1042                 # we are in the lower half of the screen --
1043                 # pop it up. Y is zero; that parts easy. The height
1044                 # is simply the y coordinate of our widget, minus
1045                 # a pixel for some visual separation. The y coordinate
1046                 # will be the topof the screen.
1047                 set y 1
1048                 set height [expr {$rooty - 1 - $y}]
1049
1050             } else {
1051                 # we are in the upper half of the screen --
1052                 # pop it down
1053                 set y [expr {$rooty + $vrooty + \
1054                         [winfo reqheight $widgets(this)] + 1}]
1055                 set height [expr {$screenHeight - $y}]
1056
1057             }
1058
1059             # force a scrollbar
1060             HandleScrollbar $widgets(this) crop
1061         }
1062     }
1063
1064     if {$y < 0} {
1065         # hmmm. Bummer.
1066         set y 0
1067         set height $screenheight
1068     }
1069
1070     set geometry [format "=%dx%d+%d+%d" $width $height $x $y]
1071
1072     return $geometry
1073 }
1074
1075 # ::combobox::DoInternalWidgetCommand --
1076 #
1077 #    perform an internal widget command, then mung any error results
1078 #    to look like it came from our megawidget. A lot of work just to
1079 #    give the illusion that our megawidget is an atomic widget
1080 #
1081 # Arguments:
1082 #
1083 #    w           widget pathname
1084 #    subwidget   pathname of the subwidget
1085 #    command     subwidget command to be executed
1086 #    args        arguments to the command
1087 #
1088 # Returns:
1089 #
1090 #    The result of the subwidget command, or an error
1091
1092 proc ::combobox::DoInternalWidgetCommand {w subwidget command args} {
1093     upvar ::combobox::${w}::widgets widgets
1094     upvar ::combobox::${w}::options options
1095
1096     set subcommand $command
1097     set command [concat $widgets($subwidget) $command $args]
1098     if {[catch $command result]} {
1099         # replace the subwidget name with the megawidget name
1100         regsub $widgets($subwidget) $result $widgets(this) result
1101
1102         # replace specific instances of the subwidget command
1103         # with out megawidget command
1104         switch $subwidget,$subcommand {
1105             listbox,index  {regsub "index"  $result "list index"  result}
1106             listbox,insert {regsub "insert" $result "list insert" result}
1107             listbox,delete {regsub "delete" $result "list delete" result}
1108             listbox,get    {regsub "get"    $result "list get"    result}
1109             listbox,size   {regsub "size"   $result "list size"   result}
1110         }
1111         error $result
1112
1113     } else {
1114         return $result
1115     }
1116 }
1117
1118
1119 # ::combobox::WidgetProc --
1120 #
1121 #    This gets uses as the widgetproc for an combobox widget.
1122 #    Notice where the widget is created and you'll see that the
1123 #    actual widget proc merely evals this proc with all of the
1124 #    arguments intact.
1125 #
1126 #    Note that some widget commands are defined "inline" (ie:
1127 #    within this proc), and some do most of their work in
1128 #    separate procs. This is merely because sometimes it was
1129 #    easier to do it one way or the other.
1130 #
1131 # Arguments:
1132 #
1133 #    w         widget pathname
1134 #    command   widget subcommand
1135 #    args      additional arguments; varies with the subcommand
1136 #
1137 # Results:
1138 #
1139 #    Performs the requested widget command
1140
1141 proc ::combobox::WidgetProc {w command args} {
1142     upvar ::combobox::${w}::widgets widgets
1143     upvar ::combobox::${w}::options options
1144     upvar ::combobox::${w}::oldFocus oldFocus
1145     upvar ::combobox::${w}::oldFocus oldGrab
1146
1147     set command [::combobox::Canonize $w command $command]
1148
1149     # this is just shorthand notation...
1150     set doWidgetCommand \
1151             [list ::combobox::DoInternalWidgetCommand $widgets(this)]
1152
1153     if {$command == "list"} {
1154         # ok, the next argument is a list command; we'll
1155         # rip it from args and append it to command to
1156         # create a unique internal command
1157         #
1158         # NB: because of the sloppy way we are doing this,
1159         # we'll also let the user enter our secret command
1160         # directly (eg: listinsert, listdelete), but we
1161         # won't document that fact
1162         set command "list-[lindex $args 0]"
1163         set args [lrange $args 1 end]
1164     }
1165
1166     set result ""
1167
1168     # many of these commands are just synonyms for specific
1169     # commands in one of the subwidgets. We'll get them out
1170     # of the way first, then do the custom commands.
1171     switch $command {
1172         bbox -
1173         delete -
1174         get -
1175         icursor -
1176         index -
1177         insert -
1178         scan -
1179         selection -
1180         xview {
1181             set result [eval $doWidgetCommand entry $command $args]
1182         }
1183         list-get        {set result [eval $doWidgetCommand listbox get $args]}
1184         list-index      {set result [eval $doWidgetCommand listbox index $args]}
1185         list-size       {set result [eval $doWidgetCommand listbox size $args]}
1186
1187         select {
1188             if {[llength $args] == 1} {
1189                 set index [lindex $args 0]
1190                 set result [Select $widgets(this) $index]
1191             } else {
1192                 error "usage: $w select index"
1193             }
1194         }
1195
1196         subwidget {
1197             set knownWidgets [list button entry listbox popup vsb]
1198             if {[llength $args] == 0} {
1199                 return $knownWidgets
1200             }
1201
1202             set name [lindex $args 0]
1203             if {[lsearch $knownWidgets $name] != -1} {
1204                 set result $widgets($name)
1205             } else {
1206                 error "unknown subwidget $name"
1207             }
1208         }
1209
1210         curselection {
1211             set result [eval $doWidgetCommand listbox curselection]
1212         }
1213
1214         list-insert {
1215             eval $doWidgetCommand listbox insert $args
1216             set result [HandleScrollbar $w "grow"]
1217         }
1218
1219         list-delete {
1220             eval $doWidgetCommand listbox delete $args
1221             set result [HandleScrollbar $w "shrink"]
1222         }
1223
1224         toggle {
1225             # ignore this command if the widget is disabled...
1226             if {$options(-state) == "disabled"} return
1227
1228             # pops down the list if it is not, hides it
1229             # if it is...
1230             if {[winfo ismapped $widgets(popup)]} {
1231                 set result [$widgets(this) close]
1232             } else {
1233                 set result [$widgets(this) open]
1234             }
1235         }
1236
1237         open {
1238
1239             # if this is an editable combobox, the focus should
1240             # be set to the entry widget
1241             if {$options(-editable)} {
1242                 focus $widgets(entry)
1243                 $widgets(entry) select range 0 end
1244                 $widgets(entry) icur end
1245             }
1246
1247             # if we are disabled, we won't allow this to happen
1248             if {$options(-state) == "disabled"} {
1249                 return 0
1250             }
1251
1252             # compute the geometry of the window to pop up, and set
1253             # it, and force the window manager to take notice
1254             # (even if it is not presently visible).
1255             #
1256             # this isn't strictly necessary if the window is already
1257             # mapped, but we'll go ahead and set the geometry here
1258             # since its harmless and *may* actually reset the geometry
1259             # to something better in some weird case.
1260             set geometry [::combobox::ComputeGeometry $widgets(this)]
1261             wm geometry $widgets(popup) $geometry
1262             update idletasks
1263
1264             # if we are already open, there's nothing else to do
1265             if {[winfo ismapped $widgets(popup)]} {
1266                 return 0
1267             }
1268
1269             # save the widget that currently has the focus; we'll restore
1270             # the focus there when we're done
1271             set oldFocus [focus]
1272
1273             # ok, tweak the visual appearance of things and
1274             # make the list pop up
1275             $widgets(button) configure -relief sunken
1276             raise $widgets(popup) [winfo parent $widgets(this)]
1277             wm deiconify $widgets(popup)
1278
1279             # force focus to the entry widget so we can handle keypress
1280             # events for traversal
1281             focus -force $widgets(entry)
1282
1283             # select something by default, but only if its an
1284             # exact match...
1285             ::combobox::Find $widgets(this) 1
1286
1287             # save the current grab state for the display containing
1288             # this widget. We'll restore it when we close the dropdown
1289             # list
1290             set status "none"
1291             set grab [grab current $widgets(this)]
1292             if {$grab != ""} {set status [grab status $grab]}
1293             set oldGrab [list $grab $status]
1294             unset grab status
1295
1296             # *gasp* do a global grab!!! Mom always told not to
1297             # do things like this, but these are desparate times.
1298             grab -global $widgets(this)
1299
1300             # fake the listbox into thinking it has focus. This is
1301             # necessary to get scanning initialized properly in the
1302             # listbox.
1303             event generate $widgets(listbox) <B1-Enter>
1304
1305             return 1
1306         }
1307
1308         close {
1309             # if we are already closed, don't do anything...
1310             if {![winfo ismapped $widgets(popup)]} {
1311                 return 0
1312             }
1313
1314             # restore the focus and grab, but ignore any errors...
1315             # we're going to be paranoid and release the grab before
1316             # trying to set any other grab because we really really
1317             # really want to make sure the grab is released.
1318             catch {focus $oldFocus} result
1319             catch {grab release $widgets(this)}
1320             catch {
1321                 set status [lindex $oldGrab 1]
1322                 if {$status == "global"} {
1323                     grab -global [lindex $oldGrab 0]
1324                 } elseif {$status == "local"} {
1325                     grab [lindex $oldGrab 0]
1326                 }
1327                 unset status
1328             }
1329
1330             # hides the listbox
1331             $widgets(button) configure -relief raised
1332             wm withdraw $widgets(popup)
1333
1334             # select the data in the entry widget. Not sure
1335             # why, other than observation seems to suggest that's
1336             # what windows widgets do.
1337             set editable [::combobox::GetBoolean $options(-editable)]
1338             if {$editable} {
1339                 $widgets(entry) selection range 0 end
1340                 $widgets(button) configure -relief raised
1341             }
1342
1343
1344             # magic tcl stuff (see tk.tcl in the distribution
1345             # lib directory)
1346             tkCancelRepeat
1347
1348             return 1
1349         }
1350
1351         cget {
1352             if {[llength $args] != 1} {
1353                 error "wrong # args: should be $w cget option"
1354             }
1355             set opt [::combobox::Canonize $w option [lindex $args 0]]
1356
1357             if {$opt == "-value"} {
1358                 set result [$widget(entry) get]
1359             } else {
1360                 set result $options($opt)
1361             }
1362         }
1363
1364         configure {
1365             set result [eval ::combobox::Configure {$w} $args]
1366         }
1367
1368         default {
1369             error "bad option \"$command\""
1370         }
1371     }
1372
1373     return $result
1374 }
1375
1376 # ::combobox::Configure --
1377 #
1378 #    Implements the "configure" widget subcommand
1379 #
1380 # Arguments:
1381 #
1382 #    w      widget pathname
1383 #    args   zero or more option/value pairs (or a single option)
1384 #
1385 # Results:
1386 #
1387 #    Performs typcial "configure" type requests on the widget
1388
1389 proc ::combobox::Configure {w args} {
1390     variable widgetOptions
1391     variable defaultEntryCursor
1392
1393     upvar ::combobox::${w}::widgets widgets
1394     upvar ::combobox::${w}::options options
1395
1396     if {[llength $args] == 0} {
1397         # hmmm. User must be wanting all configuration information
1398         # note that if the value of an array element is of length
1399         # one it is an alias, which needs to be handled slightly
1400         # differently
1401         set results {}
1402         foreach opt [lsort [array names widgetOptions]] {
1403             if {[llength $widgetOptions($opt)] == 1} {
1404                 set alias $widgetOptions($opt)
1405                 set optName $widgetOptions($alias)
1406                 lappend results [list $opt $optName]
1407             } else {
1408                 set optName  [lindex $widgetOptions($opt) 0]
1409                 set optClass [lindex $widgetOptions($opt) 1]
1410                 set default [option get $w $optName $optClass]
1411                 lappend results [list $opt $optName $optClass \
1412                         $default $options($opt)]
1413             }
1414         }
1415
1416         return $results
1417     }
1418
1419     # one argument means we are looking for configuration
1420     # information on a single option
1421     if {[llength $args] == 1} {
1422         set opt [::combobox::Canonize $w option [lindex $args 0]]
1423
1424         set optName  [lindex $widgetOptions($opt) 0]
1425         set optClass [lindex $widgetOptions($opt) 1]
1426         set default [option get $w $optName $optClass]
1427         set results [list $opt $optName $optClass \
1428                 $default $options($opt)]
1429         return $results
1430     }
1431
1432     # if we have an odd number of values, bail.
1433     if {[expr {[llength $args]%2}] == 1} {
1434         # hmmm. An odd number of elements in args
1435         error "value for \"[lindex $args end]\" missing"
1436     }
1437
1438     # Great. An even number of options. Let's make sure they
1439     # are all valid before we do anything. Note that Canonize
1440     # will generate an error if it finds a bogus option; otherwise
1441     # it returns the canonical option name
1442     foreach {name value} $args {
1443         set name [::combobox::Canonize $w option $name]
1444         set opts($name) $value
1445     }
1446
1447     # process all of the configuration options
1448     # some (actually, most) options require us to
1449     # do something, like change the attributes of
1450     # a widget or two. Here's where we do that...
1451     foreach option [array names opts] {
1452         set newValue $opts($option)
1453         if {[info exists options($option)]} {
1454             set oldValue $options($option)
1455         }
1456
1457         switch -- $option {
1458             -background {
1459                 $widgets(frame)   configure -background $newValue
1460                 $widgets(entry)   configure -background $newValue
1461                 $widgets(listbox) configure -background $newValue
1462                 $widgets(vsb)     configure -background $newValue
1463                 $widgets(vsb)     configure -troughcolor $newValue
1464                 set options($option) $newValue
1465             }
1466
1467             -borderwidth {
1468                 $widgets(frame) configure -borderwidth $newValue
1469                 set options($option) $newValue
1470             }
1471
1472             -command {
1473                 # nothing else to do...
1474                 set options($option) $newValue
1475             }
1476
1477             -commandstate {
1478                 # do some value checking...
1479                 if {$newValue != "normal" && $newValue != "disabled"} {
1480                     set options($option) $oldValue
1481                     set message "bad state value \"$newValue\";"
1482                     append message " must be normal or disabled"
1483                     error $message
1484                 }
1485                 set options($option) $newValue
1486             }
1487
1488             -cursor {
1489                 $widgets(frame) configure -cursor $newValue
1490                 $widgets(entry) configure -cursor $newValue
1491                 $widgets(listbox) configure -cursor $newValue
1492                 set options($option) $newValue
1493             }
1494
1495             -editable {
1496                 if {$newValue} {
1497                     # it's editable...
1498                     $widgets(entry) configure \
1499                             -state normal \
1500                             -cursor $defaultEntryCursor
1501                 } else {
1502                     $widgets(entry) configure \
1503                             -state disabled \
1504                             -cursor $options(-cursor)
1505                 }
1506                 set options($option) $newValue
1507             }
1508
1509             -font {
1510                 $widgets(entry) configure -font $newValue
1511                 $widgets(listbox) configure -font $newValue
1512                 set options($option) $newValue
1513             }
1514
1515             -foreground {
1516                 $widgets(entry)   configure -foreground $newValue
1517                 $widgets(button)  configure -foreground $newValue
1518                 $widgets(listbox) configure -foreground $newValue
1519                 set options($option) $newValue
1520             }
1521
1522             -height {
1523                 $widgets(listbox) configure -height $newValue
1524                 HandleScrollbar $w
1525                 set options($option) $newValue
1526             }
1527
1528             -highlightbackground {
1529                 $widgets(frame) configure -highlightbackground $newValue
1530                 set options($option) $newValue
1531             }
1532
1533             -highlightcolor {
1534                 $widgets(frame) configure -highlightcolor $newValue
1535                 set options($option) $newValue
1536             }
1537
1538             -highlightthickness {
1539                 $widgets(frame) configure -highlightthickness $newValue
1540                 set options($option) $newValue
1541             }
1542
1543             -image {
1544                 if {[string length $newValue] > 0} {
1545                     $widgets(button) configure -image $newValue
1546                 } else {
1547                     $widgets(button) configure -image ::combobox::bimage
1548                 }
1549                 set options($option) $newValue
1550             }
1551
1552             -maxheight {
1553                 # ComputeGeometry may dork with the actual height
1554                 # of the listbox, so let's undork it
1555                 $widgets(listbox) configure -height $options(-height)
1556                 HandleScrollbar $w
1557                 set options($option) $newValue
1558             }
1559
1560             -relief {
1561                 $widgets(frame) configure -relief $newValue
1562                 set options($option) $newValue
1563             }
1564
1565             -selectbackground {
1566                 $widgets(entry) configure -selectbackground $newValue
1567                 $widgets(listbox) configure -selectbackground $newValue
1568                 set options($option) $newValue
1569             }
1570
1571             -selectborderwidth {
1572                 $widgets(entry) configure -selectborderwidth $newValue
1573                 $widgets(listbox) configure -selectborderwidth $newValue
1574                 set options($option) $newValue
1575             }
1576
1577             -selectforeground {
1578                 $widgets(entry) configure -selectforeground $newValue
1579                 $widgets(listbox) configure -selectforeground $newValue
1580                 set options($option) $newValue
1581             }
1582
1583             -state {
1584                 if {$newValue == "normal"} {
1585                     # it's enabled
1586                     set editable [::combobox::GetBoolean \
1587                             $options(-editable)]
1588                     if {$editable} {
1589                         $widgets(entry) configure -state normal
1590                         $widgets(entry) configure -takefocus 1
1591                     }
1592                 } elseif {$newValue == "disabled"}  {
1593                     # it's disabled
1594                     $widgets(entry) configure -state disabled
1595                     $widgets(entry) configure -takefocus 0
1596
1597                 } else {
1598                     set options($option) $oldValue
1599                     set message "bad state value \"$newValue\";"
1600                     append message " must be normal or disabled"
1601                     error $message
1602                 }
1603
1604                 set options($option) $newValue
1605             }
1606
1607             -takefocus {
1608                 $widgets(entry) configure -takefocus $newValue
1609                 set options($option) $newValue
1610             }
1611
1612             -textvariable {
1613                 $widgets(entry) configure -textvariable $newValue
1614                 set options($option) $newValue
1615             }
1616
1617             -value {
1618                 ::combobox::SetValue $widgets(this) $newValue
1619                 set options($option) $newValue
1620             }
1621
1622             -width {
1623                 $widgets(entry) configure -width $newValue
1624                 $widgets(listbox) configure -width $newValue
1625                 set options($option) $newValue
1626             }
1627
1628             -xscrollcommand {
1629                 $widgets(entry) configure -xscrollcommand $newValue
1630                 set options($option) $newValue
1631             }
1632
1633         }
1634     }
1635 }
1636
1637 # ::combobox::VTrace --
1638 #
1639 #    this proc is called whenever the user changes the value of
1640 #    the -textvariable associated with a widget
1641 #
1642 # Arguments:
1643 #
1644 #    w          widget pathname
1645 #    args       standard stuff from a variable trace
1646 #
1647 # Returns:
1648 #
1649 #    Empty String
1650
1651 proc ::combobox::VTrace {w args} {
1652     upvar ::combobox::${w}::widgets widgets
1653     upvar ::combobox::${w}::options options
1654     upvar ::combobox::${w}::ignoreTrace ignoreTrace
1655
1656     if {[info exists ignoreTrace]} return
1657     ::combobox::SetValue $widgets(this) [set ::$options(-textvariable)]
1658
1659     return ""
1660 }
1661
1662 # ::combobox::SetValue --
1663 #
1664 #    sets the value of the combobox and calls the -command,
1665 #    if defined
1666 #
1667 # Arguments:
1668 #
1669 #    w          widget pathname
1670 #    newValue   the new value of the combobox
1671 #
1672 # Returns
1673 #
1674 #    Empty string
1675
1676 proc ::combobox::SetValue {w newValue} {
1677
1678     upvar ::combobox::${w}::widgets     widgets
1679     upvar ::combobox::${w}::options     options
1680     upvar ::combobox::${w}::ignoreTrace ignoreTrace
1681     upvar ::combobox::${w}::oldValue    oldValue
1682
1683     if {[info exists options(-textvariable)] \
1684             && [string length $options(-textvariable)] > 0} {
1685         set variable ::$options(-textvariable)
1686         set $variable $newValue
1687     } else {
1688         set oldstate [$widgets(entry) cget -state]
1689         $widgets(entry) configure -state normal
1690         $widgets(entry) delete 0 end
1691         $widgets(entry) insert 0 $newValue
1692         $widgets(entry) configure -state $oldstate
1693     }
1694
1695     # set our internal textvariable; this will cause any public
1696     # textvariable (ie: defined by the user) to be updated as
1697     # well
1698 #    set ::combobox::${w}::entryTextVariable $newValue
1699
1700     # redefine our concept of the "old value". Do it before running
1701     # any associated command so we can be sure it happens even
1702     # if the command somehow fails.
1703     set oldValue $newValue
1704
1705
1706     # call the associated command. The proc will handle whether or
1707     # not to actually call it, and with what args
1708     CallCommand $w $newValue
1709
1710     return ""
1711 }
1712
1713 # ::combobox::CallCommand --
1714 #
1715 #   calls the associated command, if any, appending the new
1716 #   value to the command to be called.
1717 #
1718 # Arguments:
1719 #
1720 #    w         widget pathname
1721 #    newValue  the new value of the combobox
1722 #
1723 # Returns
1724 #
1725 #    empty string
1726
1727 proc ::combobox::CallCommand {w newValue} {
1728     upvar ::combobox::${w}::widgets widgets
1729     upvar ::combobox::${w}::options options
1730
1731     # call the associated command, if defined and -commandstate is
1732     # set to "normal"
1733     if {$options(-commandstate) == "normal" && \
1734             [string length $options(-command)] > 0} {
1735         set args [list $widgets(this) $newValue]
1736         uplevel \#0 $options(-command) $args
1737     }
1738 }
1739
1740
1741 # ::combobox::GetBoolean --
1742 #
1743 #     returns the value of a (presumably) boolean string (ie: it should
1744 #     do the right thing if the string is "yes", "no", "true", 1, etc
1745 #
1746 # Arguments:
1747 #
1748 #     value       value to be converted
1749 #     errorValue  a default value to be returned in case of an error
1750 #
1751 # Returns:
1752 #
1753 #     a 1 or zero, or the value of errorValue if the string isn't
1754 #     a proper boolean value
1755
1756 proc ::combobox::GetBoolean {value {errorValue 1}} {
1757     if {[catch {expr {([string trim $value])?1:0}} res]} {
1758         return $errorValue
1759     } else {
1760         return $res
1761     }
1762 }
1763
1764 # ::combobox::convert --
1765 #
1766 #     public routine to convert %x, %y and %W binding substitutions.
1767 #     Given an x, y and or %W value relative to a given widget, this
1768 #     routine will convert the values to be relative to the combobox
1769 #     widget. For example, it could be used in a binding like this:
1770 #
1771 #     bind .combobox <blah> {doSomething [::combobox::convert %W -x %x]}
1772 #
1773 #     Note that this procedure is *not* exported, but is indented for
1774 #     public use. It is not exported because the name could easily
1775 #     clash with existing commands.
1776 #
1777 # Arguments:
1778 #
1779 #     w     a widget path; typically the actual result of a %W
1780 #           substitution in a binding. It should be either a
1781 #           combobox widget or one of its subwidgets
1782 #
1783 #     args  should one or more of the following arguments or
1784 #           pairs of arguments:
1785 #
1786 #           -x <x>      will convert the value <x>; typically <x> will
1787 #                       be the result of a %x substitution
1788 #           -y <y>      will convert the value <y>; typically <y> will
1789 #                       be the result of a %y substitution
1790 #           -W (or -w)  will return the name of the combobox widget
1791 #                       which is the parent of $w
1792 #
1793 # Returns:
1794 #
1795 #     a list of the requested values. For example, a single -w will
1796 #     result in a list of one items, the name of the combobox widget.
1797 #     Supplying "-x 10 -y 20 -W" (in any order) will return a list of
1798 #     three values: the converted x and y values, and the name of
1799 #     the combobox widget.
1800
1801 proc ::combobox::convert {w args} {
1802     set result {}
1803     if {![winfo exists $w]} {
1804         error "window \"$w\" doesn't exist"
1805     }
1806
1807     while {[llength $args] > 0} {
1808         set option [lindex $args 0]
1809         set args [lrange $args 1 end]
1810
1811         switch -exact -- $option {
1812             -x {
1813                 set value [lindex $args 0]
1814                 set args [lrange $args 1 end]
1815                 set win $w
1816                 while {[winfo class $win] != "Combobox"} {
1817                     incr value [winfo x $win]
1818                     set win [winfo parent $win]
1819                     if {$win == "."} break
1820                 }
1821                 lappend result $value
1822             }
1823
1824             -y {
1825                 set value [lindex $args 0]
1826                 set args [lrange $args 1 end]
1827                 set win $w
1828                 while {[winfo class $win] != "Combobox"} {
1829                     incr value [winfo y $win]
1830                     set win [winfo parent $win]
1831                     if {$win == "."} break
1832                 }
1833                 lappend result $value
1834             }
1835
1836             -w -
1837             -W {
1838                 set win $w
1839                 while {[winfo class $win] != "Combobox"} {
1840                     set win [winfo parent $win]
1841                     if {$win == "."} break;
1842                 }
1843                 lappend result $win
1844             }
1845         }
1846     }
1847     return $result
1848 }
1849
1850 # ::combobox::Canonize --
1851 #
1852 #    takes a (possibly abbreviated) option or command name and either
1853 #    returns the canonical name or an error
1854 #
1855 # Arguments:
1856 #
1857 #    w        widget pathname
1858 #    object   type of object to canonize; must be one of "command",
1859 #             "option", "scan command" or "list command"
1860 #    opt      the option (or command) to be canonized
1861 #
1862 # Returns:
1863 #
1864 #    Returns either the canonical form of an option or command,
1865 #    or raises an error if the option or command is unknown or
1866 #    ambiguous.
1867
1868 proc ::combobox::Canonize {w object opt} {
1869     variable widgetOptions
1870     variable columnOptions
1871     variable widgetCommands
1872     variable listCommands
1873     variable scanCommands
1874
1875     switch $object {
1876         command {
1877             if {[lsearch -exact $widgetCommands $opt] >= 0} {
1878                 return $opt
1879             }
1880
1881             # command names aren't stored in an array, and there
1882             # isn't a way to get all the matches in a list, so
1883             # we'll stuff the commands in a temporary array so
1884             # we can use [array names]
1885             set list $widgetCommands
1886             foreach element $list {
1887                 set tmp($element) ""
1888             }
1889             set matches [array names tmp ${opt}*]
1890         }
1891
1892         {list command} {
1893             if {[lsearch -exact $listCommands $opt] >= 0} {
1894                 return $opt
1895             }
1896
1897             # command names aren't stored in an array, and there
1898             # isn't a way to get all the matches in a list, so
1899             # we'll stuff the commands in a temporary array so
1900             # we can use [array names]
1901             set list $listCommands
1902             foreach element $list {
1903                 set tmp($element) ""
1904             }
1905             set matches [array names tmp ${opt}*]
1906         }
1907
1908         {scan command} {
1909             if {[lsearch -exact $scanCommands $opt] >= 0} {
1910                 return $opt
1911             }
1912
1913             # command names aren't stored in an array, and there
1914             # isn't a way to get all the matches in a list, so
1915             # we'll stuff the commands in a temporary array so
1916             # we can use [array names]
1917             set list $scanCommands
1918             foreach element $list {
1919                 set tmp($element) ""
1920             }
1921             set matches [array names tmp ${opt}*]
1922         }
1923
1924         option {
1925             if {[info exists widgetOptions($opt)] \
1926                     && [llength $widgetOptions($opt)] == 2} {
1927                 return $opt
1928             }
1929             set list [array names widgetOptions]
1930             set matches [array names widgetOptions ${opt}*]
1931         }
1932
1933     }
1934
1935     if {[llength $matches] == 0} {
1936         set choices [HumanizeList $list]
1937         error "unknown $object \"$opt\"; must be one of $choices"
1938
1939     } elseif {[llength $matches] == 1} {
1940         set opt [lindex $matches 0]
1941
1942         # deal with option aliases
1943         switch $object {
1944             option {
1945                 set opt [lindex $matches 0]
1946                 if {[llength $widgetOptions($opt)] == 1} {
1947                     set opt $widgetOptions($opt)
1948                 }
1949             }
1950         }
1951
1952         return $opt
1953
1954     } else {
1955         set choices [HumanizeList $list]
1956         error "ambiguous $object \"$opt\"; must be one of $choices"
1957     }
1958 }
1959
1960 # ::combobox::HumanizeList --
1961 #
1962 #    Returns a human-readable form of a list by separating items
1963 #    by columns, but separating the last two elements with "or"
1964 #    (eg: foo, bar or baz)
1965 #
1966 # Arguments:
1967 #
1968 #    list    a valid tcl list
1969 #
1970 # Results:
1971 #
1972 #    A string which as all of the elements joined with ", " or
1973 #    the word " or "
1974
1975 proc ::combobox::HumanizeList {list} {
1976
1977     if {[llength $list] == 1} {
1978         return [lindex $list 0]
1979     } else {
1980         set list [lsort $list]
1981         set secondToLast [expr {[llength $list] -2}]
1982         set most [lrange $list 0 $secondToLast]
1983         set last [lindex $list end]
1984
1985         return "[join $most {, }] or $last"
1986     }
1987 }
1988
1989 # end of combobox.tcl