Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # |
2 | # BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0 | |
3 | ||
4 | package Tk::BrowseEntry; | |
5 | ||
6 | use vars qw($VERSION); | |
7 | $VERSION = '3.030'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#30 $ | |
8 | ||
9 | use Tk qw(Ev); | |
10 | use Carp; | |
11 | use strict; | |
12 | ||
13 | require Tk::Frame; | |
14 | require Tk::LabEntry; | |
15 | ||
16 | use base qw(Tk::Frame); | |
17 | Construct Tk::Widget 'BrowseEntry'; | |
18 | ||
19 | sub Populate { | |
20 | my ($w, $args) = @_; | |
21 | ||
22 | $w->SUPER::Populate($args); | |
23 | ||
24 | # entry widget and arrow button | |
25 | my $lpack = delete $args->{-labelPack}; | |
26 | if (not defined $lpack) { | |
27 | $lpack = [-side => 'left', -anchor => 'e']; | |
28 | } | |
29 | my $var = ""; | |
30 | my $e = $w->LabEntry(-labelPack => $lpack, | |
31 | -label => delete $args->{-label}, | |
32 | -textvariable => \$var,); | |
33 | my $b = $w->Button(-bitmap => '@' . Tk->findINC('cbxarrow.xbm')); | |
34 | $w->Advertise('entry' => $e); | |
35 | $w->Advertise('arrow' => $b); | |
36 | $b->pack(-side => 'right', -padx => 1); | |
37 | $e->pack(-side => 'right', -fill => 'x', -expand => 1, -padx => 1); | |
38 | ||
39 | # popup shell for listbox with values. | |
40 | my $c = $w->Toplevel(-bd => 2, -relief => 'raised'); | |
41 | $c->overrideredirect(1); | |
42 | $c->withdraw; | |
43 | my $sl = $c->Scrolled( qw/Listbox -selectmode browse -scrollbars oe/ ); | |
44 | $w->Advertise('choices' => $c); | |
45 | $w->Advertise('slistbox' => $sl); | |
46 | $sl->pack(-expand => 1, -fill => 'both'); | |
47 | ||
48 | # other initializations | |
49 | $w->SetBindings; | |
50 | $w->{'popped'} = 0; | |
51 | $w->Delegates('insert' => $sl, 'delete' => $sl, get => $sl, DEFAULT => $e); | |
52 | $w->ConfigSpecs( | |
53 | -listwidth => [qw/PASSIVE listWidth ListWidth/, undef], | |
54 | -listcmd => [qw/CALLBACK listCmd ListCmd/, undef], | |
55 | -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef], | |
56 | -choices => [qw/METHOD choices Choices/, undef], | |
57 | -state => [qw/METHOD state State normal/], | |
58 | -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef], | |
59 | -variable => '-textvariable', | |
60 | -colorstate => [qw/PASSIVE colorState ColorState/, undef], | |
61 | -command => '-browsecmd', | |
62 | -options => '-choices', | |
63 | DEFAULT => [$e] ); | |
64 | } | |
65 | ||
66 | sub SetBindings { | |
67 | my ($w) = @_; | |
68 | ||
69 | my $e = $w->Subwidget('entry'); | |
70 | my $b = $w->Subwidget('arrow'); | |
71 | ||
72 | # set bind tags | |
73 | $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']); | |
74 | $e->bindtags([$e, $e->toplevel, 'all']); | |
75 | ||
76 | # bindings for the button and entry | |
77 | $b->bind('<1>',[$w,'BtnDown']); | |
78 | $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']); | |
79 | $b->bind('<space>',[$w,'space']); | |
80 | ||
81 | # bindings for listbox | |
82 | my $sl = $w->Subwidget('slistbox'); | |
83 | my $l = $sl->Subwidget('listbox'); | |
84 | $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]); | |
85 | $l->bind('<Escape>' => [$w,'LbClose']); | |
86 | $l->bind('<Return>' => [$w,'Return',$l]); | |
87 | ||
88 | # allow click outside the popped up listbox to pop it down. | |
89 | $w->bind('<1>','BtnDown'); | |
90 | } | |
91 | ||
92 | sub space | |
93 | { | |
94 | my $w = shift; | |
95 | $w->BtnDown; | |
96 | $w->{'savefocus'} = $w->focusCurrent; | |
97 | $w->Subwidget('slistbox')->focus; | |
98 | } | |
99 | ||
100 | ||
101 | sub ListboxRelease | |
102 | { | |
103 | my ($w,$x,$y) = @_; | |
104 | $w->ButtonHack; | |
105 | $w->LbChoose($x, $y); | |
106 | } | |
107 | ||
108 | sub Return | |
109 | { | |
110 | my ($w,$l) = @_; | |
111 | my($x, $y) = $l->bbox($l->curselection); | |
112 | $w->LbChoose($x, $y) | |
113 | } | |
114 | ||
115 | ||
116 | sub BtnDown { | |
117 | my ($w) = @_; | |
118 | return if $w->cget( '-state' ) eq 'disabled'; | |
119 | ||
120 | if ($w->{'popped'}) { | |
121 | $w->Popdown; | |
122 | $w->{'buttonHack'} = 0; | |
123 | } else { | |
124 | $w->PopupChoices; | |
125 | $w->{'buttonHack'} = 1; | |
126 | } | |
127 | } | |
128 | ||
129 | sub PopupChoices { | |
130 | my ($w) = @_; | |
131 | ||
132 | if (!$w->{'popped'}) { | |
133 | $w->Callback(-listcmd => $w); | |
134 | my $e = $w->Subwidget('entry'); | |
135 | my $c = $w->Subwidget('choices'); | |
136 | my $s = $w->Subwidget('slistbox'); | |
137 | my $a = $w->Subwidget('arrow'); | |
138 | my $y1 = $e->rooty + $e->height + 3; | |
139 | my $bd = $c->cget(-bd) + $c->cget(-highlightthickness); | |
140 | my $ht = $s->reqheight + 2 * $bd; | |
141 | my $x1 = $e->rootx; | |
142 | my ($width, $x2); | |
143 | if (defined $w->cget(-listwidth)) { | |
144 | $width = $w->cget(-listwidth); | |
145 | $x2 = $x1 + $width; | |
146 | } else { | |
147 | $x2 = $a->rootx + $a->width; | |
148 | $width = $x2 - $x1; | |
149 | } | |
150 | my $rw = $c->reqwidth; | |
151 | if ($rw < $width) { | |
152 | $rw = $width | |
153 | } else { | |
154 | if ($rw > $width * 3) { | |
155 | $rw = $width * 3; | |
156 | } | |
157 | if ($rw > $w->vrootwidth) { | |
158 | $rw = $w->vrootwidth; | |
159 | } | |
160 | } | |
161 | $width = $rw; | |
162 | ||
163 | # if listbox is too far right, pull it back to the left | |
164 | # | |
165 | if ($x2 > $w->vrootwidth) { | |
166 | $x1 = $w->vrootwidth - $width; | |
167 | } | |
168 | ||
169 | # if listbox is too far left, pull it back to the right | |
170 | # | |
171 | if ($x1 < 0) { | |
172 | $x1 = 0; | |
173 | } | |
174 | ||
175 | # if listbox is below bottom of screen, pull it up. | |
176 | my $y2 = $y1 + $ht; | |
177 | if ($y2 > $w->vrootheight) { | |
178 | $y1 = $y1 - $ht - ($e->height - 5); | |
179 | } | |
180 | ||
181 | $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1)); | |
182 | $c->deiconify; | |
183 | $c->raise; | |
184 | $e->focus; | |
185 | $w->{'popped'} = 1; | |
186 | ||
187 | $c->configure(-cursor => 'arrow'); | |
188 | $w->grabGlobal; | |
189 | } | |
190 | } | |
191 | ||
192 | # choose value from listbox if appropriate | |
193 | sub LbChoose { | |
194 | my ($w, $x, $y) = @_; | |
195 | my $l = $w->Subwidget('slistbox')->Subwidget('listbox'); | |
196 | if ((($x < 0) || ($x > $l->Width)) || | |
197 | (($y < 0) || ($y > $l->Height))) { | |
198 | # mouse was clicked outside the listbox... close the listbox | |
199 | $w->LbClose; | |
200 | } else { | |
201 | # select appropriate entry and close the listbox | |
202 | $w->LbCopySelection; | |
203 | $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get); | |
204 | } | |
205 | } | |
206 | ||
207 | # close the listbox after clearing selection | |
208 | sub LbClose { | |
209 | my ($w) = @_; | |
210 | my $l = $w->Subwidget('slistbox')->Subwidget('listbox'); | |
211 | $l->selection('clear', 0, 'end'); | |
212 | $w->Popdown; | |
213 | } | |
214 | ||
215 | # copy the selection to the entry and close listbox | |
216 | sub LbCopySelection { | |
217 | my ($w) = @_; | |
218 | my $index = $w->LbIndex; | |
219 | if (defined $index) { | |
220 | $w->{'curIndex'} = $index; | |
221 | my $l = $w->Subwidget('slistbox')->Subwidget('listbox'); | |
222 | my $var_ref = $w->cget( '-textvariable' ); | |
223 | $$var_ref = $l->get($index); | |
224 | if ($w->{'popped'}) { | |
225 | $w->Popdown; | |
226 | } | |
227 | } | |
228 | $w->Popdown; | |
229 | } | |
230 | ||
231 | sub LbIndex { | |
232 | my ($w, $flag) = @_; | |
233 | my $sel = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection; | |
234 | if (defined $sel) { | |
235 | return int($sel); | |
236 | } else { | |
237 | if (defined $flag && ($flag eq 'emptyOK')) { | |
238 | return undef; | |
239 | } else { | |
240 | return 0; | |
241 | } | |
242 | } | |
243 | } | |
244 | ||
245 | # pop down the listbox | |
246 | sub Popdown { | |
247 | my ($w) = @_; | |
248 | if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'})) { | |
249 | $w->{'savefocus'}->focus; | |
250 | delete $w->{'savefocus'}; | |
251 | } | |
252 | if ($w->{'popped'}) { | |
253 | my $c = $w->Subwidget('choices'); | |
254 | $c->withdraw; | |
255 | $w->grabRelease; | |
256 | $w->{'popped'} = 0; | |
257 | } | |
258 | } | |
259 | ||
260 | # This hack is to prevent the ugliness of the arrow being depressed. | |
261 | # | |
262 | sub ButtonHack { | |
263 | my ($w) = @_; | |
264 | my $b = $w->Subwidget('arrow'); | |
265 | if ($w->{'buttonHack'}) { | |
266 | $b->butUp; | |
267 | } | |
268 | } | |
269 | ||
270 | sub choices | |
271 | { | |
272 | my ($w,$choices) = @_; | |
273 | if (@_ > 1) | |
274 | { | |
275 | $w->delete( qw/0 end/ ); | |
276 | my %hash; | |
277 | my $var = $w->cget('-textvariable'); | |
278 | my $old = $$var; | |
279 | foreach my $val (@$choices) | |
280 | { | |
281 | $w->insert( 'end', $val); | |
282 | $hash{$val} = 1; | |
283 | } | |
284 | $old = (@$choices) ? $choices->[0] : undef unless exists $hash{$old}; | |
285 | $$var = $old; | |
286 | } | |
287 | else | |
288 | { | |
289 | return( $w->get( qw/0 end/ ) ); | |
290 | } | |
291 | } | |
292 | ||
293 | sub _set_edit_state { | |
294 | my( $w, $state ) = @_; | |
295 | ||
296 | my $entry = $w->Subwidget( 'entry' ); | |
297 | my $button = $w->Subwidget( 'arrow' ); | |
298 | ||
299 | if ($w->cget( '-colorstate' )) { | |
300 | my $color; | |
301 | if( $state eq 'normal' ) { # Editable | |
302 | $color = 'gray95'; | |
303 | } else { # Not Editable | |
304 | $color = $w->cget( -background ) || 'lightgray'; | |
305 | } | |
306 | $entry->Subwidget( 'entry' )->configure( -background => $color ); | |
307 | } | |
308 | ||
309 | if( $state eq 'readonly' ) { | |
310 | $entry->configure( -state => 'disabled' ); | |
311 | $button->configure( -state => 'normal' ); | |
312 | } else { | |
313 | $entry->configure( -state => $state ); | |
314 | $button->configure( -state => $state ); | |
315 | } | |
316 | } | |
317 | ||
318 | sub state { | |
319 | my $w = shift; | |
320 | unless( @_ ) { | |
321 | return( $w->{Configure}{-state} ); | |
322 | } else { | |
323 | my $state = shift; | |
324 | $w->{Configure}{-state} = $state; | |
325 | $w->_set_edit_state( $state ); | |
326 | } | |
327 | } | |
328 | ||
329 | sub _max { | |
330 | my $max = shift; | |
331 | foreach my $val (@_) { | |
332 | $max = $val if $max < $val; | |
333 | } | |
334 | return( $max ); | |
335 | } | |
336 | ||
337 | sub shrinkwrap { | |
338 | my( $w, $size ) = @_; | |
339 | ||
340 | unless( defined $size ) { | |
341 | $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;; | |
342 | } | |
343 | ||
344 | my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' ); | |
345 | $w->configure( -width => $size ); | |
346 | $lb->configure( -width => $size ); | |
347 | } | |
348 | ||
349 | ||
350 | 1; | |
351 | ||
352 | __END__ | |
353 |