Project

General

Profile

Statistics
| Branch: | Revision:

root / src / tkenv / combobox.tcl @ e1750c09

History | View | Annotate | Download (62.8 KB)

1 01873262 Georg Kunz
# 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 __combobox_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 $__combobox_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