OpenCores

Subversion Repositories openmsp430

[/] [openmsp430/] [trunk/] [tools/] [lib/] [tcl-lib/] [combobox.tcl] - Blame information for rev 2

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2014 OpenCores.org, equivalent to ORSoC AB, all rights reserved. OpenCores®, registered trademark.