| 1 | # |
| 2 | # The help widget that provides both "balloon" and "status bar" |
| 3 | # types of help messages. |
| 4 | |
| 5 | package Tk::Balloon; |
| 6 | |
| 7 | use vars qw($VERSION); |
| 8 | $VERSION = '3.037'; # $Id: //depot/Tk8/Tixish/Balloon.pm#37 $ |
| 9 | |
| 10 | use Tk qw(Ev Exists); |
| 11 | use Carp; |
| 12 | require Tk::Toplevel; |
| 13 | |
| 14 | Tk::Widget->Construct('Balloon'); |
| 15 | use base qw(Tk::Toplevel); |
| 16 | |
| 17 | use UNIVERSAL; |
| 18 | |
| 19 | use strict; |
| 20 | |
| 21 | my @balloons; |
| 22 | my $button_up = 0; |
| 23 | |
| 24 | sub ClassInit { |
| 25 | my ($class, $mw) = @_; |
| 26 | $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]); |
| 27 | $mw->bind('all', '<Leave>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]); |
| 28 | $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown'); |
| 29 | $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp'); |
| 30 | return $class; |
| 31 | } |
| 32 | |
| 33 | sub Populate { |
| 34 | my ($w, $args) = @_; |
| 35 | |
| 36 | $w->SUPER::Populate($args); |
| 37 | |
| 38 | $w->overrideredirect(1); |
| 39 | $w->withdraw; |
| 40 | # Only the container frame's background should be black... makes it |
| 41 | # look better. |
| 42 | $w->configure(-background => 'black'); |
| 43 | my $a = $w->Frame; |
| 44 | my $m = $w->Frame; |
| 45 | $a->configure(-bd => 0); |
| 46 | my $al = $a->Label(-bd => 0, |
| 47 | -relief => 'flat', |
| 48 | -bitmap => '@' . Tk->findINC('balArrow.xbm')); |
| 49 | $al->pack(-side => 'left', -padx => 1, -pady => 1, -anchor => 'nw'); |
| 50 | $m->configure(-bd => 0); |
| 51 | my $ml = $m->Label(-bd => 0, |
| 52 | -padx => 0, |
| 53 | -pady => 0, |
| 54 | -text => $args->{-message}); |
| 55 | $w->Advertise('message' => $ml); |
| 56 | $ml->pack(-side => 'left', |
| 57 | -anchor => 'w', |
| 58 | -expand => 1, |
| 59 | -fill => 'both', |
| 60 | -padx => 10, |
| 61 | -pady => 3); |
| 62 | $a->pack(-fill => 'both', -side => 'left'); |
| 63 | $m->pack(-fill => 'both', -side => 'left'); |
| 64 | |
| 65 | # append to global list of balloons |
| 66 | push(@balloons, $w); |
| 67 | $w->{'popped'} = 0; |
| 68 | $w->{'buttonDown'} = 0; |
| 69 | $w->{'menu_index'} = 'none'; |
| 70 | $w->{'menu_index_over'} = 'none'; |
| 71 | $w->{'canvas_tag'} = ''; |
| 72 | $w->{'canvas_tag_over'} = ''; |
| 73 | $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0], |
| 74 | -initwait => ['PASSIVE', 'initWait', 'InitWait', 350], |
| 75 | -state => ['PASSIVE', 'state', 'State', 'both'], |
| 76 | -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef], |
| 77 | -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''], |
| 78 | -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''], |
| 79 | -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'], |
| 80 | -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef], |
| 81 | -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef], |
| 82 | -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef], |
| 83 | -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'], |
| 84 | -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'], |
| 85 | -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1] |
| 86 | ); |
| 87 | } |
| 88 | |
| 89 | # attach a client to the balloon |
| 90 | sub attach { |
| 91 | my ($w, $client, %args) = @_; |
| 92 | foreach my $key (grep(/command$/,keys %args)) |
| 93 | { |
| 94 | $args{$key} = Tk::Callback->new($args{$key}); |
| 95 | } |
| 96 | my $msg = delete $args{-msg}; |
| 97 | $args{-balloonmsg} = $msg unless exists $args{-balloonmsg}; |
| 98 | $args{-statusmsg} = $msg unless exists $args{-statusmsg}; |
| 99 | $w->{'clients'}{$client} = \%args; |
| 100 | $client->OnDestroy([$w, 'detach', $client]); |
| 101 | } |
| 102 | |
| 103 | # detach a client from the balloon. |
| 104 | sub detach { |
| 105 | my ($w, $client) = @_; |
| 106 | if (Exists($w)) |
| 107 | { |
| 108 | $w->Deactivate if ($client->IS($w->{'client'})); |
| 109 | } |
| 110 | delete $w->{'clients'}{$client}; |
| 111 | } |
| 112 | |
| 113 | sub GetOption |
| 114 | { |
| 115 | my ($w,$opt,$client) = @_; |
| 116 | $client = $w->{'client'} unless defined $client; |
| 117 | if (defined $client) |
| 118 | { |
| 119 | my $info = $w->{'clients'}{$client}; |
| 120 | return $info->{$opt} if exists $info->{$opt}; |
| 121 | } |
| 122 | return $w->cget($opt); |
| 123 | } |
| 124 | |
| 125 | sub Motion { |
| 126 | my ($ewin, $x, $y, $s) = @_; |
| 127 | |
| 128 | # Don't do anything if a button is down or a grab is active |
| 129 | # 0x1f00 is (Button1Mask | .. | Button5Mask) |
| 130 | return if not defined $ewin or ((($s & 0x1f00) or $ewin->grabCurrent()) and not $ewin->isa('Tk::Menu')); |
| 131 | |
| 132 | # Find which window we are over |
| 133 | my $over = $ewin->Containing($x, $y); |
| 134 | |
| 135 | foreach my $w (@balloons) { |
| 136 | # if cursor has moved over the balloon -- ignore |
| 137 | next if defined $over and $over->toplevel eq $w; |
| 138 | |
| 139 | # find the client window that matches |
| 140 | my $client = $over; |
| 141 | while (defined $client) { |
| 142 | last if (exists $w->{'clients'}{$client}); |
| 143 | $client = $client->Parent; |
| 144 | } |
| 145 | if (defined $client) { |
| 146 | # popping up disabled -- ignore |
| 147 | my $state = $w->GetOption(-state => $client); |
| 148 | next if $state eq 'none'; |
| 149 | # Check if a button was recently released: |
| 150 | my $deactivate = 0; |
| 151 | if ($button_up) { |
| 152 | $deactivate = 1; |
| 153 | $button_up = 0; |
| 154 | } |
| 155 | # Deactivate it if the motioncommand says to: |
| 156 | my $command = $w->GetOption(-motioncommand => $client); |
| 157 | $deactivate = $command->Call($client, $x, $y) if defined $command; |
| 158 | if ($deactivate) |
| 159 | { |
| 160 | $w->Deactivate; |
| 161 | } |
| 162 | else |
| 163 | { |
| 164 | # warn "deact: $client $w->{'client'}"; |
| 165 | $w->Deactivate unless $client->IS($w->{'client'}); |
| 166 | my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg'); |
| 167 | if (defined($msg)) |
| 168 | { |
| 169 | my $delay = delete $w->{'delay'}; |
| 170 | $delay->cancel if defined $delay; |
| 171 | my $initwait = $w->GetOption(-initwait => $client); |
| 172 | $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);}); |
| 173 | $w->{'client'} = $client; |
| 174 | } |
| 175 | } |
| 176 | } else { |
| 177 | # cursor is at a position covered by a non client |
| 178 | # pop down the balloon if it is up or scheduled. |
| 179 | $w->Deactivate; |
| 180 | } |
| 181 | } |
| 182 | } |
| 183 | |
| 184 | sub ButtonDown { |
| 185 | my ($ewin) = @_; |
| 186 | |
| 187 | foreach my $w (@balloons) { |
| 188 | $w->Deactivate; |
| 189 | } |
| 190 | } |
| 191 | |
| 192 | sub ButtonUp { |
| 193 | $button_up = 1; |
| 194 | } |
| 195 | |
| 196 | # switch the balloon to a new client |
| 197 | sub SwitchToClient { |
| 198 | my ($w, $client) = @_; |
| 199 | return unless Exists($w); |
| 200 | return unless Exists($client); |
| 201 | return unless $client->IS($w->{'client'}); |
| 202 | return if $w->grabCurrent and not $client->isa('Tk::Menu'); |
| 203 | my $command = $w->GetOption(-postcommand => $client); |
| 204 | if (defined $command) { |
| 205 | # Execute the user's command and return if it returns false: |
| 206 | my $pos = $command->Call($client); |
| 207 | return if not $pos; |
| 208 | if ($pos =~ /^(\d+),(\d+)$/) { |
| 209 | # Save the returned position so the Popup method can use it: |
| 210 | $w->{'clients'}{$client}{'postposition'} = [$1, $2]; |
| 211 | } |
| 212 | } |
| 213 | my $state = $w->GetOption(-state => $client); |
| 214 | $w->Popup if ($state =~ /both|balloon/); |
| 215 | $w->SetStatus if ($state =~ /both|status/); |
| 216 | $w->{'popped'} = 1; |
| 217 | $w->{'delay'} = $w->repeat(200, ['Verify', $w, $client]); |
| 218 | } |
| 219 | |
| 220 | sub Subclient |
| 221 | { |
| 222 | my ($w,$data) = @_; |
| 223 | if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data)) |
| 224 | { |
| 225 | $w->Deactivate; |
| 226 | } |
| 227 | $w->{'subclient'} = $data; |
| 228 | } |
| 229 | |
| 230 | sub Verify { |
| 231 | my $w = shift; |
| 232 | my $client = shift; |
| 233 | my ($X,$Y) = (@_) ? @_ : ($w->pointerxy); |
| 234 | my $over = $w->Containing($X,$Y); |
| 235 | return if not defined $over or ($over->toplevel eq $w); |
| 236 | my $deactivate = # DELETE? or move it to the isa-Menu section?: |
| 237 | # ($over ne $client) or |
| 238 | not $client->IS($w->{'client'}) |
| 239 | or (!$client->isa('Tk::Menu') && $w->grabCurrent); |
| 240 | if ($deactivate) |
| 241 | { |
| 242 | $w->Deactivate; |
| 243 | } |
| 244 | else |
| 245 | { |
| 246 | $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg'); |
| 247 | } |
| 248 | } |
| 249 | |
| 250 | sub Deactivate { |
| 251 | my ($w) = @_; |
| 252 | my $delay = delete $w->{'delay'}; |
| 253 | $delay->cancel if defined $delay; |
| 254 | if ($w->{'popped'}) { |
| 255 | my $client = $w->{'client'}; |
| 256 | my $command = $w->GetOption(-cancelcommand => $client); |
| 257 | if (defined $command) { |
| 258 | # Execute the user's command and return if it returns false: |
| 259 | return if not $command->Call($client); |
| 260 | } |
| 261 | $w->withdraw; |
| 262 | $w->ClearStatus; |
| 263 | $w->{'popped'} = 0; |
| 264 | $w->{'menu_index'} = 'none'; |
| 265 | $w->{'canvas_tag'} = ''; |
| 266 | } |
| 267 | $w->{'client'} = undef; |
| 268 | $w->{'subclient'} = undef; |
| 269 | } |
| 270 | |
| 271 | sub Popup { |
| 272 | my ($w) = @_; |
| 273 | if ($w->cget(-installcolormap)) { |
| 274 | $w->colormapwindows($w->winfo('toplevel')) |
| 275 | } |
| 276 | my $client = $w->{'client'}; |
| 277 | return if not defined $client or not exists $w->{'clients'}{$client}; |
| 278 | my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg'); |
| 279 | # Dereference it if it looks like a scalar reference: |
| 280 | $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR'); |
| 281 | |
| 282 | $w->Subwidget('message')->configure(-text => $msg); |
| 283 | $w->idletasks; |
| 284 | |
| 285 | return unless Exists($w); |
| 286 | return unless Exists($client); |
| 287 | return if $msg eq ''; # Don't popup empty balloons. |
| 288 | |
| 289 | my ($x, $y); |
| 290 | my $pos = $w->GetOption(-balloonposition => $client); |
| 291 | my $postpos = delete $w->{'clients'}{$client}{'postposition'}; |
| 292 | if (defined $postpos) { |
| 293 | # The postcommand must have returned a position for the balloon - I will use that: |
| 294 | ($x, $y) = @{$postpos}; |
| 295 | } elsif ($pos eq 'mouse') { |
| 296 | $x = int($client->pointerx + 10); |
| 297 | $y = int($client->pointery + 10); |
| 298 | } elsif ($pos eq 'widget') { |
| 299 | $x = int($client->rootx + $client->width/2); |
| 300 | $y = int($client->rooty + int ($client->height/1.3)); |
| 301 | } else { |
| 302 | croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'."; |
| 303 | } |
| 304 | |
| 305 | $w->idletasks; |
| 306 | my($width, $height) = ($w->reqwidth, $w->reqheight); |
| 307 | my $xx = ($x + $width > $w->screenwidth |
| 308 | ? $w->screenwidth - $width |
| 309 | : $x); |
| 310 | my $yy = ($y + $height > $w->screenheight |
| 311 | ? $w->screenheight - $height |
| 312 | : $y); |
| 313 | |
| 314 | $w->geometry("+$xx+$yy"); |
| 315 | #$w->MoveToplevelWindow($x,$y); |
| 316 | $w->deiconify(); |
| 317 | $w->raise; |
| 318 | #$w->update; # This can cause confusion by processing more Motion events before this one has finished. |
| 319 | } |
| 320 | |
| 321 | sub SetStatus { |
| 322 | my ($w) = @_; |
| 323 | my $client = $w->{'client'}; |
| 324 | my $s = $w->GetOption(-statusbar => $client); |
| 325 | if (defined $s and $s->winfo('exists')) { |
| 326 | my $vref = $s->cget(-textvariable); |
| 327 | return if not defined $client or not exists $w->{'clients'}{$client}; |
| 328 | my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg'); |
| 329 | # Dereference it if it looks like a scalar reference: |
| 330 | $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR'); |
| 331 | if (not defined $vref) { |
| 332 | eval { $s->configure(-text => $msg); }; |
| 333 | } else { |
| 334 | $$vref = $msg; |
| 335 | } |
| 336 | } |
| 337 | } |
| 338 | |
| 339 | sub ClearStatus { |
| 340 | my ($w) = @_; |
| 341 | my $client = $w->{'client'}; |
| 342 | my $s = $w->GetOption(-statusbar => $client); |
| 343 | if (defined $s and $s->winfo('exists')) { |
| 344 | my $vref = $s->cget(-textvariable); |
| 345 | if (defined $vref) { |
| 346 | $$vref = ''; |
| 347 | } else { |
| 348 | eval { $s->configure(-text => ''); } |
| 349 | } |
| 350 | } |
| 351 | } |
| 352 | |
| 353 | sub destroy { |
| 354 | my ($w) = @_; |
| 355 | @balloons = grep($w != $_, @balloons); |
| 356 | #$w->SUPER::destroy; |
| 357 | # Above doesn't seem to work but at least I have removed it from the |
| 358 | # list of balloons and maybe undef'ing the object will get rid of it. |
| 359 | undef $w; |
| 360 | } |
| 361 | |
| 362 | 1; |
| 363 | |