1
2
3package Tk::MenuEntry;
4
5use Tk qw(Ev);
6use strict;
7use vars qw(@ISA $VERSION);
8
9@ISA = qw(Tk::Derived Tk::Frame);
10$VERSION = "0.02";
11
12Construct Tk::Widget 'MenuEntry';
13
14my $BITMAP;
15
16sub ClassInit {
17    my($class,$mw) = @_;
18
19    unless(defined($BITMAP)) {
20	$BITMAP = __PACKAGE__ . "::downarrow";
21
22	my $bits = pack("b12"x5,".1111111111.",
23				"..11111111..",
24				"...111111...",
25				"....1111....",
26				".....11.....");
27
28	$mw->DefineBitmap($BITMAP => 12,5, $bits);
29    }
30}
31
32sub Populate {
33    my($me,$args) = @_;
34
35    $me->SUPER::Populate($args);
36
37    my $sf = $me->Frame;
38
39    my $b = $sf->Button(
40	-bitmap => $BITMAP,
41	-anchor => 'center',
42	-highlightthickness => 0,
43    )->pack(-fill => 'both', -expand => 1);
44
45    $me->Advertise(Button => $b);
46
47    $sf->packPropagate(0);
48    $sf->GeometryRequest($b->ReqWidth + 2,1);
49    $sf->pack(-side => 'right', -fill => 'y');
50
51    my $e = $me->Entry(
52	-borderwidth => 0,
53	-highlightthickness => 0,
54    )->pack(
55	-side => 'left',
56	-fill => 'both',
57	-expand => 1
58    );
59
60    # popup shell for listbox with values.
61    my $c = $me->Toplevel(-bd => 2,-relief => "raised");
62    $c->overrideredirect(1);
63    $c->withdraw;
64    my $sl = $c->ScrlListbox(
65	-scrollbars => 'oe',
66	-selectmode => "browse",
67	-exportselection => 0,
68	-bd => 0,
69	-width => 0,
70	-highlightthickness => 0,
71	-relief => "raised"
72    )->pack(
73	-expand => 1,
74	-fill => "both"
75    );
76
77    $me->Advertise(Popup => $c);
78    $me->Advertise(Listbox => $sl);
79
80    $b->bind('<1>', [ $me, 'ButtonDown']);
81
82    $b->bind('<ButtonRelease-1>', [$me, 'ButtonUp', $b]);
83    $me->bind('<ButtonRelease-1>', [$me, 'ButtonUp', $me]);
84
85    $sl = $sl->Subwidget('scrolled');
86
87    $sl->bind('<ButtonRelease-1>', [$me, 'ButtonUp', $sl, Ev('index',Ev('@'))]);
88
89    $me->ConfigSpecs(
90	-background  => [SELF => qw(background  Background),  "#d9d9d9"],
91	-borderwidth => [SELF => qw(borderWidth BorderWidth), 2],
92	-relief	     => [SELF => qw(relief      Relief),      'sunken'],
93	-highlightthickness
94		     => [SELF => qw(highlightThickness HighlightThickness),2],
95	-maxlines    => [PASSIVE => qw(maxLines MaxLines), 10],
96	-menucreate  => [CALLBACK => undef, undef, undef],
97    );
98
99    $me->Default(Entry => $e);
100
101    $me;
102}
103
104sub ButtonDown {
105    my ($me) = @_;
106
107    return
108	if ($me->cget(-state) =~ /disabled/);
109
110    my $tl = $me->Subwidget('Popup');
111    if ($tl->ismapped) {
112	$me->Unpost;
113    } else {
114	$me->Post;
115    }
116}
117
118sub ButtonUp {
119    my ($me,$where,$index) = @_;
120
121    return
122	if ($me->cget(-state) =~ /disabled/);
123
124    my $tl = $me->Subwidget('Popup');
125
126    if ($tl->ismapped) {
127	if($where->isa('Tk::Button')) {
128	    my $lb = $me->Subwidget("Listbox");
129
130	    $lb->selectionClear(0,'end');
131	    $lb->selectionSet(0);
132	}
133	else {
134	    if($where->isa('Tk::Listbox')) {
135		my $sel = $where->get($index);
136		my $e = $me->Subwidget('Entry');
137		$e->delete(0,'end');
138		$e->insert(0,$sel);
139	    }
140	    $me->Unpost;
141	}
142    }
143}
144
145sub listInsert	{ shift->Subwidget('Listbox')->insert(@_) }
146sub listGet	{ shift->Subwidget('Listbox')->get(@_)	  }
147sub listDelete	{ shift->Subwidget('Listbox')->delete(@_) }
148
149sub Unpost {
150    my ($me) = @_;
151    my $tl = $me->Subwidget('Popup');
152
153    if ($tl->ismapped) {
154	$tl->withdraw;
155	$me->grabRelease;
156	$me->Subwidget('Button')->butUp;
157    }
158}
159
160sub Post {
161    my ($me) = @_;
162    my $tl = $me->Subwidget('Popup');
163
164    unless($tl->ismapped) {
165	my $mc = $me->{Configure}{-menucreate};
166
167	$mc->Call($me)
168	    if defined $mc;
169
170	my $lb = $me->Subwidget("Listbox");
171	my $x = $me->rootx;
172        my $y = $me->rooty + $me->height;
173	my $size = $lb->size;
174	my $msize = $me->{Configure}{-maxlines};
175
176	$size = $msize
177	    if $size > $msize;
178	$size = 1
179	    if(($size = int($size)) < 1);
180
181	$lb->configure(-height => $size);
182	# Scrolled turns propagate off, but I need it on
183	$lb->Tk::pack('propagate',1);
184	$lb->update;
185
186	$x = 0
187	    if $x < 0;
188	$y = 0
189	    if $y < 0;
190
191	my $vw = $me->vrootwidth;
192	my $rw = $tl->ReqWidth;
193	my $w = $me->rootx + $me->width - $x;
194
195	$w = $rw
196	    if $rw > $w;
197	$x =  $vw - $w
198	    if(($x + $w) > $vw);
199
200	my $vh = $me->vrootheight;
201	my $h = $tl->ReqHeight;
202
203	$y = $vh - $h
204	    if(($y + $h) > $vh);
205
206	$tl->geometry(
207	    sprintf("%dx%d+%d+%d",$w, $h, $x, $y)
208	);
209
210	$tl->deiconify;
211	$tl->raise;
212
213	$me->Subwidget("Entry")->focus;
214
215	$tl->configure(-cursor => "arrow");
216
217	$lb->selectionClear(0);
218	$lb->yview('moveto',0);
219	$me->grabGlobal;
220    }
221}
222
2231;
224