Gecko [ oosaka-bmw-kaitori.com ]

Name	Size	Permission
DragDrop	[ DIR ]	drwxr-xr-x
Event	[ DIR ]	drwxr-xr-x
Menu	[ DIR ]	drwxr-xr-x
TableMatrix	[ DIR ]	drwxr-xr-x
Text	[ DIR ]	drwxr-xr-x
pTk	[ DIR ]	drwxr-xr-x
804delta.pod	2.65 KB	-rw-r--r--
Adjuster.pm	10.91 KB	-rw-r--r--
Adjuster.pod	6.92 KB	-rw-r--r--
After.pm	1.9 KB	-rw-r--r--
Animation.pm	4.91 KB	-rw-r--r--
Animation.pod	2.84 KB	-rw-r--r--
Balloon.pm	20.7 KB	-rw-r--r--
Balloon.pod	9.96 KB	-rw-r--r--
Bitmap.pm	225 B	-rw-r--r--
Bitmap.pod	2.88 KB	-rw-r--r--
BrowseEntry.pm	13.32 KB	-rw-r--r--
BrowseEntry.pod	5.07 KB	-rw-r--r--
Button.pm	5.95 KB	-rw-r--r--
Button.pod	7.62 KB	-rw-r--r--
Camel.xpm	1.3 KB	-rw-r--r--
Canvas.pm	28.22 KB	-rw-r--r--
Canvas.pod	86.71 KB	-rw-r--r--
Checkbutton.pm	997 B	-rw-r--r--
Checkbutton.pod	11.08 KB	-rw-r--r--
Clipboard.pm	1.83 KB	-rw-r--r--
Clipboard.pod	2.83 KB	-rw-r--r--
CmdLine.pm	15.82 KB	-rw-r--r--
CmdLine.pod	14.12 KB	-rw-r--r--
ColorEdit.xpm	2.62 KB	-rw-r--r--
ColorEditor.pm	22.8 KB	-rw-r--r--
ColorEditor.pod	3.67 KB	-rw-r--r--
Common.pod	266 B	-rw-r--r--
Compound.pm	712 B	-rw-r--r--
Compound.pod	8.61 KB	-rw-r--r--
Config.pm	414 B	-rw-r--r--
ConfigSpecs.pod	7.94 KB	-rw-r--r--
Configure.pm	1.21 KB	-rw-r--r--
Credits	149 B	-rw-r--r--
DItem.pod	11.98 KB	-rw-r--r--
Derived.pm	11.83 KB	-rw-r--r--
Derived.pod	2.2 KB	-rw-r--r--
Dialog.pm	1.66 KB	-rw-r--r--
Dialog.pod	2.82 KB	-rw-r--r--
DialogBox.pm	4.54 KB	-rw-r--r--
DialogBox.pod	4.39 KB	-rw-r--r--
DirTree.pm	6.47 KB	-rw-r--r--
DirTree.pod	4.14 KB	-rw-r--r--
Dirlist.pm	1.89 KB	-rw-r--r--
DragDrop.pm	7.18 KB	-rw-r--r--
DropSite.pm	4.96 KB	-rw-r--r--
DropSite.pod	641 B	-rw-r--r--
DummyEncode.pm	729 B	-rw-r--r--
English.pm	9.63 KB	-rw-r--r--
Entry.pm	15.56 KB	-rw-r--r--
Entry.pod	22.23 KB	-rw-r--r--
Error.pod	4.98 KB	-rw-r--r--
ErrorDialog.pm	3.39 KB	-rw-r--r--
Event.pm	458 B	-rw-r--r--
Eventloop.pod	1.18 KB	-rw-r--r--
FBox.pm	29.84 KB	-rw-r--r--
FBox.pod	1.59 KB	-rw-r--r--
FileSelect.pm	14.76 KB	-rw-r--r--
FileSelect.pod	4.44 KB	-rw-r--r--
FloatEntry.pm	1.99 KB	-rw-r--r--
Font.pm	2.8 KB	-rw-r--r--
Font.pod	15.2 KB	-rw-r--r--
Frame.pm	7.99 KB	-rw-r--r--
Frame.pod	3.99 KB	-rw-r--r--
HList.pm	13.34 KB	-rw-r--r--
HList.pod	35.38 KB	-rw-r--r--
IO.pm	2.97 KB	-rw-r--r--
IO.pod	1.21 KB	-rw-r--r--
IconList.pm	19.2 KB	-rw-r--r--
IconList.pod	1.36 KB	-rw-r--r--
Image.pm	1.48 KB	-rw-r--r--
Image.pod	4.07 KB	-rw-r--r--
InputO.pm	275 B	-rw-r--r--
InputO.pod	1.27 KB	-rw-r--r--
Internals.pod	5.62 KB	-rw-r--r--
ItemStyle.pm	703 B	-rw-r--r--
JPEG.pm	926 B	-rw-r--r--
LabEntry.pm	773 B	-rw-r--r--
LabFrame.pm	3.47 KB	-rw-r--r--
LabFrame.pod	2.34 KB	-rw-r--r--
LabRadio.pm	1.6 KB	-rw-r--r--
Label.pm	386 B	-rw-r--r--
Label.pod	3.57 KB	-rw-r--r--
Labelframe.pm	292 B	-rw-r--r--
Labelframe.pod	5.87 KB	-rw-r--r--
Listbox.pm	22.07 KB	-rw-r--r--
Listbox.pod	26.01 KB	-rw-r--r--
MMtry.pm	1.61 KB	-rw-r--r--
MMutil.pm	13.13 KB	-rw-r--r--
MainWindow.pm	5.6 KB	-rw-r--r--
MainWindow.pod	2.2 KB	-rw-r--r--
MakeDepend.pm	5.52 KB	-rw-r--r--
Menu.pm	29.71 KB	-rw-r--r--
Menu.pod	32.08 KB	-rw-r--r--
Menubar.pm	382 B	-rw-r--r--
Menubutton.pm	10.66 KB	-rw-r--r--
Menubutton.pod	8.16 KB	-rw-r--r--
Message.pm	419 B	-rw-r--r--
Message.pod	5.13 KB	-rw-r--r--
MsgBox.pm	18.05 KB	-rw-r--r--
MsgBox.pod	1.48 KB	-rw-r--r--
Mwm.pm	311 B	-rw-r--r--
Mwm.pod	3.28 KB	-rw-r--r--
NBFrame.pm	368 B	-rw-r--r--
NoteBook.pm	10.27 KB	-rw-r--r--
NoteBook.pod	5.75 KB	-rw-r--r--
Optionmenu.pm	2.9 KB	-rw-r--r--
Optionmenu.pod	1.94 KB	-rw-r--r--
PNG.pm	726 B	-rw-r--r--
Pane.pm	12.9 KB	-rw-r--r--
Panedwindow.pm	5.03 KB	-rw-r--r--
Panedwindow.pod	10.56 KB	-rw-r--r--
Photo.pm	415 B	-rw-r--r--
Photo.pod	18.08 KB	-rw-r--r--
Pixmap.pm	266 B	-rw-r--r--
Pixmap.pod	1.81 KB	-rw-r--r--
Popup.pod	3.07 KB	-rw-r--r--
Pretty.pm	1.74 KB	-rw-r--r--
ProgressBar.pm	11.52 KB	-rw-r--r--
README.Adjust	3.28 KB	-rw-r--r--
ROText.pm	1.06 KB	-rw-r--r--
ROText.pod	725 B	-rw-r--r--
Radiobutton.pm	1.03 KB	-rw-r--r--
Radiobutton.pod	10.69 KB	-rw-r--r--
Region.pm	2.95 KB	-rw-r--r--
Reindex.pm	5.19 KB	-rw-r--r--
ReindexedROText.pm	255 B	-rw-r--r--
ReindexedText.pm	245 B	-rw-r--r--
Scale.pm	6.68 KB	-rw-r--r--
Scale.pod	10.05 KB	-rw-r--r--
Scrollbar.pm	9.97 KB	-rw-r--r--
Scrollbar.pod	13.71 KB	-rw-r--r--
Scrolled.pod	1.86 KB	-rw-r--r--
Spinbox.pm	2.26 KB	-rw-r--r--
Spinbox.pod	25.74 KB	-rw-r--r--
Stats.pm	407 B	-rw-r--r--
Submethods.pm	744 B	-rw-r--r--
Submethods.pod	662 B	-rw-r--r--
SunConst.pod	405 B	-rw-r--r--
TList.pm	7.1 KB	-rw-r--r--
TList.pod	18.48 KB	-rw-r--r--
Table.pm	11.69 KB	-rw-r--r--
Table.pod	2.41 KB	-rw-r--r--
TableMatrix.pm	26.1 KB	-rw-r--r--
TableMatrix.pod	56.32 KB	-rw-r--r--
Tcl-perl.pod	5.16 KB	-rw-r--r--
Text.pm	43.07 KB	-rw-r--r--
Text.pod	79.41 KB	-rw-r--r--
TextEdit.pm	14.06 KB	-rw-r--r--
TextList.pm	25.78 KB	-rw-r--r--
TextUndo.pm	24.76 KB	-rw-r--r--
TextUndo.pod	1.59 KB	-rw-r--r--
Tiler.pm	4.07 KB	-rw-r--r--
Tiler.pod	689 B	-rw-r--r--
TixGrid.pm	28.23 KB	-rw-r--r--
TixGrid.pod	15.77 KB	-rw-r--r--
Tk.xbm	3.07 KB	-rw-r--r--
Tk.xpm	1.29 KB	-rw-r--r--
TkXSUB.def	3.09 KB	-rw-r--r--
Toplevel.pm	5.15 KB	-rw-r--r--
Toplevel.pod	5.66 KB	-rw-r--r--
Trace.pm	12.21 KB	-rw-r--r--
Tree.pm	5.9 KB	-rw-r--r--
Tree.pod	7.87 KB	-rw-r--r--
UserGuide.pod	19.43 KB	-rw-r--r--
Widget.pm	42.71 KB	-rw-r--r--
Widget.pod	25.06 KB	-rw-r--r--
WidgetDemo.pod	1.7 KB	-rw-r--r--
WinPhoto.pm	1.28 KB	-rw-r--r--
Wm.pm	3.75 KB	-rw-r--r--
Wm.pod	29.5 KB	-rw-r--r--
X.pm	5.73 KB	-rw-r--r--
X.pod	5.37 KB	-rw-r--r--
X11Font.pm	3.04 KB	-rw-r--r--
X11Font.pod	1.6 KB	-rw-r--r--
Xcamel.gif	4.09 KB	-rw-r--r--
Xlib.pm	276 B	-rw-r--r--
Xrm.pm	121 B	-rw-r--r--
Xrm.pod	1.06 KB	-rw-r--r--
act_folder.xbm	227 B	-rw-r--r--
act_folder.xpm	438 B	-rw-r--r--
after.pod	6 KB	-rw-r--r--
anim.gif	2.47 KB	-rw-r--r--
arrowdownwin.xbm	234 B	-rw-r--r--
balArrow.xbm	123 B	-rw-r--r--
bind.pod	21.88 KB	-rw-r--r--
bindtags.pod	4.09 KB	-rw-r--r--
callbacks.pod	2.91 KB	-rw-r--r--
cbxarrow.xbm	263 B	-rw-r--r--
chooseColor.pod	1.81 KB	-rw-r--r--
chooseDirectory.pod	2.79 KB	-rw-r--r--
composite.pod	5.01 KB	-rw-r--r--
event.pod	14.93 KB	-rw-r--r--
exit.pod	974 B	-rw-r--r--
file.xbm	233 B	-rw-r--r--
file.xpm	298 B	-rw-r--r--
fileevent.pod	4.61 KB	-rw-r--r--
focus.pod	6.22 KB	-rw-r--r--
folder.xbm	215 B	-rw-r--r--
folder.xpm	414 B	-rw-r--r--
form.pod	13.05 KB	-rw-r--r--
getOpenFile.pod	6.86 KB	-rw-r--r--
grab.pod	4.86 KB	-rw-r--r--
grid.pod	16.43 KB	-rw-r--r--
icon.gif	1.88 KB	-rw-r--r--
install.pm	764 B	-rw-r--r--
license.terms	1.75 KB	-rw-r--r--
mega.pod	10.61 KB	-rw-r--r--
messageBox.pod	1.89 KB	-rw-r--r--
openfile.xbm	245 B	-rw-r--r--
openfolder.xbm	227 B	-rw-r--r--
openfolder.xpm	418 B	-rw-r--r--
option.pod	8.4 KB	-rw-r--r--
options.pod	24.28 KB	-rw-r--r--
overview.pod	4.55 KB	-rw-r--r--
pTk.pod	16.81 KB	-rw-r--r--
pack.pod	10.31 KB	-rw-r--r--
palette.pod	3.3 KB	-rw-r--r--
place.pod	10.46 KB	-rw-r--r--
prolog.ps	9.32 KB	-rw-r--r--
selection.pod	6.79 KB	-rw-r--r--
send.pod	4.35 KB	-rw-r--r--
srcfile.xpm	302 B	-rw-r--r--
textfile.xpm	310 B	-rw-r--r--
tixWm.pod	1.95 KB	-rw-r--r--
tkGlue.def	2.38 KB	-rw-r--r--
tkGlue.h	2.34 KB	-rw-r--r--
tkGlue.m	1.46 KB	-rw-r--r--
tkGlue.t	2.3 KB	-rw-r--r--
tkGlue_f.h	341 B	-rw-r--r--
tkvars.pod	3.52 KB	-rw-r--r--
tranicon.gif	1.68 KB	-rw-r--r--
typemap	1.61 KB	-rw-r--r--
vtab.def	4.04 KB	-rw-r--r--
widgets.pm	309 B	-rw-r--r--
widgets.pod	286 B	-rw-r--r--
win.xbm	284 B	-rw-r--r--
winfolder.xpm	719 B	-rw-r--r--
wintext.xpm	743 B	-rw-r--r--

Code Editor : Balloon.pm

#
# 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 = '4.012'; # was: 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],
		   );
}

sub _get_client {
    my ($w, $client) = @_;
    if ($client->can("Subwidget") and my $scrolled = $client->Subwidget("scrolled")) {
        $scrolled;
    } else {
	$client;
    }
}

# attach a client to the balloon
sub attach {
    my ($w, $client, %args) = @_;
    $client = $w->_get_client($client);
    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) = @_;
    $client = $w->_get_client($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});
	    if ($client->can("MasterMenu")) {
		my $master = $client->MasterMenu;
		if ($master && exists $w->{'clients'}{$master}) {
		    $w->{'clients'}{$client} = $w->{'clients'}{$master};
		    last;
		}
	    }
	    $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;

# Ignore grab check if $w is the balloon itself.
    # XXX Why is this necessary? Is it possible to remove the grabBad
    # condition in SwitchToClient altogether?
    return 0 if $w->isa(__PACKAGE__);

# 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;
    }
}

${this.title}

Code Editor : Balloon.pm