# xisofs v1.3 Perl/Tk Interface to mkisofs / cdwrite
# Copyright (c) 1997 Steve Sherwood (pariah@netcomuk.co.uk)
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# Bubble.pm will be available soon as a stand-alone module.
package Bubble;
use Tk;
use strict;
use Carp;
sub new {
my ($this,%args) = @_;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
$self->initialize(\%args);
return $self;
}
#--------------------
# Initialise Defaults
#--------------------
sub initialize
{
my ($self,$args) = @_;
@{$self->{options}} = (
'relief',
'foreground',
'background',
'bordercolour',
'bordersize',
'font',
'icon',
'iconalign',
'xoffset',
'yoffset',
'delay',
'state',
'contents');
${$self->{relief}}{'default'} = 'flat';
${$self->{foreground}}{'default'} = 'white';
${$self->{background}}{'default'} = 'red';
${$self->{bordercolour}}{'default'} = 'black';
${$self->{bordersize}}{'default'} = '1';
${$self->{font}}{'default'} = 'fixed';
${$self->{icon}}{'default'} = '';
${$self->{iconalign}}{'default'} = 'left';
${$self->{xoffset}}{'default'} = 12;
${$self->{yoffset}}{'default'} = 12;
${$self->{delay}}{'default'} = 1000;
${$self->{state}}{'default'} = 'normal';
${$self->{contents}}{'default'} = 'full';
$self->get_options('default', $args);
}
#----------------------------
# Attach a window to a widget
#----------------------------
sub attach {
my ($self, $parent, %args) = @_;
my $popup = $parent->Toplevel;
$popup->overrideredirect(1);
$popup->withdraw;
${$self->{text}}{$popup} = $args{'-text'}
if (defined($args{'-text'}));
${$self->{textvariable}}{$popup} = $args{'-textvariable'}
if (defined($args{'-textvariable'}));
$self->copy_options($popup);
$self->get_options($popup,\%args);
${$self->{status}}{$popup} = 0;
my $icn = ${$self->{icon}}{$popup};
if (length($icn) > 0)
{
unless (defined(${$self->{pixmap}}{$icn}))
{
${$self->{pixmap}}{$icn} =
$popup->Pixmap(-file => $icn);
}
}
my ($frm,$borderfrm);
if ((${$self->{contents}}{$popup} eq 'full') ||
(${$self->{contents}}{$popup} eq 'partial'))
{
$borderfrm = $popup->Frame(
-background => ${$self->{bordercolour}}{$popup},
-borderwidth => 0,
-relief => 'flat')->pack;
$frm = $borderfrm->Frame(
-background => ${$self->{background}}{$popup},
-borderwidth => 1,
-relief => ${$self->{relief}}{$popup})->pack(
-padx => ${$self->{bordersize}}{$popup},
-pady => ${$self->{bordersize}}{$popup});
}
if (${$self->{contents}}{$popup} eq 'full')
{
if (length(${$self->{icon}}{$popup}) > 0)
{
$frm->Label(
-background => ${$self->{background}}{$popup},
-image => $self->{pixmap}{${$self->{icon}}{$popup}})->pack(
-side => ${$self->{iconalign}}{$popup});
}
if (defined($args{'-text'}))
{
my $text = $frm->Label(
-background => ${$self->{background}}{$popup},
-foreground => ${$self->{foreground}}{$popup},
-font => ${$self->{font}}{$popup},
-text => ${$self->{text}}{$popup})->pack(-side => 'left');
}
elsif (defined($args{'-textvariable'}))
{
my $text = $frm->Label(
-background => ${$self->{background}}{$popup},
-foreground => ${$self->{foreground}}{$popup},
-font => ${$self->{font}}{$popup},
-textvariable => ${$self->{textvariable}}{$popup})->pack(-side => 'left');
}
else
{
croak "Either -text, or -textvariable must be specified";
}
}
$parent->bind('<Enter>',['Bubble::activate',$self,Ev('X'),Ev('Y'),$popup]);
$parent->bind('<Leave>',['Bubble::popleave',$self,Ev('X'),Ev('Y'),$popup]);
$parent->bind('<Motion>',['Bubble::popmove',$self,Ev('X'),Ev('Y'),$popup]);
$parent->bind('<Button>',['Bubble::popleave',$self,Ev('X'),Ev('Y'),$popup]);
$popup->bind('<Leave>',['Bubble::popleave',$self,Ev('X'),Ev('Y'),$popup]);
if (${$self->{contents}}{$popup} eq 'partial')
{
return $frm;
}
else
{
return $popup;
}
}
#----------------------
# re-configure a widget
#----------------------
sub configure
{
my ($self, %args) = @_;
}
#------------------------------------------
# Activate, ie start waiting the delay time
#------------------------------------------
sub activate
{
my ($w,$self,$x,$y,$parent) = @_;
return if (${$self->{state}}{$parent} eq 'disabled');
${$self->{status}}{$parent} = 1;
${$self->{after}}{$parent} =
$parent->after(${$self->{delay}}{$parent},sub{popup($self,$parent,
$x+${$self->{xoffset}}{$parent},$y+${$self->{yoffset}}{$parent})});
}
#-----------------------
# Show the bubble window
#-----------------------
sub popup
{
my ($self,$parent,$x,$y) = @_;
return if (${$self->{status}}{$parent} == 0);
$parent->geometry("+$x+$y");
$parent->deiconify();
$parent->raise;
${$self->{status}}{$parent} = 2;
}
#--------------------------------
# Pointer have moved out the area
#--------------------------------
sub popleave
{
my ($w,$self,$x,$y,$parent) = @_;
if (${$self->{status}}{$parent} == 1)
{
$parent->afterCancel(${$self->{after}}{$parent})
}
$parent->withdraw;
${$self->{status}}{$parent} = 0;
}
#----------------------------------
# Pointer has moved within the area
#----------------------------------
sub popmove
{
my ($w,$self,$x,$y,$parent) = @_;
return if (${$self->{state}}{$parent} eq 'disabled');
if (${$self->{status}}{$parent} == 1)
{
$parent->afterCancel(${$self->{after}}{$parent})
}
else
{
$parent->withdraw;
}
$parent->withdraw;
${$self->{after}}{$parent} =
$parent->after(${$self->{delay}}{$parent},sub{popup($self,$parent,
$x+${$self->{xoffset}}{$parent},$y+${$self->{yoffset}}{$parent})});
${$self->{status}}{$parent} = 1;
}
#----------------------------
# Sort out any options passed
#----------------------------
sub get_options
{
my ($self, $index,$args) = @_;
foreach(@{$self->{options}})
{
${$self->{$_}}{$index} = delete $$args{"-$_"}
if (defined($$args{"-$_"}));
}
if (${$self->{icon}}{$index} eq 'none')
{
delete ${$self->{icon}}{$index};
}
}
#-------------------------
# Copy the default options
#-------------------------
sub copy_options
{
my ($self,$index) = @_;
foreach(@{$self->{options}})
{
${$self->{$_}}{$index} = ${$self->{$_}}{'default'};
}
}
1;
__END__
=head1 NAME
Tk::Bubble - Pop up help windows
=head1 SYNOPSYS
use Tk::Bubble;
...
$bubble = new Bubble(<options..>);
$bubble->attach(<widget>,<options>);
$bubble->configure(<widget>,<options>);
=head1 DESCRIPTION
B<Bubble> is a bubble help system (or sometimes called tooltips/balloon help)
which allows a window to be displayed after a certain amount of time. This
window will vanish if the mouse is moved or a button is pressed.
=head1 CREATE OBJECT
To use the bubble help, a new bubble object must first be created.
I<$bubble = new Bubble(options);>. The following options are available and
will be used as defaults for any popup windows created with this
object.
=over 4
=item B<-background>
Specifies the background colour of the window. The default is
'red'.
=item B<-bordercolour>
Specifies the colour of the border around the popup window. The default
is 'black'.
=item B<-bordersize>
Specifies the size of the border around the popup window in pixels. The
default is 1.
=item B<-contents>
This specifies how the window will be drawn. I<full> which is the default
will draw the popup window using the parameters supplied. I<partial> will
draw the border and the inner window as specified, but not add any text.
I<none> will simply create the framework for the popup button, but not
actually create anything. This option is useful if you have a complex
popup window to draw, as the attach will return the innermost object which
can be use to add any other objects.
=item B<-delay>
This is the delay in milliseconds before the window is displayed. The default
is 1000.
=item B<-font>
This is the font to be used for the text. The default is 'fixed'.
=item B<-foreground>
This is the foreground colour for the popup window. The default is 'white'.
=item B<-icon>
This will add an icon to the popup window. It must be an XPM image. It
will be aligned in the window as specified by I<-iconalign>. The default
is no icon.
=item B<-iconalign>
This specifies the alignment of the icon. It can be one of I<left>, I<right>,
I<top> and I<bottom>. The default is 'left'.
=item B<-relief>
This specifies the relief of the window inside the border. It can be any of
the normally support relief values and by default is 'flat'.
=item B<-state>
This is either I<normal> or I<disabled>. This affects all popup windows
in this object and the default is 'normal'.
=item B<-xoffset>
This is how many pixels in the x direction the popup window is offset
from the mouse pointer. The default is 12.
=item B<-yoffset>
This is how many pixels in the y direction the popup window is offset
from the mouse pointer. The default is 12.
=back
=head1 AUTHOR
Steve Sherwood <pariah@netcomuk.co.uk>
=cut