← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to Tixish/BrowseEntry.pm

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
Tixish/BrowseEntry.pm
1
1
#
2
2
# BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
 
3
#
 
4
# Some additions by Slaven Rezic <slaven@rezic.de> to make the widget
 
5
# look like the Windows' Combobox. There are also additional options.
 
6
#
3
7
 
4
8
package Tk::BrowseEntry;
5
9
 
6
10
use vars qw($VERSION);
7
 
$VERSION = '3.030'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#30 $
 
11
$VERSION = '3.033'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#33 $
8
12
 
9
13
use Tk qw(Ev);
10
14
use Carp;
11
15
use strict;
12
16
 
13
 
require Tk::Frame;
14
 
require Tk::LabEntry;
15
 
 
16
17
use base qw(Tk::Frame);
17
18
Construct Tk::Widget 'BrowseEntry';
18
19
 
 
20
require Tk::LabEntry;
 
21
 
 
22
sub LabEntryWidget { "LabEntry" }
 
23
sub ButtonWidget   { "Button"   }
 
24
sub ListboxWidget  { "Listbox"  }
 
25
 
19
26
sub Populate {
20
27
    my ($w, $args) = @_;
21
28
 
22
 
    $w->SUPER::Populate($args);
 
29
    $w->Tk::Frame::Populate($args);
23
30
 
24
31
    # entry widget and arrow button
25
32
    my $lpack = delete $args->{-labelPack};
26
33
    if (not defined $lpack) {
27
34
        $lpack = [-side => 'left', -anchor => 'e'];
28
35
    }
 
36
    $w->{_BE_Style} = delete $args->{-style} || $Tk::platform;
 
37
    my $LabEntry = $w->LabEntryWidget;
 
38
    my $Listbox  = $w->ListboxWidget;
 
39
    my $Button   = $w->ButtonWidget;
 
40
    # XXX should this be retained?
 
41
#      if (defined $args->{-state} and $args->{-state} eq 'readonly') { # XXX works only at construction time
 
42
#       $LabEntry = "NoSelLabEntry";
 
43
#       require Tk::NoSelLabEntry;
 
44
#      }
 
45
    my $e;
29
46
    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'));
 
47
    my @LabEntry_args = (-textvariable => \$var);
 
48
    if (exists $args->{-label}) {
 
49
        $e = $w->$LabEntry(-labelPack => $lpack,
 
50
                           -label => delete $args->{-label},
 
51
                           @LabEntry_args,
 
52
                          );
 
53
    } else {
 
54
        $e = $w->$LabEntry(@LabEntry_args);
 
55
    }
 
56
    my $b = $w->$Button(-bitmap => '@' . Tk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm'));
34
57
    $w->Advertise('entry' => $e);
35
58
    $w->Advertise('arrow' => $b);
36
59
    $b->pack(-side => 'right', -padx => 1);
37
 
    $e->pack(-side => 'right', -fill => 'x', -expand => 1, -padx => 1);
 
60
    $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1);
38
61
 
39
62
    # popup shell for listbox with values.
40
 
    my $c = $w->Toplevel(-bd => 2, -relief => 'raised');
 
63
    my $c = $w->Toplevel(-bd => 2,
 
64
                         -relief => ($w->{_BE_Style} eq 'MSWin32'
 
65
                                     ? "solid" : "raised"));
41
66
    $c->overrideredirect(1);
42
67
    $c->withdraw;
43
 
    my $sl = $c->Scrolled( qw/Listbox -selectmode browse -scrollbars oe/ );
 
68
    my $sl = $c->Scrolled( $Listbox, qw/-selectmode browse -scrollbars oe/ );
 
69
    if ($w->{_BE_Style} eq 'MSWin32' and $Tk::platform eq 'MSWin32') {
 
70
        $sl->configure(-bg => 'SystemWindow', -relief => "flat");
 
71
    }
44
72
    $w->Advertise('choices' => $c);
45
73
    $w->Advertise('slistbox' => $sl);
46
74
    $sl->pack(-expand => 1, -fill => 'both');
47
75
 
 
76
    $sl->Subwidget("scrolled")->bind("<Motion>",sub {
 
77
        return unless ($w->{_BE_Style} eq 'MSWin32');
 
78
        my $e = $_[0]->XEvent;
 
79
        my $y = $e->y;
 
80
        my $inx = $sl->nearest($y);
 
81
        if (defined $inx) {
 
82
            $sl->selectionClear(0, "end");
 
83
            $sl->selectionSet($inx);
 
84
        }
 
85
   });
 
86
 
48
87
    # other initializations
49
88
    $w->SetBindings;
50
 
    $w->{'popped'} = 0;
51
 
    $w->Delegates('insert' => $sl, 'delete' => $sl, get => $sl, DEFAULT => $e);
 
89
    $w->{'_BE_popped'} = 0;
 
90
    $w->Delegates(get => $sl, DEFAULT => $e);
52
91
    $w->ConfigSpecs(
53
92
        -listwidth   => [qw/PASSIVE  listWidth   ListWidth/,   undef],
 
93
        -listheight  => [{-height => $sl}, qw/listHeight ListHeight/, undef],
54
94
        -listcmd     => [qw/CALLBACK listCmd     ListCmd/,     undef],
 
95
        -autolistwidth   => [qw/PASSIVE autoListWidth AutoListWidth/, undef],
 
96
        -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/],
55
97
        -browsecmd   => [qw/CALLBACK browseCmd   BrowseCmd/,   undef],
 
98
        -browse2cmd  => [qw/CALLBACK browse2Cmd  Browse2Cmd/,  undef],
56
99
        -choices     => [qw/METHOD   choices     Choices/,     undef],
57
100
        -state       => [qw/METHOD   state       State         normal/],
58
101
        -arrowimage  => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
59
 
        -variable    => '-textvariable',
 
102
        -variable    => [ {'-textvariable' => $e} ],
60
103
        -colorstate  => [qw/PASSIVE  colorState  ColorState/,  undef],
61
104
        -command     => '-browsecmd',
62
105
        -options     => '-choices',
 
106
        -label       => [qw/PASSIVE  label       Label/,       undef],
 
107
        -labelPack   => [qw/PASSIVE  labelPack   LabelPack/,   undef],
 
108
                    #-background  => [$e, qw/background Background/,   undef],
 
109
                    #-foreground  => [$e, qw/foreground Foreground/,   undef],
 
110
        -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus',
 
111
                             'ButtonTakefocus', 1],
63
112
        DEFAULT      => [$e] );
64
113
}
65
114
 
93
142
{
94
143
 my $w = shift;
95
144
 $w->BtnDown;
96
 
 $w->{'savefocus'} = $w->focusCurrent;
 
145
 $w->{'_BE_savefocus'} = $w->focusCurrent;
97
146
 $w->Subwidget('slistbox')->focus;
98
147
}
99
148
 
117
166
    my ($w) = @_;
118
167
    return if $w->cget( '-state' ) eq 'disabled';
119
168
 
120
 
    if ($w->{'popped'}) {
 
169
    if ($w->{'_BE_popped'}) {
121
170
        $w->Popdown;
122
 
        $w->{'buttonHack'} = 0;
 
171
        $w->{'_BE_buttonHack'} = 0;
123
172
    } else {
124
173
        $w->PopupChoices;
125
 
        $w->{'buttonHack'} = 1;
 
174
        $w->{'_BE_buttonHack'} = 1;
126
175
    }
127
176
}
128
177
 
129
178
sub PopupChoices {
130
179
    my ($w) = @_;
131
180
 
132
 
    if (!$w->{'popped'}) {
133
 
       $w->Callback(-listcmd => $w);
 
181
    if (!$w->{'_BE_popped'}) {
 
182
        $w->Callback(-listcmd => $w);
134
183
        my $e = $w->Subwidget('entry');
135
184
        my $c = $w->Subwidget('choices');
136
185
        my $s = $w->Subwidget('slistbox');
137
186
        my $a = $w->Subwidget('arrow');
138
 
        my $y1 = $e->rooty + $e->height + 3;
 
187
        my $y1 = ($w->{_BE_Style} eq 'MSWin32'
 
188
                  ? $a->rooty + $a->height
 
189
                  : $e->rooty + $e->height + 3
 
190
                 );
139
191
        my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
140
 
        my $ht = $s->reqheight + 2 * $bd;
141
 
        my $x1 = $e->rootx;
 
192
        # using the real listbox reqheight rather than the
 
193
        # container frame one, which does not change after resizing the
 
194
        # listbox
 
195
        my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd;
 
196
        my $x1 = ($w->{_BE_Style} eq 'MSWin32'
 
197
                  ? $e->Subwidget("entry")->rootx
 
198
                  : $e->rootx
 
199
                 );
142
200
        my ($width, $x2);
143
201
        if (defined $w->cget(-listwidth)) {
144
202
            $width = $w->cget(-listwidth);
147
205
            $x2 = $a->rootx + $a->width;
148
206
            $width = $x2 - $x1;
149
207
        }
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;
 
208
        my $rw = $c->reqwidth;
 
209
        if ($rw < $width) {
 
210
            $rw = $width
 
211
        } else {
 
212
            if ($rw > $width * 3) {
 
213
                $rw = $width * 3;
 
214
            }
 
215
            if ($rw > $w->vrootwidth) {
 
216
                $rw = $w->vrootwidth;
 
217
            }
 
218
        }
 
219
        $width = $rw;
162
220
 
163
221
        # if listbox is too far right, pull it back to the left
164
222
        #
173
231
        }
174
232
 
175
233
        # if listbox is below bottom of screen, pull it up.
 
234
        # check the Win32 taskbar, if possible
 
235
        my $rootheight;
 
236
        if ($Tk::platform eq 'MSWin32' and $^O eq 'MSWin32') {
 
237
            eval {
 
238
                require Win32Util; # XXX should not use a non-CPAN widget
 
239
                $rootheight = (Win32Util::screen_region($w))[3];
 
240
            };
 
241
        }
 
242
        if (!defined $rootheight) {
 
243
            $rootheight = $w->vrootheight;
 
244
        }
 
245
 
176
246
        my $y2 = $y1 + $ht;
177
 
        if ($y2 > $w->vrootheight) {
 
247
        if ($y2 > $rootheight) {
178
248
            $y1 = $y1 - $ht - ($e->height - 5);
179
249
        }
180
 
 
181
250
        $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
182
251
        $c->deiconify;
183
252
        $c->raise;
184
253
        $e->focus;
185
 
        $w->{'popped'} = 1;
 
254
        $w->{'_BE_popped'} = 1;
 
255
 
 
256
        # highlight current selection
 
257
        my $current_sel = $e->get;
 
258
        if (defined $current_sel) {
 
259
            my $i = 0;
 
260
            foreach my $str ($s->get(0, "end")) {
 
261
                if ($str eq $current_sel) {
 
262
                    $s->selectionClear(0, "end");
 
263
                    $s->selectionSet($i);
 
264
                    last;
 
265
                }
 
266
                $i++;
 
267
            }
 
268
        }
186
269
 
187
270
        $c->configure(-cursor => 'arrow');
 
271
        $w->{'_BE_grabinfo'} = $w->grabSave;
188
272
        $w->grabGlobal;
189
273
    }
190
274
}
194
278
    my ($w, $x, $y) = @_;
195
279
    my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
196
280
    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;
 
281
        (($y < 0) || ($y > $l->Height))) {
 
282
        # mouse was clicked outside the listbox... close the listbox
 
283
        $w->LbClose;
200
284
    } else {
201
 
        # select appropriate entry and close the listbox
202
 
        $w->LbCopySelection;
203
 
       $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get);
 
285
        # select appropriate entry and close the listbox
 
286
        $w->LbCopySelection;
 
287
        $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get());
 
288
        $w->Callback(-browse2cmd => $w, $w->LbIndex);
204
289
    }
205
290
}
206
291
 
217
302
    my ($w) = @_;
218
303
    my $index = $w->LbIndex;
219
304
    if (defined $index) {
220
 
        $w->{'curIndex'} = $index;
 
305
        $w->{'_BE_curIndex'} = $index;
221
306
        my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
222
307
        my $var_ref = $w->cget( '-textvariable' );
223
308
        $$var_ref = $l->get($index);
224
 
        if ($w->{'popped'}) {
 
309
        if ($w->{'_BE_popped'}) {
225
310
            $w->Popdown;
226
311
        }
227
312
    }
245
330
# pop down the listbox
246
331
sub Popdown {
247
332
    my ($w) = @_;
248
 
    if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'})) {
249
 
        $w->{'savefocus'}->focus;
250
 
        delete $w->{'savefocus'};
 
333
    if ($w->{'_BE_savefocus'} && Tk::Exists($w->{'_BE_savefocus'})) {
 
334
        $w->{'_BE_savefocus'}->focus;
 
335
        delete $w->{'_BE_savefocus'};
251
336
    }
252
 
    if ($w->{'popped'}) {
 
337
    if ($w->{'_BE_popped'}) {
253
338
        my $c = $w->Subwidget('choices');
254
339
        $c->withdraw;
255
340
        $w->grabRelease;
256
 
        $w->{'popped'} = 0;
 
341
        if (ref $w->{'_BE_grabinfo'} eq 'CODE') {
 
342
            $w->{'_BE_grabinfo'}->();
 
343
            delete $w->{'_BE_grabinfo'};
 
344
        }
 
345
        $w->{'_BE_popped'} = 0;
257
346
    }
258
347
}
259
348
 
262
351
sub ButtonHack {
263
352
    my ($w) = @_;
264
353
    my $b = $w->Subwidget('arrow');
265
 
    if ($w->{'buttonHack'}) {
 
354
    if ($w->{'_BE_buttonHack'}) {
266
355
        $b->butUp;
267
356
    }
268
357
}
281
370
     $w->insert( 'end', $val);
282
371
     $hash{$val} = 1;
283
372
    }
284
 
   $old = (@$choices) ? $choices->[0] : undef unless exists $hash{$old};
 
373
   $old = $choices->[0]
 
374
    if defined $old && not exists $hash{$old} && defined $choices->[0];
285
375
   $$var = $old;
286
376
  }
287
377
 else
309
399
    if( $state eq 'readonly' ) {
310
400
        $entry->configure( -state => 'disabled' );
311
401
        $button->configure( -state => 'normal' );
 
402
        if ($w->{_BE_Style} eq 'MSWin32') {
 
403
            $entry->bind('<1>',[$w,'BtnDown']);
 
404
            $w->{_BE_OriginalCursor} = $entry->cget( -cursor );
 
405
            $entry->configure( -cursor => 'left_ptr' );
 
406
        }
312
407
    } else {
313
408
        $entry->configure( -state => $state );
 
409
        if (exists $w->{_BE_OriginalCursor}) {
 
410
            $entry->configure(-cursor => delete $w->{_BE_OriginalCursor});
 
411
        }
314
412
        $button->configure( -state => $state );
 
413
        if ($w->{_BE_Style} eq 'MSWin32') {
 
414
            $entry->bind('<1>',['Button1',Tk::Ev('x')]);
 
415
        }
315
416
    }
316
417
}
317
418
 
346
447
    $lb->configure( -width => $size );
347
448
}
348
449
 
 
450
sub limitheight {
 
451
    my $w = shift;
 
452
    my $choices_number = shift || $w->Subwidget('slistbox')->index("end");
 
453
    $choices_number = 10 if $choices_number > 10;
 
454
    $w->configure(-listheight => $choices_number) if ($choices_number > 0);
 
455
}
 
456
 
 
457
sub insert {
 
458
    my $w = shift;
 
459
    $w->Subwidget("slistbox")->insert(@_);
 
460
    if ($w->cget(-autolimitheight)) {
 
461
        $w->limitheight;
 
462
    }
 
463
    if ($w->cget(-autolistwidth)) {
 
464
        $w->updateListWidth(@_[1..$#_]);
 
465
    }
 
466
}
 
467
 
 
468
sub delete {
 
469
    my $w = shift;
 
470
    $w->Subwidget("slistbox")->delete(@_);
 
471
    if ($w->cget(-autolimitheight)) {
 
472
        $w->limitheight;
 
473
    }
 
474
    if ($w->cget(-autolistwidth)) {
 
475
        $w->updateListWidth();
 
476
    }
 
477
}
 
478
 
 
479
sub updateListWidth {
 
480
    my $w = shift;
 
481
    my @ins = @_;
 
482
    if (!@ins) {
 
483
        @ins = $w->get(0, "end");
 
484
    }
 
485
 
 
486
    my $max_width = 0;
 
487
    foreach my $ins (@ins) {
 
488
        my $new_width = $w->fontMeasure($w->cget(-font), $ins);
 
489
        if ($new_width > $max_width) {
 
490
            $max_width = $new_width;
 
491
        }
 
492
    }
 
493
    if ($max_width > 20) { # be sane
 
494
        $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar
 
495
    }
 
496
}
349
497
 
350
498
1;
351
499