"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/Tixish/Balloon.pm" (23 Feb 2020, 21199 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Balloon.pm" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 804.034_vs_804.035.

    1 #
    2 # The help widget that provides both "balloon" and "status bar"
    3 # types of help messages.
    4 #
    5 # This is a patched version of Balloon 3.037 - it adds support
    6 # for different orientations of the balloon widget, depending
    7 # on whether there's enough space for it. The little arrow now
    8 # should always point directly to the client.
    9 # Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com)
   10 #
   11 # Nov 1, 2003 - Jack Dunnigan
   12 # Added support for more than one screen in single logical
   13 # screen mode (i.e. xinerama, dual monitors)
   14 
   15 package Tk::Balloon;
   16 
   17 use vars qw($VERSION);
   18 $VERSION = '4.013'; # was: sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
   19 
   20 use Tk qw(Ev Exists);
   21 use Carp;
   22 require Tk::Toplevel;
   23 
   24 Tk::Widget->Construct('Balloon');
   25 use base qw(Tk::Toplevel);
   26 
   27 # use UNIVERSAL; avoid the UNIVERSAL.pm file subs are XS in perl core
   28 
   29 use strict;
   30 
   31 my @balloons;
   32 my $button_up = 0;
   33 my %arrows = ( TL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAINjA0HAEdwLCwMKIQfBQA7',
   34            TR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIRBGMDwAEQkgAIAAoCABEEuwAAOw==',
   35            BR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPDOHHhYVRAIgIAEISQLELADs=',
   36            BL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPhB1xAUFALCIMKAaAWQAVADs=',
   37            NO => 'R0lGODlhAQABAJEAANnZ2f///////////yH5BAEAAAAALAAAAAABAAEAAAICRAEAOw=='
   38          );
   39 
   40 
   41 sub ClassInit {
   42     my ($class, $mw) = @_;
   43     $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
   44     $mw->bind('all', '<Leave>',  ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
   45     $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown');
   46     $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp');
   47     return $class;
   48 }
   49 
   50 sub Populate {
   51     my ($w, $args) = @_;
   52 
   53     $w->SUPER::Populate($args);
   54 
   55     $w->overrideredirect(1);
   56     $w->withdraw;
   57     # Only the container frame's background should be black... makes it
   58     # look better.
   59     $w->configure(-background => 'black');
   60 
   61     # the balloon arrows
   62     $w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif');
   63     $w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif');
   64     $w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif');
   65     $w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif');
   66     $w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif');
   67     $w->OnDestroy([$w, '_destroyed']);
   68 
   69     $w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no});
   70 
   71     # the balloon message
   72     # We give the Label a big borderwidth
   73     # ..enough to slide a 6x6 gif image along the border including some space
   74 
   75     my $ml = $w->Label(-bd => 0,
   76                 -padx => 10,
   77                 -pady => 3,
   78                 -justify => 'left',
   79                 -relief=>'flat');
   80     $w->Advertise('message' => $ml);
   81 
   82     $ml->pack(
   83         -side => 'top',
   84         -anchor => 'nw',
   85         -expand => 1,
   86         -fill => 'both',
   87         -padx => 0,
   88         -pady => 0);
   89 
   90     # append to global list of balloons
   91     push(@balloons, $w);
   92     $w->{'popped'} = 0;
   93     $w->{'buttonDown'} = 0;
   94     $w->{'menu_index'} = 'none';
   95     $w->{'menu_index_over'} = 'none';
   96     $w->{'canvas_tag'} = '';
   97     $w->{'canvas_tag_over'} = '';
   98     $w->{'current_screen'} = 0;
   99 
  100     $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0],
  101             -initwait => ['PASSIVE', 'initWait', 'InitWait', 350],
  102             -state => ['PASSIVE', 'state', 'State', 'both'],
  103             -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef],
  104             -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''],
  105             -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''],
  106             -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'],
  107             -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef],
  108             -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef],
  109             -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef],
  110             -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'],
  111                     -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef],
  112             -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],
  113             -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1],
  114                     -numscreens=>['PASSIVE', 'numScreens','NumScreens',1],
  115            );
  116 }
  117 
  118 sub _get_client {
  119     my ($w, $client) = @_;
  120     if ($client->can("Subwidget") and my $scrolled = $client->Subwidget("scrolled")) {
  121         $scrolled;
  122     } else {
  123     $client;
  124     }
  125 }
  126 
  127 # attach a client to the balloon
  128 sub attach {
  129     my ($w, $client, %args) = @_;
  130     $client = $w->_get_client($client);
  131     foreach my $key (grep(/command$/,keys %args))
  132      {
  133       $args{$key} = Tk::Callback->new($args{$key});
  134      }
  135     my $msg = delete $args{-msg};
  136     $args{-balloonmsg} = $msg unless exists $args{-balloonmsg};
  137     $args{-statusmsg}  = $msg unless exists $args{-statusmsg};
  138     $w->{'clients'}{$client} = \%args;
  139     $client->OnDestroy([$w, 'detach', $client]);
  140 }
  141 
  142 # detach a client from the balloon.
  143 sub detach {
  144     my ($w, $client) = @_;
  145     $client = $w->_get_client($client);
  146     if (Exists($w))
  147      {
  148       $w->Deactivate if ($client->IS($w->{'client'}));
  149      }
  150     delete $w->{'clients'}{$client};
  151 }
  152 
  153 sub GetOption
  154 {
  155  my ($w,$opt,$client) = @_;
  156  $client = $w->{'client'} unless defined $client;
  157  if (defined $client)
  158   {
  159    my $info = $w->{'clients'}{$client};
  160    return $info->{$opt} if exists $info->{$opt};
  161   }
  162  return $w->cget($opt);
  163 }
  164 
  165 sub Motion {
  166     my ($ewin, $x, $y, $s) = @_;
  167 
  168     return if not defined $ewin;
  169 
  170     # Find which window we are over
  171     my $over = $ewin->Containing($x, $y);
  172 
  173     return if &grabBad($ewin, $over);
  174 
  175     foreach my $w (@balloons) {
  176     # if cursor has moved over the balloon -- ignore
  177     next if defined $over and $over->toplevel eq $w;
  178 
  179     # find the client window that matches
  180     my $client = $over;
  181     while (defined $client) {
  182         last if (exists $w->{'clients'}{$client});
  183         if ($client->can("MasterMenu")) {
  184         my $master = $client->MasterMenu;
  185         if ($master && exists $w->{'clients'}{$master}) {
  186             $w->{'clients'}{$client} = $w->{'clients'}{$master};
  187             last;
  188         }
  189         }
  190         $client = $client->Parent;
  191     }
  192     if (defined $client) {
  193         # popping up disabled -- ignore
  194         my $state = $w->GetOption(-state => $client);
  195         next if $state eq 'none';
  196         # Check if a button was recently released:
  197         my $deactivate = 0;
  198         if ($button_up) {
  199           $deactivate = 1;
  200           $button_up = 0;
  201         }
  202         # Deactivate it if the motioncommand says to:
  203             my $command = $w->GetOption(-motioncommand => $client);
  204         $deactivate = $command->Call($client, $x, $y) if defined $command;
  205             if ($deactivate)
  206              {
  207               $w->Deactivate;
  208              }
  209             else
  210              {
  211               # warn "deact: $client $w->{'client'}";
  212               $w->Deactivate unless $client->IS($w->{'client'});
  213               my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
  214               if (defined($msg))
  215                {
  216                 my $delay = delete $w->{'delay'};
  217                 $delay->cancel if defined $delay;
  218                 my $initwait = $w->GetOption(-initwait => $client);
  219                 $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);});
  220                 $w->{'client'} = $client;
  221                }
  222              }
  223     } else {
  224         # cursor is at a position covered by a non client
  225         # pop down the balloon if it is up or scheduled.
  226         $w->Deactivate;
  227     }
  228     }
  229 }
  230 
  231 sub ButtonDown {
  232     my ($ewin) = @_;
  233 
  234     foreach my $w (@balloons) {
  235         $w->Deactivate;
  236     }
  237 }
  238 
  239 sub ButtonUp {
  240     $button_up = 1;
  241 }
  242 
  243 # switch the balloon to a new client
  244 sub SwitchToClient {
  245     my ($w, $client) = @_;
  246     return unless Exists($w);
  247     return unless Exists($client);
  248     return unless $client->IS($w->{'client'});
  249     return if &grabBad($w, $client);
  250     my $command = $w->GetOption(-postcommand => $client);
  251     if (defined $command) {
  252         # Execute the user's command and return if it returns false:
  253         my $pos = $command->Call($client);
  254         return if not $pos;
  255         if ($pos =~ /^(\d+),(\d+)$/) {
  256             # Save the returned position so the Popup method can use it:
  257             $w->{'clients'}{$client}{'postposition'} = [$1, $2];
  258         }
  259     }
  260     my $state = $w->GetOption(-state => $client);
  261     $w->Popup if ($state =~ /both|balloon/);
  262     $w->SetStatus if ($state =~ /both|status/);
  263     $w->{'popped'} = 1;
  264     $w->{'delay'}  = $w->repeat(200, ['Verify', $w, $client]);
  265 }
  266 
  267 sub grabBad {
  268 
  269     my ($w, $client) = @_;
  270 
  271     return 0 unless Exists($client);
  272     my $g = $w->grabCurrent;
  273     return 0 unless defined $g;
  274     return 0 if $g->isa('Tk::Menu');
  275     return 0 if $g eq $client;
  276 
  277     # Ignore grab check if $w is the balloon itself.
  278     # XXX Why is this necessary? Is it possible to remove the grabBad
  279     # condition in SwitchToClient altogether?
  280     return 0 if $w->isa(__PACKAGE__);
  281 
  282     # The grab is OK if $client is a descendant of $g. Use the internal Tcl/Tk
  283     # pathname (yes, it's cheating, but it's legal).
  284 
  285     return 0 if $g == $w->MainWindow;
  286     my $wp = $w->PathName;
  287     my $gp = $g->PathName;
  288     return 0 if $wp =~ /^$gp/;
  289     return 1;                   # bad grab
  290 
  291 } # end grabBad
  292 
  293 
  294 sub Subclient
  295 {
  296  my ($w,$data) = @_;
  297  if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
  298   {
  299    $w->Deactivate;
  300   }
  301  $w->{'subclient'} = $data;
  302 }
  303 
  304 sub Verify {
  305     my $w      = shift;
  306     my $client = shift;
  307     my ($X,$Y) = (@_) ? @_ : ($w->pointerxy);
  308     my $over = $w->Containing($X,$Y);
  309     return if not defined $over or ($over->toplevel eq $w);
  310     my $deactivate = # DELETE? or move it to the isa-Menu section?:
  311              # ($over ne $client) or
  312              not $client->IS($w->{'client'})
  313 #                     or (!$client->isa('Tk::Menu') && $w->grabCurrent);
  314 #                     or $w->grabbad($client);
  315              or &grabBad($w, $client);
  316     if ($deactivate)
  317      {
  318       $w->Deactivate;
  319      }
  320     else
  321      {
  322       $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
  323      }
  324 }
  325 
  326 sub Deactivate {
  327     my ($w) = @_;
  328     my $delay = delete $w->{'delay'};
  329     $delay->cancel if defined $delay;
  330     if ($w->{'popped'}) {
  331         my $client = $w->{'client'};
  332         my $command = $w->GetOption(-cancelcommand => $client);
  333         if (defined $command) {
  334             # Execute the user's command and return if it returns false:
  335             return if not $command->Call($client);
  336         }
  337         $w->withdraw;
  338         $w->ClearStatus;
  339         $w->{'popped'} = 0;
  340         $w->{'menu_index'} = 'none';
  341         $w->{'canvas_tag'} = '';
  342     }
  343     $w->{'client'} = undef;
  344     $w->{'subclient'} = undef;
  345     $w->{'location'} = undef;
  346 }
  347 
  348 sub Popup {
  349     my ($w) = @_;
  350     if ($w->cget(-installcolormap)) {
  351         $w->colormapwindows($w->winfo('toplevel'))
  352     }
  353     my $client = $w->{'client'};
  354     return if not defined $client or not exists $w->{'clients'}{$client};
  355     my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg');
  356     # Dereference it if it looks like a scalar reference:
  357     $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
  358 
  359     $w->Subwidget('message')->configure(-text => $msg);
  360     $w->idletasks;
  361 
  362     return unless Exists($w);
  363     return unless Exists($client);
  364     return if $msg eq '';  # Don't popup empty balloons.
  365 
  366     my ($x, $y);
  367     my $pos = $w->GetOption(-balloonposition => $client);
  368     my $postpos = delete $w->{'clients'}{$client}{'postposition'};
  369     if (defined $postpos) {
  370     # The postcommand must have returned a position for the balloon - I will use that:
  371     ($x,$y) = @{$postpos};
  372     } elsif ($pos eq 'mouse') {
  373         ($x,$y)=$client->pointerxy; # We adjust the position later
  374     } elsif ($pos eq 'widget') {
  375     $x = int($client->rootx + $client->width/2);
  376     $y = int($client->rooty + int ($client->height/1.3));
  377     } else {
  378     croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
  379     }
  380 
  381     $w->idletasks;
  382 
  383     # Explanation of following code. [JD]
  384     # PREMISE: We want to ensure that the balloon is always "on screen".
  385     # To do this we use calculate the size of the
  386     # toplevel before it is mapped. Then we adjust its position with respect to the
  387     # mouse cursor or widget. Balloons are usually shown below and to the right of the target.
  388     # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP..
  389     # the balloon will extend across two monitors in single logical screen mode (SLS).
  390     # This is an undesirable characteristic indeed. Trying to read a disjointed balloon
  391     # across monitors is not fun.
  392     #
  393     # The intent of the following code is to fix this problem. We do this by avoiding
  394     # placement of any part of the balloon over,say, the "half screenwidth" mark (for two
  395     # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on...
  396     # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard
  397     # boundaries to be avoided.
  398     #
  399     # The only drawback of this code, is I know of no way to actually determine this on a
  400     # user by user basis. This means that the developer or administrator will have to know
  401     # the hardware (monitor) setup for which the application is designed.
  402     #
  403     # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead
  404     # of creating four separate labels, we configure only ONE label with the proper image.
  405     # Then using the place geometry manager, this image/label can be "slid" along the
  406     # appropriate side of the toplevel so that it always points directly at the target widget.
  407     #
  408     # Here we go..
  409 
  410     my ($width, $height) = ($w->reqwidth, $w->reqheight);
  411     my ($sw, $sh) = ($w->screenwidth, $w->screenheight);
  412     my $numscreen = $w->cget(-numscreens);
  413     my $deltax = $sw/$numscreen;
  414     my $leftedge;
  415     my $rightedge;
  416     my $count = 0;
  417     for (my $i=0; $i<$sw; $i+=$deltax){
  418     $leftedge = $i;
  419     $rightedge = $i + $deltax;
  420     if ($x >= $leftedge && $x < $rightedge ){
  421         last;
  422     }
  423         $count++;
  424     }
  425 
  426     # Force another look at balloon location because mouse has switched
  427     # virtual screens.
  428     $w->{'location'} = undef unless ( $count == $w->{'current_screen'} );
  429     $w->{'current_screen'} = $count;
  430 
  431     my $xx=undef;
  432     my $yy=undef; # to hold final toplevel placement
  433     my $slideOffsetX = 0;
  434     my $slideOffsetY = 0;
  435     my $cornerOffset = 5; #default - keep corner away from pointer
  436     my $testtop = $y - $height - $cornerOffset;
  437     my $testbottom = $y + $height + (2*$cornerOffset);
  438     my $testright = $x + $width + (2*$cornerOffset);
  439     my $testleft = $x - $width - $cornerOffset;
  440     my $vert='bottom'; #default
  441     my $horiz='right'; #default
  442 
  443 
  444     if ( defined $w->{'location'} ){
  445       # Once balloon is activated, **don't** change the location of the balloon.
  446       # It is annoying to have it jump from one location to another.
  447         ( $w->{'location'}=~/top/  ) ? ( $vert = 'top'   ) : ( $vert = 'bottom' );
  448         ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' );
  449 
  450         if ($vert eq 'top' && $testtop < 0) {
  451             $yy = 0;
  452             $slideOffsetY = $testtop;
  453         }
  454         elsif ($vert eq 'bottom' && $testbottom > $sh) {
  455             $slideOffsetY = $testbottom - $sh;
  456         }
  457 
  458         if ($horiz eq 'left' && $testleft < $leftedge) {
  459             $xx = $leftedge;
  460         }
  461         elsif ($horiz eq 'right' && $testright > $rightedge) {
  462             $slideOffsetX = $testright - $rightedge;
  463         }
  464     }
  465     else {
  466         #Test balloon positions in the vertical
  467         if ($testbottom > $sh) {
  468             #Then offscreen to bottom, check top
  469             if ($testtop >= 0) {
  470                 $vert = 'top';
  471             }
  472             elsif ($y > $sh/2) {
  473         #still offscreen to top but there is more room above then below
  474                 $vert = 'top';
  475                 $yy=0;
  476                 $slideOffsetY = $testtop;
  477             }
  478         if ($vert eq 'bottom'){
  479                 #Calculate Yoffset to fit entire balloon onto screen
  480                 $slideOffsetY = $testbottom - $sh;
  481             }
  482         }
  483         #Test balloon positions in the horizontal
  484 
  485         if ($testright > $rightedge) {
  486             #The offscreen, check left
  487             if ($testleft >= $leftedge) {
  488                 $horiz = 'left';
  489             }
  490             elsif ($x > ($leftedge+$deltax) ) {
  491                 #still offscreen to left but there is more room to left than right
  492             $horiz = 'left';
  493                 $xx=0;
  494                 $slideOffsetX = $testleft;
  495         }
  496         if ($horiz eq 'right'){
  497                 #Calculate Xoffset to fit entire balloon onto screen
  498                 $slideOffsetX = $testright - $rightedge;
  499             }
  500         }
  501     }
  502 
  503     $w->{'location'} = $vert.$horiz unless (defined $w->{'location'});
  504 
  505     if ($w->{'location'} eq 'bottomright') {
  506         if ( $slideOffsetX or $slideOffsetY ) {
  507             $w->{'pointer'}->configure(-image => $w->{img_no});
  508         }
  509         else {
  510             $w->{'pointer'}->configure(-image => $w->{img_tl});
  511         }
  512 
  513         $w->{'pointer'}->place(
  514             -in=>$w,
  515 #            -relx=>0, -x=>$slideOffsetX + 2,
  516 #            -rely=>0, -y=>$slideOffsetY + 2,
  517             -relx=>0, -x=>2,
  518             -rely=>0, -y=>2,
  519             -bordermode=>'outside',
  520             -anchor=>'nw');
  521 
  522         $xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx);
  523         $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
  524 
  525     }
  526     elsif ($w->{'location'} eq 'bottomleft') {
  527         if ( $slideOffsetX or $slideOffsetY ) {
  528             $w->{'pointer'}->configure(-image => $w->{img_no});
  529         }
  530         else {
  531             $w->{'pointer'}->configure(-image => $w->{img_tr});
  532         }
  533 
  534         $w->{'pointer'}->place(-in=>$w,
  535 #            -relx=>1, -x=>$slideOffsetX - 2,
  536 #            -rely=>0, -y=>$slideOffsetY + 2,
  537             -relx=>1, -x=>-2,
  538             -rely=>0, -y=>2,
  539             -bordermode=>'outside',
  540             -anchor=>'ne');
  541 
  542         $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
  543         $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
  544 
  545     }
  546     elsif ($w->{'location'} eq 'topright') {
  547         if ( $slideOffsetX or $slideOffsetY ) {
  548             $w->{'pointer'}->configure(-image => $w->{img_no});
  549         }
  550         else {
  551             $w->{'pointer'}->configure(-image => $w->{img_bl});
  552         }
  553 
  554         $w->{'pointer'}->place(-in=>$w,
  555 #            -relx=>0, -x=>$slideOffsetX + 2,
  556 #            -rely=>1, -y=>$slideOffsetY - 2,
  557             -relx=>0, -x=>2,
  558             -rely=>1, -y=>-2,
  559             -bordermode=>'outside',
  560             -anchor=>'sw');
  561 
  562         $xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx);
  563         $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
  564     }
  565     elsif ($w->{'location'} eq 'topleft') {
  566         if ( $slideOffsetX or $slideOffsetY ) {
  567             $w->{'pointer'}->configure(-image => $w->{img_no});
  568         }
  569         else {
  570             $w->{'pointer'}->configure(-image => $w->{img_br});
  571         }
  572 
  573         $w->{'pointer'}->place(-in=>$w,
  574 #            -relx=>1, -x=>$slideOffsetX - 2,
  575 #            -rely=>1, -y=>$slideOffsetY - 2,
  576             -relx=>1, -x=>-2,
  577             -rely=>1, -y=>-2,
  578             -bordermode=>'outside',
  579             -anchor=>'se');
  580 
  581         $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
  582         $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
  583     }
  584 
  585     $w->{'pointer'}->raise;
  586     $xx = int($xx);
  587     $yy = int($yy);
  588     $w->geometry("+$xx+$yy");
  589     $w->deiconify();
  590     $w->raise;
  591 }
  592 
  593 sub SetStatus {
  594     my ($w) = @_;
  595     my $client = $w->{'client'};
  596     my $s = $w->GetOption(-statusbar => $client);
  597     if (defined $s and $s->winfo('exists')) {
  598         my $vref = $s->cget(-textvariable);
  599         return if not defined $client or not exists $w->{'clients'}{$client};
  600         my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg');
  601         # Dereference it if it looks like a scalar reference:
  602         $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
  603         if (not defined $vref) {
  604             eval { $s->configure(-text => $msg); };
  605         } else {
  606             $$vref = $msg;
  607         }
  608     }
  609 }
  610 
  611 sub ClearStatus {
  612     my ($w) = @_;
  613     my $client = $w->{'client'};
  614     my $s = $w->GetOption(-statusbar => $client);
  615     if (defined $s and $s->winfo('exists')) {
  616     my $vref = $s->cget(-textvariable);
  617     if (defined $vref) {
  618         $$vref = '';
  619     } else {
  620         eval { $s->configure(-text => ''); }
  621     }
  622     }
  623 }
  624 
  625 sub _destroyed {
  626     my ($w) = @_;
  627     # This is called when widget is destroyed (no matter how!)
  628     # via the ->OnDestroy hook set in Populate.
  629     # remove ourselves from the list of baloons.
  630     @balloons = grep($w != $_, @balloons);
  631 
  632     # FIXME: If @balloons is now empty perhaps remove the 'all' bindings
  633     # to reduce overhead until another balloon is created?
  634 
  635     # Delete the images
  636     for (qw(no tl tr bl br)) {
  637         my $img = delete $w->{"img_$_"};
  638         $img->delete if defined $img;
  639     }
  640 }
  641 
  642 1;
  643 
  644