File Coverage

blib/lib/Tcl/pTk/BrowseEntry.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             #
2             # BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
3             #
4             # Some additions by Slaven Rezic to make the widget
5             # look like the Windows' Combobox. There are also additional options.
6             #
7             #
8             # Converted to Tcl::pTk by John Cerney
9            
10             package Tcl::pTk::BrowseEntry;
11            
12             our ($VERSION) = ('0.92');
13            
14 2     2   12418 use Tcl::pTk qw(Ev);
  0            
  0            
15             use Carp;
16             use strict;
17            
18             use base qw(Tcl::pTk::Frame);
19             Construct Tcl::pTk::Widget 'BrowseEntry';
20            
21             require Tcl::pTk::LabEntry;
22            
23             sub LabEntryWidget { "LabEntry" }
24             sub ButtonWidget { "Button" }
25             sub ListboxWidget { "Listbox" }
26            
27             sub Populate {
28             my ($w, $args) = @_;
29            
30             my %labelArgs;
31             while(my($k,$v) = each %$args) {
32             $labelArgs{$k} = $v;
33             delete $args->{$k};
34             }
35            
36             $w->Tcl::pTk::Frame::Populate($args);
37            
38             while(my($k,$v) = each %labelArgs) {
39             $args->{$k} = $v;
40             }
41            
42             # entry widget and arrow button
43             my $lpack = delete $args->{-labelPack};
44             if (not defined $lpack) {
45             $lpack = [-side => 'left', -anchor => 'e'];
46             }
47             $w->{_BE_Style} = delete $args->{-style} || $Tcl::pTk::platform;
48             my $LabEntry = $w->LabEntryWidget;
49             my $Listbox = $w->ListboxWidget;
50             my $Button = $w->ButtonWidget;
51             # XXX should this be retained?
52             # if (defined $args->{-state} and $args->{-state} eq 'readonly') { # XXX works only at construction time
53             # $LabEntry = "NoSelLabEntry";
54             # require Tk::NoSelLabEntry;
55             # }
56             my $e;
57             my $var = "";
58             my @LabEntry_args = (-textvariable => \$var);
59             if (exists $args->{-label}) {
60             $e = $w->$LabEntry(-labelPack => $lpack,
61             -label => delete $args->{-label},
62             @LabEntry_args,
63             );
64             } else {
65             $e = $w->$LabEntry(@LabEntry_args);
66             }
67             my $b = $w->$Button(-bitmap => '@' . Tcl::pTk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm'));
68             $w->Advertise('entry' => $e);
69             $w->Advertise('arrow' => $b);
70            
71             # Pack the button to align vertically with the entry widget
72             my @anch;
73             my $edge = {@$lpack}->{-side};
74             push(@anch,-anchor => 's') if ($edge && $edge eq 'top');
75             push(@anch,-anchor => 'n') if ($edge && $edge eq 'bottom');
76             $b->pack(-side => 'right', -padx => 1, @anch);
77            
78             $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1);
79            
80             # popup shell for listbox with values.
81             my $c = $w->Toplevel(-bd => 2,
82             -relief => ($w->{_BE_Style} eq 'MSWin32'
83             ? "solid" : "raised"));
84             $c->overrideredirect(1);
85             $c->withdraw;
86             my $sl = $c->Scrolled( $Listbox, qw/-selectmode browse -scrollbars oe/ );
87             if ($w->{_BE_Style} eq 'MSWin32' and $Tcl::pTk::platform eq 'MSWin32') {
88             $sl->configure(-bg => 'SystemWindow', -relief => "flat");
89             }
90             $w->Advertise('choices' => $c);
91             $w->Advertise('slistbox' => $sl);
92             $sl->pack(-expand => 1, -fill => 'both');
93            
94             $sl->Subwidget("scrolled")->bind("",[sub {
95             return unless ($w->{_BE_Style} eq 'MSWin32');
96             my $widget = shift;
97             my $y = shift;
98             my $inx = $sl->nearest($y);
99             if (defined $inx) {
100             $sl->selectionClear(0, "end");
101             $sl->selectionSet($inx);
102             }
103             },Ev('y')]
104             );
105            
106             # other initializations
107             $w->SetBindings;
108             $w->{'_BE_popped'} = 0;
109             $w->Delegates(get => $sl, DEFAULT => $e);
110             $w->ConfigSpecs(
111             -font => [qw/DESCENDANTS font Font/],
112             -listwidth => [qw/PASSIVE listWidth ListWidth/, undef],
113             -listheight => [{-height => $sl}, qw/listHeight ListHeight/, undef],
114             -listcmd => [qw/CALLBACK listCmd ListCmd/, undef],
115             -autolistwidth => [qw/PASSIVE autoListWidth AutoListWidth/, undef],
116             -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/],
117             -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef],
118             -browse2cmd => [qw/CALLBACK browse2Cmd Browse2Cmd/, undef],
119             -choices => [qw/METHOD choices Choices/, undef],
120             -state => [qw/METHOD state State normal/],
121             -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
122             -variable => [ {'-textvariable' => $e} ],
123             -colorstate => [qw/PASSIVE colorState ColorState/, undef],
124             -command => '-browsecmd',
125             -options => '-choices',
126             -label => [qw/PASSIVE label Label/, undef],
127             -labelPack => [qw/PASSIVE labelPack LabelPack/, undef],
128             #-background => [$e, qw/background Background/, undef],
129             #-foreground => [$e, qw/foreground Foreground/, undef],
130             -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus',
131             'ButtonTakefocus', 1],
132             DEFAULT => [$e] );
133             }
134            
135             sub SetBindings {
136             my ($w) = @_;
137            
138             my $e = $w->Subwidget('entry');
139             my $b = $w->Subwidget('arrow');
140            
141             # set bind tags
142             $w->bindtags([$w, 'Tcl::pTk::BrowseEntry', $w->toplevel, 'all']);
143             # as we don't bind $e here leave its tags alone ...
144             # $e->bindtags([$e, ref($e), $e->toplevel, 'all']);
145            
146             # bindings for the button and entry
147             $b->bind('<1>',[$w,'BtnDown']);
148             $b->toplevel->bind('',[$w,'ButtonHack']);
149             $b->bind('',[$w,'space']);
150            
151             # bindings for listbox
152             my $sl = $w->Subwidget('slistbox');
153             my $l = $sl->Subwidget('listbox');
154             $l->bind('',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
155             $l->bind('' => [$w,'LbClose']);
156             $l->bind('' => [$w,'Return',$l]);
157            
158             # allow click outside the popped up listbox to pop it down.
159             $w->bind('<1>','BtnDown');
160             }
161            
162             sub space
163             {
164             my $w = shift;
165             $w->BtnDown;
166             $w->{'_BE_savefocus'} = $w->focusCurrent;
167             $w->Subwidget('slistbox')->focus;
168             }
169            
170            
171             sub ListboxRelease
172             {
173             my ($w,$x,$y) = @_;
174             $w->ButtonHack;
175             $w->LbChoose($x, $y);
176             }
177            
178             sub Return
179             {
180             my ($w,$l) = @_;
181             my($x, $y) = $l->bbox($l->curselection);
182             $w->LbChoose($x, $y)
183             }
184            
185            
186             sub BtnDown {
187             my ($w) = @_;
188             return if $w->cget( '-state' ) eq 'disabled';
189            
190             if ($w->{'_BE_popped'}) {
191             $w->Popdown;
192             $w->{'_BE_buttonHack'} = 0;
193             } else {
194             $w->PopupChoices;
195             $w->{'_BE_buttonHack'} = 1;
196             }
197             }
198            
199             sub PopupChoices {
200             my ($w) = @_;
201            
202             if (!$w->{'_BE_popped'}) {
203             $w->Callback(-listcmd => $w);
204             my $e = $w->Subwidget('entry');
205             my $c = $w->Subwidget('choices');
206             my $s = $w->Subwidget('slistbox');
207             my $a = $w->Subwidget('arrow');
208             my $y1 = ($w->{_BE_Style} eq 'MSWin32'
209             ? $a->rooty + $a->height
210             : $e->rooty + $e->height + 3
211             );
212             my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
213             # using the real listbox reqheight rather than the
214             # container frame one, which does not change after resizing the
215             # listbox
216             my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd;
217             my $x1 = ($w->{_BE_Style} eq 'MSWin32'
218             ? $e->Subwidget("entry")->rootx
219             : $e->rootx
220             );
221             my ($width, $x2);
222             if (defined $w->cget(-listwidth)) {
223             $width = $w->cget(-listwidth);
224             $x2 = $x1 + $width;
225             } else {
226             $x2 = $a->rootx + $a->width;
227             $width = $x2 - $x1;
228             }
229             my $rw = $c->reqwidth;
230             if ($rw < $width) {
231             $rw = $width
232             } else {
233             if ($rw > $width * 3) {
234             $rw = $width * 3;
235             }
236             if ($rw > $w->vrootwidth) {
237             $rw = $w->vrootwidth;
238             }
239             }
240             $width = $rw;
241            
242             # if listbox is too far right, pull it back to the left
243             #
244             if ($x2 > $w->vrootwidth) {
245             $x1 = $w->vrootwidth - $width;
246             }
247            
248             # if listbox is too far left, pull it back to the right
249             #
250             if ($x1 < 0) {
251             $x1 = 0;
252             }
253            
254             # if listbox is below bottom of screen, pull it up.
255             # check the Win32 taskbar, if possible
256             my $rootheight;
257             if ($Tcl::pTk::platform eq 'MSWin32' and $^O eq 'MSWin32') {
258             eval {
259             require Win32Util; # XXX should not use a non-CPAN widget
260             $rootheight = (Win32Util::screen_region($w))[3];
261             };
262             }
263             if (!defined $rootheight) {
264             $rootheight = $w->vrootheight;
265             }
266            
267             my $y2 = $y1 + $ht;
268             if ($y2 > $rootheight) {
269             $y1 = $y1 - $ht - ($e->height - 5);
270             }
271             $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
272             $c->deiconify;
273             $c->raise;
274             $e->focus;
275             $w->{'_BE_popped'} = 1;
276            
277             # highlight current selection
278             my $current_sel = $e->get;
279             if (defined $current_sel) {
280             my $i = 0;
281             foreach my $str ($s->get(0, "end")) {
282             local $^W = 0; # in case of undefined strings
283             if ($str eq $current_sel) {
284             $s->selectionClear(0, "end");
285             $s->selectionSet($i);
286             last;
287             }
288             $i++;
289             }
290             }
291            
292             $c->configure(-cursor => 'arrow');
293             $w->{'_BE_grabinfo'} = $w->grabSave;
294             eval{ $w->grabGlobal; }; # sometimes will fail (if another mainwindow has been ->Busy'ed. But is ok to fail
295             # in these cases.
296             }
297             }
298            
299             # choose value from listbox if appropriate
300             sub LbChoose {
301             my ($w, $x, $y) = @_;
302             my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
303             if ((($x < 0) || ($x > $l->width)) ||
304             (($y < 0) || ($y > $l->height))) {
305             # mouse was clicked outside the listbox... close the listbox
306             $w->LbClose;
307             } else {
308             # select appropriate entry and close the listbox
309             $w->LbCopySelection;
310             $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get());
311             $w->Callback(-browse2cmd => $w, $w->LbIndex);
312             }
313             }
314            
315             # close the listbox after clearing selection
316             sub LbClose {
317             my ($w) = @_;
318             my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
319             $l->selection('clear', 0, 'end');
320             $w->Popdown;
321             }
322            
323             # copy the selection to the entry and close listbox
324             sub LbCopySelection {
325             my ($w) = @_;
326             my $index = $w->LbIndex;
327             if (defined $index) {
328             $w->{'_BE_curIndex'} = $index;
329             my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
330             my $var_ref = $w->cget( '-textvariable' );
331             $$var_ref = $l->get($index);
332             if ($w->{'_BE_popped'}) {
333             $w->Popdown;
334             }
335             }
336             $w->Popdown;
337             }
338            
339             sub LbIndex {
340             my ($w, $flag) = @_;
341             my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
342             if (defined $sel) {
343             return int($sel);
344             } else {
345             if (defined $flag && ($flag eq 'emptyOK')) {
346             return undef;
347             } else {
348             return 0;
349             }
350             }
351             }
352            
353             # pop down the listbox
354             sub Popdown {
355             my ($w) = @_;
356             if ($w->{'_BE_savefocus'} && Tcl::pTk::Exists($w->{'_BE_savefocus'})) {
357             $w->{'_BE_savefocus'}->focus;
358             delete $w->{'_BE_savefocus'};
359             }
360             if ($w->{'_BE_popped'}) {
361             my $c = $w->Subwidget('choices');
362             $c->withdraw;
363             $w->grabRelease;
364             if (ref $w->{'_BE_grabinfo'} eq 'CODE') {
365             $w->{'_BE_grabinfo'}->();
366             delete $w->{'_BE_grabinfo'};
367             }
368             $w->{'_BE_popped'} = 0;
369             }
370             }
371            
372             # This hack is to prevent the ugliness of the arrow being depressed.
373             #
374             sub ButtonHack {
375             my ($w) = @_;
376             my $b = $w->Subwidget('arrow');
377             if ($w->{'_BE_buttonHack'}) {
378             #$b->butUp; # This function not available for Tcl::pTk
379             }
380             }
381            
382             sub choices
383             {
384             my ($w,$choices) = @_;
385             if (@_ > 1)
386             {
387             $w->delete( qw/0 end/ );
388             my %hash;
389             my $var = $w->cget('-textvariable');
390             my $old = $$var;
391             foreach my $val (@$choices)
392             {
393             local $^W = 0; # in case of undefined values
394             $w->insert( 'end', $val);
395             $hash{$val} = 1;
396             }
397             $old = $choices->[0]
398             if defined $old && !exists $hash{$old} && defined $choices->[0];
399             $$var = defined($old) ? $old : '';
400             }
401             else
402             {
403             return( $w->get( qw/0 end/ ) );
404             }
405             }
406            
407             sub _set_edit_state {
408             my( $w, $state ) = @_;
409            
410             my $entry = $w->Subwidget( 'entry' );
411             my $button = $w->Subwidget( 'arrow' );
412            
413             if ($w->cget( '-colorstate' )) {
414             my $color;
415             if( $state eq 'normal' ) { # Editable
416             $color = 'gray95';
417             } else { # Not Editable
418             $color = $w->cget( -background ) || 'lightgray';
419             }
420             $entry->Subwidget( 'entry' )->configure( -background => $color );
421             }
422            
423             if( $state eq 'readonly' ) {
424             $entry->configure( -state => 'disabled' );
425             $button->configure( -state => 'normal' );
426             if ($w->{_BE_Style} eq 'MSWin32') {
427             $entry->bind('<1>',[$w,'BtnDown']);
428             $w->{_BE_OriginalCursor} = $entry->cget( -cursor );
429             $entry->configure( -cursor => 'left_ptr' );
430             }
431             } else {
432             $entry->configure( -state => $state );
433             if (exists $w->{_BE_OriginalCursor}) {
434             $entry->configure(-cursor => delete $w->{_BE_OriginalCursor});
435             }
436             $button->configure( -state => $state );
437             # Button1 method of Entry isn't there in Tcl::pTk Is it really needed?
438             #if ($w->{_BE_Style} eq 'MSWin32') {
439             # $entry->bind('<1>',['Button1',Ev('x')]);
440             #}
441             }
442             }
443            
444             sub state {
445             my $w = shift;
446             unless( @_ ) {
447             return( $w->{Configure}{-state} );
448             } else {
449             my $state = shift;
450             $w->{Configure}{-state} = $state;
451             $w->_set_edit_state( $state );
452             }
453             }
454            
455             sub _max {
456             my $max = shift;
457             foreach my $val (@_) {
458             $max = $val if $max < $val;
459             }
460             return( $max );
461             }
462            
463             sub shrinkwrap {
464             my( $w, $size ) = @_;
465            
466             unless( defined $size ) {
467             $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
468             }
469            
470             my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
471             $w->configure( -width => $size );
472             $lb->configure( -width => $size );
473             }
474            
475             sub limitheight {
476             my $w = shift;
477             my $choices_number = shift || $w->Subwidget('slistbox')->index("end");
478             $choices_number = 10 if $choices_number > 10;
479             $w->configure(-listheight => $choices_number) if ($choices_number > 0);
480             }
481            
482             sub insert {
483             my $w = shift;
484             $w->Subwidget("slistbox")->insert(@_);
485             if ($w->cget(-autolimitheight)) {
486             $w->limitheight;
487             }
488             if ($w->cget(-autolistwidth)) {
489             $w->updateListWidth(@_[1..$#_]);
490             }
491             }
492            
493             sub delete {
494             my $w = shift;
495             $w->Subwidget("slistbox")->delete(@_);
496             if ($w->cget(-autolimitheight)) {
497             $w->limitheight;
498             }
499             if ($w->cget(-autolistwidth)) {
500             $w->updateListWidth();
501             }
502             }
503            
504             sub updateListWidth {
505             my $w = shift;
506             my @ins = @_;
507             if (!@ins) {
508             @ins = $w->get(0, "end");
509             }
510            
511             my $max_width = 0;
512             foreach my $ins (@ins) {
513             my $new_width = $w->fontMeasure($w->cget(-font), $ins);
514             if ($new_width > $max_width) {
515             $max_width = $new_width;
516             }
517             }
518             if ($max_width > 20) { # be sane
519             $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar
520             }
521             }
522            
523             1;
524            
525             __END__