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