home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Balloon.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  8.7 KB  |  333 lines
  1. # $Id: Balloon.pm,v 1.3 1997/02/08 19:20:49 rsi Exp $
  2. #
  3. # The help widget that provides both "balloon" and "status bar"
  4. # types of help messages.
  5.  
  6. package Tk::Balloon;
  7.  
  8. use Tk qw(Ev Exists);
  9. use Carp;
  10. require Tk::Toplevel;
  11.  
  12. Tk::Widget->Construct("Balloon");
  13. @Tk::Balloon::ISA = qw(Tk::Toplevel);
  14.  
  15. use strict;
  16.  
  17. my @balloons;
  18.  
  19. sub ClassInit {
  20.     my ($class, $mw) = @_;
  21.     $mw->bind("all", "<Motion>", ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
  22.     $mw->bind("all", "<Leave>",  ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
  23.     $mw->bind("all", "<Button>", 'Tk::Balloon::ButtonDown');
  24.     return $class;
  25. }
  26.  
  27. sub Populate {
  28.     my ($w, $args) = @_;
  29.  
  30.     $w->SUPER::Populate($args);
  31.  
  32.     $w->overrideredirect(1);
  33.     $w->withdraw;
  34.     # Only the container frame's background should be black... makes it
  35.     # look better.
  36.     $w->configure(-background => "black");
  37.     my $a = $w->Frame;
  38.     my $m = $w->Frame;
  39.     $a->configure(-bd => 0);
  40.     my $al = $a->Label(-bd => 0,
  41.                -relief => "flat",
  42.                -bitmap => '@' . Tk->findINC("balArrow.xbm"));
  43.     $al->pack(-side => "left", -padx => 1, -pady => 1, -anchor => "nw");
  44.     $m->configure(-bd => 0);
  45.     my $ml = $m->Label(-bd => 0,
  46.                -padx => 0,
  47.                -pady => 0,
  48.                -text => $args->{-message});
  49.     $w->Advertise("message" => $ml);
  50.     $ml->pack(-side => "left",
  51.           -anchor => "w",
  52.           -expand => 1,
  53.           -fill => "both",
  54.           -padx => 10,
  55.           -pady => 3);
  56.     $a->pack(-fill => "both", -side => "left");
  57.     $m->pack(-fill => "both", -side => "left");
  58.  
  59.     # append to global list of balloons
  60.     push(@balloons, $w);
  61.     $w->{"popped"} = 0;
  62.     $w->{"buttonDown"} = 0;
  63.     $w->ConfigSpecs(-installcolormap => ["PASSIVE", "installColormap", "InstallColormap", 0],
  64.             -initwait => ["PASSIVE", "initWait", "InitWait", 350],
  65.             -state => ["PASSIVE", "state", "State", "both"],
  66.             -statusbar => ["PASSIVE", "statusBar", "StatusBar", undef],
  67.             -background => ["DESCENDANTS", "background", "Background", "#C0C080"],
  68.             -font => [$ml, "font", "Font", "-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*"],
  69.             -borderwidth => ["SELF", "borderWidth", "BorderWidth", 1]
  70. );
  71.  
  72. }
  73.  
  74. # attach a client to the balloon
  75. sub attach {
  76.     my ($w, $client, %args) = @_;
  77.     my $msg = delete $args{-msg};
  78.     my $balloonmsg = delete $args{-balloonmsg};
  79.     my $statusmsg = delete $args{-statusmsg};
  80.     $balloonmsg = $msg if (not defined $balloonmsg);
  81.     $statusmsg = $msg if (not defined $statusmsg);
  82.     $w->{"clients"}->{$client} = {-balloonmsg => $balloonmsg, -statusmsg => $statusmsg};
  83.     $client->OnDestroy([$w, 'detach', $client]);
  84. }
  85.  
  86. # detach a client from the balloon.
  87. sub detach 
  88. {
  89.     my ($w, $client) = @_;
  90.     return unless Exists($w);
  91.     $w->Deactivate if ($w->{"client"} == $client);
  92.     delete $w->{"clients"}->{$client};
  93. }
  94.  
  95. sub Motion {
  96.     my ($ewin, $x, $y, $s) = @_;
  97.     
  98.     # Don't do anything if a button is down or a grab is active
  99.     return if ($s || $ewin->grabCurrent());
  100.  
  101.     # Find which window we are over
  102.     my $over = $ewin->Containing($x, $y);
  103.     my $w;
  104.  
  105.     foreach $w (@balloons) {
  106.     next if (($w->cget(-state) eq "none"));    # popping up disabled
  107.  
  108.     # if cursor has moved over the balloon -- ignore
  109.     next if ((defined $over) && $over->toplevel eq $w);
  110.  
  111.     # find the client window that matches
  112.     my $client = $over;
  113.     while (defined $client) {
  114.         last if (exists $w->{"clients"}->{$client});
  115.         $client = $client->Parent;
  116.     }
  117.     if (defined $client) {
  118.         unless ($client->IS($w->{"client"})) {  
  119.         $w->Deactivate;
  120.         $w->{"client"} = $client;
  121.         $w->{"delay"}  = $client->after($w->cget(-initwait), sub {$w->SwitchToClient($client);});
  122.         }
  123.     } 
  124.     else {
  125.         # cursor is at a position covered by a non client
  126.         # pop down the balloon if it is up or scheduled.
  127.         $w->Deactivate if ($w->{"popped"} || $w->{"delay"});
  128.         $w->{"client"} = undef;
  129.     }
  130.     }
  131. }
  132.  
  133. sub ButtonDown {
  134.     my ($ewin) = @_;
  135.     my $w;
  136.     foreach $w (@balloons) {
  137.     $w->Deactivate if ($w->{"popped"} || $w->{"delay"});
  138.     }
  139. }
  140.  
  141. # switch the balloon to a new client
  142. sub SwitchToClient {
  143.     my ($w, $client) = @_;
  144.     return unless Exists($w);
  145.     return unless Exists($client);
  146.     return unless $client->IS($w->{"client"});
  147.     return if ($w->grabCurrent);
  148.     my $state = $w->cget(-state);
  149.     $w->Popup if ($state =~ /both|balloon/);
  150.     $w->SetStatus if ($state =~ /both|status/);
  151.     $w->{"popped"} = 1;
  152.     $w->{"delay"}  = $w->repeat(200, ['Verify', $w]);
  153. }
  154.  
  155. sub Verify {
  156.     my ($w) = @_;
  157.     $w->Deactivate if ($w->grabCurrent);
  158. }
  159.  
  160. sub Deactivate {
  161.     my ($w) = @_;
  162.     my $delay = delete $w->{"delay"};
  163.     $delay->cancel if defined $delay;
  164.     if ($w->{"popped"}) {
  165.     $w->withdraw;
  166.     $w->ClearStatus;
  167.     $w->{"popped"} = 0;
  168.     } else {
  169.     $w->{"client"} = undef;
  170.     }
  171. }
  172.  
  173. sub Popup {
  174.     my ($w) = @_;
  175.     if ($w->cget(-installcolormap)) {
  176.     $w->colormapwindows($w->winfo("toplevel"))
  177.     }
  178.     my $client = $w->{"client"};
  179.     return if ((not defined $client) ||
  180.            (not exists $w->{"clients"}->{$client}));
  181.     my $msg = $w->{"clients"}->{$client}->{-balloonmsg};
  182.     $w->Subwidget("message")->configure(-text => $msg);
  183.     $w->idletasks;
  184.  
  185.     return unless Exists($w);
  186.     return unless Exists($client);
  187.  
  188.     my $x = int($client->rootx + $client->width/2);
  189.     my $y = int($client->rooty + int ($client->height/1.3));
  190.     $w->geometry("+$x+$y");
  191.     $w->deiconify();
  192.     $w->raise;
  193.     $w->update;
  194. }
  195.  
  196. sub SetStatus {
  197.     my ($w) = @_;
  198.     my $s = $w->cget(-statusbar);
  199.     if ((defined $s) && $s->winfo("exists")) {
  200.     my $vref = $s->cget(-textvariable);
  201.     my $client = $w->{"client"};
  202.     return if ((not defined $client) ||
  203.            (not exists $w->{"clients"}->{$client}));
  204.     my $msg = $w->{"clients"}->{$client}->{-statusmsg} || '';
  205.     if (not defined $vref) {
  206.         eval { $s->configure(-text => $msg); };
  207.     } else {
  208.         $$vref = $msg;
  209.     }
  210.     }
  211. }
  212.  
  213. sub ClearStatus {
  214.     my ($w) = @_;
  215.     my $s = $w->cget(-statusbar);
  216.     if (defined $s && $s->winfo("exists")) {
  217.     my $vref = $s->cget(-textvariable);
  218.     if (defined $vref) {
  219.         $$vref = "";
  220.     } else {
  221.         eval { $s->configure(-text => ""); }
  222.     }
  223.     }
  224. }
  225.  
  226. sub destroy {
  227.     my ($w) = @_;
  228.     @balloons = grep($w != $_, @balloons);
  229.     $w->SUPER::destroy;
  230. }
  231.  
  232. 1;
  233.  
  234. __END__
  235.  
  236. =head1 NAME
  237.  
  238. Tk::Balloon - pop up help balloons.
  239.  
  240. =head1 SYNOPSIS
  241.  
  242.     use Tk::Balloon;
  243.     ...
  244.     $b = $top->Balloon(-statusbar => $status_bar_widget);
  245.     $b->attach($widget,
  246.            -balloonmsg => "Balloon help message",
  247.            -statusmsg => "Status bar message");
  248.  
  249. =head1 DESCRIPTION
  250.  
  251. B<Balloon> provides the framework to create and attach help
  252. balloons to various widgets so that when the mouse pauses over the
  253. widget for more than a specified amount of time, a help balloon is
  254. poppped up.
  255.  
  256. B<Balloon> accepts all the options that the B<Frame> widget
  257. accepts. In addition, the following options are also recognized.
  258.  
  259. =over 4
  260.  
  261. =item B<-initwait>
  262.  
  263. Specifies the amount of time to wait without activity before
  264. popping up a help balloon. Specified in milliseconds. Defaults to
  265. 350 milliseconds. This applies only to the popped up balloon.
  266. The status bar message is shown instantly.
  267.  
  268. =item B<-state>
  269.  
  270. Can be one of B<balloon>, B<status>, B<both> or B<none> indicating
  271. that the help balloon, status bar help, both or none respectively
  272. should be activated when the mouse pauses over the client widget.
  273.  
  274. =item B<-statusbar>
  275.  
  276. Specifies the widget used to display the status message. This
  277. widget should accept the B<-text> option and is typically a
  278. B<Label>.
  279.  
  280. =back
  281.  
  282. =head1 METHODS
  283.  
  284. The B<Balloon> widget supports only two non-standard methods:
  285.  
  286. =over 4
  287.  
  288. =item B<attach(>I<widget>, I<options>B<)>
  289. Attaches the widget indicated by I<widget> to the help system. The
  290. options can be:
  291.  
  292. =over 4
  293.  
  294. =item B<-statusmsg>
  295.  
  296. The argument is the message to be shown on the status bar when the
  297. mouse passes over this client. If this is not specified, but
  298. B<-msg> is specified then the message displayed on the status bar
  299. is the same as the argument for B<-msg>.
  300.  
  301. =item B<-balloonmsg>
  302.  
  303. The argument is the message to be displayed in the balloon that
  304. will be popped up when the mouse pauses over the client. As with
  305. B<-statusmsg> if this is not specified, then it takes its value
  306. from the B<-msg> specification as any. If neither B<-balloonmsg>
  307. nor B<-msg> are specified, then an empty balloon will be popped
  308. up... this is silly, but there it is.
  309.  
  310. =item B<-msg>
  311.  
  312. The catch-all for B<-statusmsg> and B<-balloonmsg>. This is a
  313. convenient way of specifying the same message to be displayed in
  314. both the balloon and the status bar for the client.
  315.  
  316. =back
  317.  
  318. =item B<detach(>I<widget>B<)>
  319.  
  320. Detaches the specified widget I<widget> from the help system.
  321.  
  322. =back
  323.  
  324. =head1 AUTHOR
  325.  
  326. B<Rajappa Iyer> rsi@earthling.net
  327.  
  328. This code and documentation is derived from Balloon.tcl from the
  329. Tix4.0 distribution by Ioi Lam. This code may be redistributed
  330. under the same terms as Perl.
  331.  
  332. =cut
  333.