summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Balloon.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Balloon.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Balloon.pm621
1 files changed, 0 insertions, 621 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Balloon.pm b/Master/tlpkg/tlperl/lib/Tk/Balloon.pm
deleted file mode 100644
index 2ee0f6c3bce..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Balloon.pm
+++ /dev/null
@@ -1,621 +0,0 @@
-#
-# The help widget that provides both "balloon" and "status bar"
-# types of help messages.
-#
-# This is a patched version of Balloon 3.037 - it adds support
-# for different orientations of the balloon widget, depending
-# on wether there's enough space for it. The little arrow now
-# should always point directly to the client.
-# Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com)
-#
-# Nov 1, 2003 - Jack Dunnigan
-# Added support for more than one screen in single logical
-# screen mode (i.e. xinerama, dual monitors)
-
-package Tk::Balloon;
-
-use vars qw($VERSION);
-$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/;
-
-use Tk qw(Ev Exists);
-use Carp;
-require Tk::Toplevel;
-
-Tk::Widget->Construct('Balloon');
-use base qw(Tk::Toplevel);
-
-# use UNIVERSAL; avoid the UNIVERSAL.pm file subs are XS in perl core
-
-use strict;
-
-my @balloons;
-my $button_up = 0;
-my %arrows = ( TL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAINjA0HAEdwLCwMKIQfBQA7',
- TR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIRBGMDwAEQkgAIAAoCABEEuwAAOw==',
- BR => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPDOHHhYVRAIgIAEISQLELADs=',
- BL => 'R0lGODlhBgAGAJEAANnZ2QAAAP///////yH5BAEAAAAALAAAAAAGAAYAAAIPhB1xAUFALCIMKAaAWQAVADs=',
- NO => 'R0lGODlhAQABAJEAANnZ2f///////////yH5BAEAAAAALAAAAAABAAEAAAICRAEAOw=='
- );
-
-
-sub ClassInit {
- my ($class, $mw) = @_;
- $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
- $mw->bind('all', '<Leave>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
- $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown');
- $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp');
- return $class;
-}
-
-sub Populate {
- my ($w, $args) = @_;
-
- $w->SUPER::Populate($args);
-
- $w->overrideredirect(1);
- $w->withdraw;
- # Only the container frame's background should be black... makes it
- # look better.
- $w->configure(-background => 'black');
-
- # the balloon arrows
- $w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif');
- $w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif');
- $w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif');
- $w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif');
- $w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif');
- $w->OnDestroy([$w, '_destroyed']);
-
- $w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no});
-
- # the balloon message
- # We give the Label a big borderwidth
- # ..enough to slide a 6x6 gif image along the border including some space
-
- my $ml = $w->Label(-bd => 0,
- -padx => 10,
- -pady => 3,
- -justify => 'left',
- -relief=>'flat');
- $w->Advertise('message' => $ml);
-
- $ml->pack(
- -side => 'top',
- -anchor => 'nw',
- -expand => 1,
- -fill => 'both',
- -padx => 0,
- -pady => 0);
-
- # append to global list of balloons
- push(@balloons, $w);
- $w->{'popped'} = 0;
- $w->{'buttonDown'} = 0;
- $w->{'menu_index'} = 'none';
- $w->{'menu_index_over'} = 'none';
- $w->{'canvas_tag'} = '';
- $w->{'canvas_tag_over'} = '';
- $w->{'current_screen'} = 0;
-
- $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0],
- -initwait => ['PASSIVE', 'initWait', 'InitWait', 350],
- -state => ['PASSIVE', 'state', 'State', 'both'],
- -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef],
- -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''],
- -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''],
- -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'],
- -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef],
- -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef],
- -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef],
- -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'],
- -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef],
- -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],
- -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1],
- -numscreens=>['PASSIVE', 'numScreens','NumScreens',1],
- );
-}
-
-# attach a client to the balloon
-sub attach {
- my ($w, $client, %args) = @_;
- foreach my $key (grep(/command$/,keys %args))
- {
- $args{$key} = Tk::Callback->new($args{$key});
- }
- my $msg = delete $args{-msg};
- $args{-balloonmsg} = $msg unless exists $args{-balloonmsg};
- $args{-statusmsg} = $msg unless exists $args{-statusmsg};
- $w->{'clients'}{$client} = \%args;
- $client->OnDestroy([$w, 'detach', $client]);
-}
-
-# detach a client from the balloon.
-sub detach {
- my ($w, $client) = @_;
- if (Exists($w))
- {
- $w->Deactivate if ($client->IS($w->{'client'}));
- }
- delete $w->{'clients'}{$client};
-}
-
-sub GetOption
-{
- my ($w,$opt,$client) = @_;
- $client = $w->{'client'} unless defined $client;
- if (defined $client)
- {
- my $info = $w->{'clients'}{$client};
- return $info->{$opt} if exists $info->{$opt};
- }
- return $w->cget($opt);
-}
-
-sub Motion {
- my ($ewin, $x, $y, $s) = @_;
-
- return if not defined $ewin;
-
- # Find which window we are over
- my $over = $ewin->Containing($x, $y);
-
- return if &grabBad($ewin, $over);
-
- foreach my $w (@balloons) {
- # if cursor has moved over the balloon -- ignore
- next if defined $over and $over->toplevel eq $w;
-
- # find the client window that matches
- my $client = $over;
- while (defined $client) {
- last if (exists $w->{'clients'}{$client});
- $client = $client->Parent;
- }
- if (defined $client) {
- # popping up disabled -- ignore
- my $state = $w->GetOption(-state => $client);
- next if $state eq 'none';
- # Check if a button was recently released:
- my $deactivate = 0;
- if ($button_up) {
- $deactivate = 1;
- $button_up = 0;
- }
- # Deactivate it if the motioncommand says to:
- my $command = $w->GetOption(-motioncommand => $client);
- $deactivate = $command->Call($client, $x, $y) if defined $command;
- if ($deactivate)
- {
- $w->Deactivate;
- }
- else
- {
- # warn "deact: $client $w->{'client'}";
- $w->Deactivate unless $client->IS($w->{'client'});
- my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
- if (defined($msg))
- {
- my $delay = delete $w->{'delay'};
- $delay->cancel if defined $delay;
- my $initwait = $w->GetOption(-initwait => $client);
- $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);});
- $w->{'client'} = $client;
- }
- }
- } else {
- # cursor is at a position covered by a non client
- # pop down the balloon if it is up or scheduled.
- $w->Deactivate;
- }
- }
-}
-
-sub ButtonDown {
- my ($ewin) = @_;
-
- foreach my $w (@balloons) {
- $w->Deactivate;
- }
-}
-
-sub ButtonUp {
- $button_up = 1;
-}
-
-# switch the balloon to a new client
-sub SwitchToClient {
- my ($w, $client) = @_;
- return unless Exists($w);
- return unless Exists($client);
- return unless $client->IS($w->{'client'});
- return if &grabBad($w, $client);
- my $command = $w->GetOption(-postcommand => $client);
- if (defined $command) {
- # Execute the user's command and return if it returns false:
- my $pos = $command->Call($client);
- return if not $pos;
- if ($pos =~ /^(\d+),(\d+)$/) {
- # Save the returned position so the Popup method can use it:
- $w->{'clients'}{$client}{'postposition'} = [$1, $2];
- }
- }
- my $state = $w->GetOption(-state => $client);
- $w->Popup if ($state =~ /both|balloon/);
- $w->SetStatus if ($state =~ /both|status/);
- $w->{'popped'} = 1;
- $w->{'delay'} = $w->repeat(200, ['Verify', $w, $client]);
-}
-
-sub grabBad {
-
- my ($w, $client) = @_;
-
- return 0 unless Exists($client);
- my $g = $w->grabCurrent;
- return 0 unless defined $g;
- return 0 if $g->isa('Tk::Menu');
- return 0 if $g eq $client;
-
- # The grab is OK if $client is a decendant of $g. Use the internal Tcl/Tk
- # pathname (yes, it's cheating, but it's legal).
-
- return 0 if $g == $w->MainWindow;
- my $wp = $w->PathName;
- my $gp = $g->PathName;
- return 0 if $wp =~ /^$gp/;
- return 1; # bad grab
-
-} # end grabBad
-
-
-sub Subclient
-{
- my ($w,$data) = @_;
- if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
- {
- $w->Deactivate;
- }
- $w->{'subclient'} = $data;
-}
-
-sub Verify {
- my $w = shift;
- my $client = shift;
- my ($X,$Y) = (@_) ? @_ : ($w->pointerxy);
- my $over = $w->Containing($X,$Y);
- return if not defined $over or ($over->toplevel eq $w);
- my $deactivate = # DELETE? or move it to the isa-Menu section?:
- # ($over ne $client) or
- not $client->IS($w->{'client'})
-# or (!$client->isa('Tk::Menu') && $w->grabCurrent);
-# or $w->grabbad($client);
- or &grabBad($w, $client);
- if ($deactivate)
- {
- $w->Deactivate;
- }
- else
- {
- $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
- }
-}
-
-sub Deactivate {
- my ($w) = @_;
- my $delay = delete $w->{'delay'};
- $delay->cancel if defined $delay;
- if ($w->{'popped'}) {
- my $client = $w->{'client'};
- my $command = $w->GetOption(-cancelcommand => $client);
- if (defined $command) {
- # Execute the user's command and return if it returns false:
- return if not $command->Call($client);
- }
- $w->withdraw;
- $w->ClearStatus;
- $w->{'popped'} = 0;
- $w->{'menu_index'} = 'none';
- $w->{'canvas_tag'} = '';
- }
- $w->{'client'} = undef;
- $w->{'subclient'} = undef;
- $w->{'location'} = undef;
-}
-
-sub Popup {
- my ($w) = @_;
- if ($w->cget(-installcolormap)) {
- $w->colormapwindows($w->winfo('toplevel'))
- }
- my $client = $w->{'client'};
- return if not defined $client or not exists $w->{'clients'}{$client};
- my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg');
- # Dereference it if it looks like a scalar reference:
- $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
-
- $w->Subwidget('message')->configure(-text => $msg);
- $w->idletasks;
-
- return unless Exists($w);
- return unless Exists($client);
- return if $msg eq ''; # Don't popup empty balloons.
-
- my ($x, $y);
- my $pos = $w->GetOption(-balloonposition => $client);
- my $postpos = delete $w->{'clients'}{$client}{'postposition'};
- if (defined $postpos) {
- # The postcommand must have returned a position for the balloon - I will use that:
- ($x,$y) = @{$postpos};
- } elsif ($pos eq 'mouse') {
- ($x,$y)=$client->pointerxy; # We adjust the position later
- } elsif ($pos eq 'widget') {
- $x = int($client->rootx + $client->width/2);
- $y = int($client->rooty + int ($client->height/1.3));
- } else {
- croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
- }
-
- $w->idletasks;
-
- # Explanation of following code. [JD]
- # PREMISE: We want to ensure that the balloon is always "on screen".
- # To do this we use calculate the size of the
- # toplevel before it is mapped. Then we adjust it's position with respect to the
- # mouse cursor or widget. Balloons are usually shown below and to the right of the target.
- # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP..
- # the balloon will extend across two monitors in single logical screen mode (SLS).
- # This is an undesirable characteristic indeed. Trying to read a disjointed balloon
- # across monitors is not fun.
- #
- # The intent of the following code is to fix this problem. We do this by avoiding
- # placement of any part of the balloon over,say, the "half screenwidth" mark (for two
- # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on...
- # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard
- # boundaries to be avoided.
- #
- # The only drawback of this code, is I know of no way to actually determine this on a
- # user by user basis. This means that the developer or administrator will have to know
- # the hardware (monitor) setup for which the application is designed.
- #
- # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead
- # of creating four separate labels, we configure only ONE label with the proper image.
- # Then using the place geometry manager, this image/label can be "slid" along the
- # appropriate side of the toplevel so that it always points directly at the target widget.
- #
- # Here we go..
-
- my ($width, $height) = ($w->reqwidth, $w->reqheight);
- my ($sw, $sh) = ($w->screenwidth, $w->screenheight);
- my $numscreen = $w->cget(-numscreens);
- my $deltax = $sw/$numscreen;
- my $leftedge;
- my $rightedge;
- my $count = 0;
- for (my $i=0; $i<$sw; $i+=$deltax){
- $leftedge = $i;
- $rightedge = $i + $deltax;
- if ($x >= $leftedge && $x < $rightedge ){
- last;
- }
- $count++;
- }
-
- # Force another look at balloon location because mouse has switched
- # virtual screens.
- $w->{'location'} = undef unless ( $count == $w->{'current_screen'} );
- $w->{'current_screen'} = $count;
-
- my $xx=undef;
- my $yy=undef; # to hold final toplevel placement
- my $slideOffsetX = 0;
- my $slideOffsetY = 0;
- my $cornerOffset = 5; #default - keep corner away from pointer
- my $testtop = $y - $height - $cornerOffset;
- my $testbottom = $y + $height + (2*$cornerOffset);
- my $testright = $x + $width + (2*$cornerOffset);
- my $testleft = $x - $width - $cornerOffset;
- my $vert='bottom'; #default
- my $horiz='right'; #default
-
-
- if ( defined $w->{'location'} ){
- # Once balloon is activated, **don't** change the location of the balloon.
- # It is annoying to have it jump from one location to another.
- ( $w->{'location'}=~/top/ ) ? ( $vert = 'top' ) : ( $vert = 'bottom' );
- ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' );
-
- if ($vert eq 'top' && $testtop < 0) {
- $yy = 0;
- $slideOffsetY = $testtop;
- }
- elsif ($vert eq 'bottom' && $testbottom > $sh) {
- $slideOffsetY = $testbottom - $sh;
- }
-
- if ($horiz eq 'left' && $testleft < $leftedge) {
- $xx = $leftedge;
- }
- elsif ($horiz eq 'right' && $testright > $rightedge) {
- $slideOffsetX = $testright - $rightedge;
- }
- }
- else {
- #Test balloon positions in the vertical
- if ($testbottom > $sh) {
- #Then offscreen to bottom, check top
- if ($testtop >= 0) {
- $vert = 'top';
- }
- elsif ($y > $sh/2) {
- #still offscreen to top but there is more room above then below
- $vert = 'top';
- $yy=0;
- $slideOffsetY = $testtop;
- }
- if ($vert eq 'bottom'){
- #Calculate Yoffset to fit entire balloon onto screen
- $slideOffsetY = $testbottom - $sh;
- }
- }
- #Test balloon positions in the horizontal
-
- if ($testright > $rightedge) {
- #The offscreen, check left
- if ($testleft >= $leftedge) {
- $horiz = 'left';
- }
- elsif ($x > ($leftedge+$deltax) ) {
- #still offscreen to left but there is more room to left than right
- $horiz = 'left';
- $xx=0;
- $slideOffsetX = $testleft;
- }
- if ($horiz eq 'right'){
- #Calculate Xoffset to fit entire balloon onto screen
- $slideOffsetX = $testright - $rightedge;
- }
- }
- }
-
- $w->{'location'} = $vert.$horiz unless (defined $w->{'location'});
-
- if ($w->{'location'} eq 'bottomright') {
- if ( $slideOffsetX or $slideOffsetY ) {
- $w->{'pointer'}->configure(-image => $w->{img_no});
- }
- else {
- $w->{'pointer'}->configure(-image => $w->{img_tl});
- }
-
- $w->{'pointer'}->place(
- -in=>$w,
-# -relx=>0, -x=>$slideOffsetX + 2,
-# -rely=>0, -y=>$slideOffsetY + 2,
- -relx=>0, -x=>2,
- -rely=>0, -y=>2,
- -bordermode=>'outside',
- -anchor=>'nw');
-
- $xx=$x-$slideOffsetX+(2*$cornerOffset) unless (defined $xx);
- $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
-
- }
- elsif ($w->{'location'} eq 'bottomleft') {
- if ( $slideOffsetX or $slideOffsetY ) {
- $w->{'pointer'}->configure(-image => $w->{img_no});
- }
- else {
- $w->{'pointer'}->configure(-image => $w->{img_tr});
- }
-
- $w->{'pointer'}->place(-in=>$w,
-# -relx=>1, -x=>$slideOffsetX - 2,
-# -rely=>0, -y=>$slideOffsetY + 2,
- -relx=>1, -x=>-2,
- -rely=>0, -y=>2,
- -bordermode=>'outside',
- -anchor=>'ne');
-
- $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
- $yy=$y-$slideOffsetY+(2*$cornerOffset) unless (defined $yy);
-
- }
- elsif ($w->{'location'} eq 'topright') {
- if ( $slideOffsetX or $slideOffsetY ) {
- $w->{'pointer'}->configure(-image => $w->{img_no});
- }
- else {
- $w->{'pointer'}->configure(-image => $w->{img_bl});
- }
-
- $w->{'pointer'}->place(-in=>$w,
-# -relx=>0, -x=>$slideOffsetX + 2,
-# -rely=>1, -y=>$slideOffsetY - 2,
- -relx=>0, -x=>2,
- -rely=>1, -y=>-2,
- -bordermode=>'outside',
- -anchor=>'sw');
-
- $xx=$x-$slideOffsetX+$cornerOffset unless (defined $xx);
- $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
- }
- elsif ($w->{'location'} eq 'topleft') {
- if ( $slideOffsetX or $slideOffsetY ) {
- $w->{'pointer'}->configure(-image => $w->{img_no});
- }
- else {
- $w->{'pointer'}->configure(-image => $w->{img_br});
- }
-
- $w->{'pointer'}->place(-in=>$w,
-# -relx=>1, -x=>$slideOffsetX - 2,
-# -rely=>1, -y=>$slideOffsetY - 2,
- -relx=>1, -x=>-2,
- -rely=>1, -y=>-2,
- -bordermode=>'outside',
- -anchor=>'se');
-
- $xx=$x-$width-$slideOffsetX-$cornerOffset unless (defined $xx);
- $yy=$y-$height-$slideOffsetY-$cornerOffset unless (defined $yy);
- }
-
- $w->{'pointer'}->raise;
- $xx = int($xx);
- $yy = int($yy);
- $w->geometry("+$xx+$yy");
- $w->deiconify();
- $w->raise;
-}
-
-sub SetStatus {
- my ($w) = @_;
- my $client = $w->{'client'};
- my $s = $w->GetOption(-statusbar => $client);
- if (defined $s and $s->winfo('exists')) {
- my $vref = $s->cget(-textvariable);
- return if not defined $client or not exists $w->{'clients'}{$client};
- my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg');
- # Dereference it if it looks like a scalar reference:
- $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
- if (not defined $vref) {
- eval { $s->configure(-text => $msg); };
- } else {
- $$vref = $msg;
- }
- }
-}
-
-sub ClearStatus {
- my ($w) = @_;
- my $client = $w->{'client'};
- my $s = $w->GetOption(-statusbar => $client);
- if (defined $s and $s->winfo('exists')) {
- my $vref = $s->cget(-textvariable);
- if (defined $vref) {
- $$vref = '';
- } else {
- eval { $s->configure(-text => ''); }
- }
- }
-}
-
-sub _destroyed {
- my ($w) = @_;
- # This is called when widget is destroyed (no matter how!)
- # via the ->OnDestroy hook set in Populate.
- # remove ourselves from the list of baloons.
- @balloons = grep($w != $_, @balloons);
-
- # FIXME: If @balloons is now empty perhaps remove the 'all' bindings
- # to reduce overhead until another balloon is created?
-
- # Delete the images
- for (qw(no tl tr bl br)) {
- my $img = delete $w->{"img_$_"};
- $img->delete if defined $img;
- }
-}
-
-1;
-
-