home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _d4e16c872f1eca669ec4ee480c753b7e < prev    next >
Text File  |  2004-06-01  |  21KB  |  622 lines
  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 wether 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 = 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. # attach a client to the balloon
  119. sub attach {
  120.     my ($w, $client, %args) = @_;
  121.     foreach my $key (grep(/command$/,keys %args))
  122.      {
  123.       $args{$key} = Tk::Callback->new($args{$key});
  124.      }
  125.     my $msg = delete $args{-msg};
  126.     $args{-balloonmsg} = $msg unless exists $args{-balloonmsg};
  127.     $args{-statusmsg}  = $msg unless exists $args{-statusmsg};
  128.     $w->{'clients'}{$client} = \%args;
  129.     $client->OnDestroy([$w, 'detach', $client]);
  130. }
  131.  
  132. # detach a client from the balloon.
  133. sub detach {
  134.     my ($w, $client) = @_;
  135.     if (Exists($w))
  136.      {
  137.       $w->Deactivate if ($client->IS($w->{'client'}));
  138.      }
  139.     delete $w->{'clients'}{$client};
  140. }
  141.  
  142. sub GetOption
  143. {
  144.  my ($w,$opt,$client) = @_;
  145.  $client = $w->{'client'} unless defined $client;
  146.  if (defined $client)
  147.   {
  148.    my $info = $w->{'clients'}{$client};
  149.    return $info->{$opt} if exists $info->{$opt};
  150.   }
  151.  return $w->cget($opt);
  152. }
  153.  
  154. sub Motion {
  155.     my ($ewin, $x, $y, $s) = @_;
  156.  
  157.     return if not defined $ewin;
  158.  
  159.     # Find which window we are over
  160.     my $over = $ewin->Containing($x, $y);
  161.  
  162.     return if &grabBad($ewin, $over);
  163.  
  164.     foreach my $w (@balloons) {
  165.     # if cursor has moved over the balloon -- ignore
  166.     next if defined $over and $over->toplevel eq $w;
  167.  
  168.     # find the client window that matches
  169.     my $client = $over;
  170.     while (defined $client) {
  171.         last if (exists $w->{'clients'}{$client});
  172.         $client = $client->Parent;
  173.     }
  174.     if (defined $client) {
  175.         # popping up disabled -- ignore
  176.         my $state = $w->GetOption(-state => $client);
  177.         next if $state eq 'none';
  178.         # Check if a button was recently released:
  179.         my $deactivate = 0;
  180.         if ($button_up) {
  181.           $deactivate = 1;
  182.           $button_up = 0;
  183.         }
  184.         # Deactivate it if the motioncommand says to:
  185.             my $command = $w->GetOption(-motioncommand => $client);
  186.         $deactivate = $command->Call($client, $x, $y) if defined $command;
  187.             if ($deactivate)
  188.              {
  189.               $w->Deactivate;
  190.              }
  191.             else
  192.              {
  193.               # warn "deact: $client $w->{'client'}";
  194.               $w->Deactivate unless $client->IS($w->{'client'});
  195.               my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
  196.               if (defined($msg))
  197.                {
  198.                 my $delay = delete $w->{'delay'};
  199.                 $delay->cancel if defined $delay;
  200.                 my $initwait = $w->GetOption(-initwait => $client);
  201.                 $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);});
  202.                 $w->{'client'} = $client;
  203.                }
  204.              }
  205.     } else {
  206.         # cursor is at a position covered by a non client
  207.         # pop down the balloon if it is up or scheduled.
  208.         $w->Deactivate;
  209.     }
  210.     }
  211. }
  212.  
  213. sub ButtonDown {
  214.     my ($ewin) = @_;
  215.  
  216.     foreach my $w (@balloons) {
  217.         $w->Deactivate;
  218.     }
  219. }
  220.  
  221. sub ButtonUp {
  222.     $button_up = 1;
  223. }
  224.  
  225. # switch the balloon to a new client
  226. sub SwitchToClient {
  227.     my ($w, $client) = @_;
  228.     return unless Exists($w);
  229.     return unless Exists($client);
  230.     return unless $client->IS($w->{'client'});
  231.     return if &grabBad($w, $client);
  232.     my $command = $w->GetOption(-postcommand => $client);
  233.     if (defined $command) {
  234.         # Execute the user's command and return if it returns false:
  235.         my $pos = $command->Call($client);
  236.         return if not $pos;
  237.         if ($pos =~ /^(\d+),(\d+)$/) {
  238.             # Save the returned position so the Popup method can use it:
  239.             $w->{'clients'}{$client}{'postposition'} = [$1, $2];
  240.         }
  241.     }
  242.     my $state = $w->GetOption(-state => $client);
  243.     $w->Popup if ($state =~ /both|balloon/);
  244.     $w->SetStatus if ($state =~ /both|status/);
  245.     $w->{'popped'} = 1;
  246.     $w->{'delay'}  = $w->repeat(200, ['Verify', $w, $client]);
  247. }
  248.  
  249. sub grabBad {
  250.  
  251.     my ($w, $client) = @_;
  252.  
  253.     return 0 unless Exists($client);
  254.     my $g = $w->grabCurrent;
  255.     return 0 unless defined $g;
  256.     return 0 if $g->isa('Tk::Menu');
  257.     return 0 if $g eq $client;
  258.  
  259.     # The grab is OK if $client is a decendant of $g. Use the internal Tcl/Tk
  260.     # pathname (yes, it's cheating, but it's legal).
  261.  
  262.     return 0 if $g == $w->MainWindow;
  263.     my $wp = $w->PathName;
  264.     my $gp = $g->PathName;
  265.     return 0 if $wp =~ /^$gp/;
  266.     return 1;                   # bad grab
  267.  
  268. } # end grabBad
  269.  
  270.  
  271. sub Subclient
  272. {
  273.  my ($w,$data) = @_;
  274.  if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
  275.   {
  276.    $w->Deactivate;
  277.   }
  278.  $w->{'subclient'} = $data;
  279. }
  280.  
  281. sub Verify {
  282.     my $w      = shift;
  283.     my $client = shift;
  284.     my ($X,$Y) = (@_) ? @_ : ($w->pointerxy);
  285.     my $over = $w->Containing($X,$Y);
  286.     return if not defined $over or ($over->toplevel eq $w);
  287.     my $deactivate = # DELETE? or move it to the isa-Menu section?:
  288.              # ($over ne $client) or
  289.              not $client->IS($w->{'client'})
  290. #                     or (!$client->isa('Tk::Menu') && $w->grabCurrent);
  291. #                     or $w->grabbad($client);
  292.              or &grabBad($w, $client);
  293.     if ($deactivate)
  294.      {
  295.       $w->Deactivate;
  296.      }
  297.     else
  298.      {
  299.       $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
  300.      }
  301. }
  302.  
  303. sub Deactivate {
  304.     my ($w) = @_;
  305.     my $delay = delete $w->{'delay'};
  306.     $delay->cancel if defined $delay;
  307.     if ($w->{'popped'}) {
  308.         my $client = $w->{'client'};
  309.         my $command = $w->GetOption(-cancelcommand => $client);
  310.         if (defined $command) {
  311.             # Execute the user's command and return if it returns false:
  312.             return if not $command->Call($client);
  313.         }
  314.         $w->withdraw;
  315.         $w->ClearStatus;
  316.         $w->{'popped'} = 0;
  317.         $w->{'menu_index'} = 'none';
  318.         $w->{'canvas_tag'} = '';
  319.     }
  320.     $w->{'client'} = undef;
  321.     $w->{'subclient'} = undef;
  322.     $w->{'location'} = undef;
  323. }
  324.  
  325. sub Popup {
  326.     my ($w) = @_;
  327.     if ($w->cget(-installcolormap)) {
  328.         $w->colormapwindows($w->winfo('toplevel'))
  329.     }
  330.     my $client = $w->{'client'};
  331.     return if not defined $client or not exists $w->{'clients'}{$client};
  332.     my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg');
  333.     # Dereference it if it looks like a scalar reference:
  334.     $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
  335.  
  336.     $w->Subwidget('message')->configure(-text => $msg);
  337.     $w->idletasks;
  338.  
  339.     return unless Exists($w);
  340.     return unless Exists($client);
  341.     return if $msg eq '';  # Don't popup empty balloons.
  342.  
  343.     my ($x, $y);
  344.     my $pos = $w->GetOption(-balloonposition => $client);
  345.     my $postpos = delete $w->{'clients'}{$client}{'postposition'};
  346.     if (defined $postpos) {
  347.     # The postcommand must have returned a position for the balloon - I will use that:
  348.     ($x,$y) = @{$postpos};
  349.     } elsif ($pos eq 'mouse') {
  350.         ($x,$y)=$client->pointerxy; # We adjust the position later
  351.     } elsif ($pos eq 'widget') {
  352.     $x = int($client->rootx + $client->width/2);
  353.     $y = int($client->rooty + int ($client->height/1.3));
  354.     } else {
  355.     croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
  356.     }
  357.  
  358.     $w->idletasks;
  359.  
  360.     # Explanation of following code. [JD]
  361.     # PREMISE: We want to ensure that the balloon is always "on screen".
  362.     # To do this we use calculate the size of the
  363.     # toplevel before it is mapped. Then we adjust it's position with respect to the
  364.     # mouse cursor or widget. Balloons are usually shown below and to the right of the target.
  365.     # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP..
  366.     # the balloon will extend across two monitors in single logical screen mode (SLS).
  367.     # This is an undesirable characteristic indeed. Trying to read a disjointed balloon
  368.     # across monitors is not fun.
  369.     #
  370.     # The intent of the following code is to fix this problem. We do this by avoiding
  371.     # placement of any part of the balloon over,say, the "half screenwidth" mark (for two
  372.     # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on...
  373.     # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard
  374.     # boundaries to be avoided.
  375.     #
  376.     # The only drawback of this code, is I know of no way to actually determine this on a
  377.     # user by user basis. This means that the developer or administrator will have to know
  378.     # the hardware (monitor) setup for which the application is designed.
  379.     #
  380.     # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead
  381.     # of creating four separate labels, we configure only ONE label with the proper image.
  382.     # Then using the place geometry manager, this image/label can be "slid" along the
  383.     # appropriate side of the toplevel so that it always points directly at the target widget.
  384.     #
  385.     # Here we go..
  386.  
  387.     my ($width, $height) = ($w->reqwidth, $w->reqheight);
  388.     my ($sw, $sh) = ($w->screenwidth, $w->screenheight);
  389.     my $numscreen = $w->cget(-numscreens);
  390.     my $deltax = $sw/$numscreen;
  391.     my $leftedge;
  392.     my $rightedge;
  393.     my $count = 0;
  394.     for (my $i=0; $i<$sw; $i+=$deltax){
  395.     $leftedge = $i;
  396.     $rightedge = $i + $deltax;
  397.     if ($x >= $leftedge && $x < $rightedge ){
  398.         last;
  399.     }
  400.         $count++;
  401.     }
  402.  
  403.     # Force another look at balloon location because mouse has switched
  404.     # virtual screens.
  405.     $w->{'location'} = undef unless ( $count == $w->{'current_screen'} );
  406.     $w->{'current_screen'} = $count;
  407.  
  408.     my $xx=undef;
  409.     my $yy=undef; # to hold final toplevel placement
  410.     my $slideOffsetX = 0;
  411.     my $slideOffsetY = 0;
  412.     my $cornerOffset = 5; #default - keep corner away from pointer
  413.     my $testtop = $y - $height - $cornerOffset;
  414.     my $testbottom = $y + $height + (2*$cornerOffset);
  415.     my $testright = $x + $width + (2*$cornerOffset);
  416.     my $testleft = $x - $width - $cornerOffset;
  417.     my $vert='bottom'; #default
  418.     my $horiz='right'; #default
  419.  
  420.  
  421.     if ( defined $w->{'location'} ){
  422.       # Once balloon is activated, **don't** change the location of the balloon.
  423.       # It is annoying to have it jump from one location to another.
  424.         ( $w->{'location'}=~/top/  ) ? ( $vert = 'top'   ) : ( $vert = 'bottom' );
  425.         ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' );
  426.  
  427.         if ($vert eq 'top' && $testtop < 0) {
  428.             $yy = 0;
  429.             $slideOffsetY = $testtop;
  430.         }
  431.         elsif ($vert eq 'bottom' && $testbottom > $sh) {
  432.             $slideOffsetY = $testbottom - $sh;
  433.         }
  434.  
  435.         if ($horiz eq 'left' && $testleft < $leftedge) {
  436.             $xx = $leftedge;
  437.         }
  438.         elsif ($horiz eq 'right' && $testright > $rightedge) {
  439.             $slideOffsetX = $testright - $rightedge;
  440.         }
  441.     }
  442.     else {
  443.         #Test balloon positions in the vertical
  444.         if ($testbottom > $sh) {
  445.             #Then offscreen to bottom, check top
  446.             if ($testtop >= 0) {
  447.                 $vert = 'top';
  448.             }
  449.             elsif ($y > $sh/2) {
  450.          #still offscreen to top but there is more room above then below
  451.                 $vert = 'top';
  452.                 $yy=0;
  453.                 $slideOffsetY = $testtop;
  454.              }
  455.         if ($vert eq 'bottom'){
  456.                 #Calculate Yoffset to fit entire balloon onto screen
  457.                 $slideOffsetY = $testbottom - $sh;
  458.             }
  459.         }
  460.         #Test balloon positions in the horizontal
  461.  
  462.         if ($testright > $rightedge) {
  463.             #The offscreen, check left
  464.             if ($testleft >= $leftedge) {
  465.                 $horiz = 'left';
  466.             }
  467.             elsif ($x > ($leftedge+$deltax) ) {
  468.                 #still offscreen to left but there is more room to left than right
  469.             $horiz = 'left';
  470.                 $xx=0;
  471.                 $slideOffsetX = $testleft;
  472.         }
  473.         if ($horiz eq 'right'){
  474.                 #Calculate Xoffset to fit entire balloon onto screen
  475.                 $slideOffsetX = $testright - $rightedge;
  476.             }
  477.         }
  478.     }
  479.  
  480.     $w->{'location'} = $vert.$horiz unless (defined $w->{'location'});
  481.  
  482.     if ($w->{'location'} eq 'bottomright') {
  483.         if ( $slideOffsetX or $slideOffsetY ) {
  484.             $w->{'pointer'}->configure(-image => $w->{img_no});
  485.         }
  486.         else {
  487.             $w->{'pointer'}->configure(-image => $w->{img_tl});
  488.         }
  489.  
  490.         $w->{'pointer'}->place(
  491.             -in=>$w,
  492. #            -relx=>0, -x=>$slideOffsetX + 2,
  493. #            -rely=>0, -y=>$slideOffsetY + 2,
  494.             -relx=>0, -x=>2,
  495.             -rely=>0, -y=>2,
  496.             -bordermode=>'outside',
  497.             -anchor=>'nw');
  498.  
  499.         $xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx);
  500.         $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
  501.  
  502.     }
  503.     elsif ($w->{'location'} eq 'bottomleft') {
  504.         if ( $slideOffsetX or $slideOffsetY ) {
  505.             $w->{'pointer'}->configure(-image => $w->{img_no});
  506.         }
  507.         else {
  508.             $w->{'pointer'}->configure(-image => $w->{img_tr});
  509.         }
  510.  
  511.         $w->{'pointer'}->place(-in=>$w,
  512. #            -relx=>1, -x=>$slideOffsetX - 2,
  513. #            -rely=>0, -y=>$slideOffsetY + 2,
  514.             -relx=>1, -x=>-2,
  515.             -rely=>0, -y=>2,
  516.             -bordermode=>'outside',
  517.             -anchor=>'ne');
  518.  
  519.         $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
  520.         $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
  521.  
  522.     }
  523.     elsif ($w->{'location'} eq 'topright') {
  524.         if ( $slideOffsetX or $slideOffsetY ) {
  525.             $w->{'pointer'}->configure(-image => $w->{img_no});
  526.         }
  527.         else {
  528.             $w->{'pointer'}->configure(-image => $w->{img_bl});
  529.         }
  530.  
  531.         $w->{'pointer'}->place(-in=>$w,
  532. #            -relx=>0, -x=>$slideOffsetX + 2,
  533. #            -rely=>1, -y=>$slideOffsetY - 2,
  534.             -relx=>0, -x=>2,
  535.             -rely=>1, -y=>-2,
  536.             -bordermode=>'outside',
  537.             -anchor=>'sw');
  538.  
  539.         $xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx);
  540.         $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
  541.     }
  542.     elsif ($w->{'location'} eq 'topleft') {
  543.         if ( $slideOffsetX or $slideOffsetY ) {
  544.             $w->{'pointer'}->configure(-image => $w->{img_no});
  545.         }
  546.         else {
  547.             $w->{'pointer'}->configure(-image => $w->{img_br});
  548.         }
  549.  
  550.         $w->{'pointer'}->place(-in=>$w,
  551. #            -relx=>1, -x=>$slideOffsetX - 2,
  552. #            -rely=>1, -y=>$slideOffsetY - 2,
  553.             -relx=>1, -x=>-2,
  554.             -rely=>1, -y=>-2,
  555.             -bordermode=>'outside',
  556.             -anchor=>'se');
  557.  
  558.         $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
  559.         $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
  560.     }
  561.  
  562.     $w->{'pointer'}->raise;
  563.     $xx = int($xx);
  564.     $yy = int($yy);
  565.     $w->geometry("+$xx+$yy");
  566.     $w->deiconify();
  567.     $w->raise;
  568. }
  569.  
  570. sub SetStatus {
  571.     my ($w) = @_;
  572.     my $client = $w->{'client'};
  573.     my $s = $w->GetOption(-statusbar => $client);
  574.     if (defined $s and $s->winfo('exists')) {
  575.         my $vref = $s->cget(-textvariable);
  576.         return if not defined $client or not exists $w->{'clients'}{$client};
  577.         my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg');
  578.         # Dereference it if it looks like a scalar reference:
  579.         $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
  580.         if (not defined $vref) {
  581.             eval { $s->configure(-text => $msg); };
  582.         } else {
  583.             $$vref = $msg;
  584.         }
  585.     }
  586. }
  587.  
  588. sub ClearStatus {
  589.     my ($w) = @_;
  590.     my $client = $w->{'client'};
  591.     my $s = $w->GetOption(-statusbar => $client);
  592.     if (defined $s and $s->winfo('exists')) {
  593.     my $vref = $s->cget(-textvariable);
  594.     if (defined $vref) {
  595.         $$vref = '';
  596.     } else {
  597.         eval { $s->configure(-text => ''); }
  598.     }
  599.     }
  600. }
  601.  
  602. sub _destroyed {
  603.     my ($w) = @_;
  604.     # This is called when widget is destroyed (no matter how!)
  605.     # via the ->OnDestroy hook set in Populate.
  606.     # remove ourselves from the list of baloons.
  607.     @balloons = grep($w != $_, @balloons);
  608.  
  609.     # FIXME: If @balloons is now empty perhaps remove the 'all' bindings
  610.     # to reduce overhead until another balloon is created?
  611.  
  612.     # Delete the images
  613.     for (qw(no tl tr bl br)) {
  614.         my $img = delete $w->{"img_$_"};
  615.         $img->delete if defined $img;
  616.     }
  617. }
  618.  
  619. 1;
  620.  
  621.  
  622.