| 1 | # Balloon, pop up help window when mouse lingers over widget. |
| 2 | |
| 3 | use Tk; |
| 4 | use English; |
| 5 | use Carp; |
| 6 | |
| 7 | use Tk::Frame; |
| 8 | use Tk::Balloon; |
| 9 | |
| 10 | my $lmsg = ""; |
| 11 | |
| 12 | my $top = MainWindow->new; |
| 13 | my $f = $top->Frame; |
| 14 | |
| 15 | # status bar widget |
| 16 | my $status = $top->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w'); |
| 17 | $status->pack(-side => "bottom", -fill => "y", -padx => 2, -pady => 1); |
| 18 | |
| 19 | # create the widgets to be explained |
| 20 | my $mb = $top->Menubutton(-relief => 'raised', |
| 21 | -text => 'Menu button'); |
| 22 | my $xxx = 0; |
| 23 | $mb->checkbutton(-label => 'checkbutton', |
| 24 | -variable => \$xxx); |
| 25 | $mb->cascade(-label => 'cascade entry'); |
| 26 | my $menu = $mb->cget(-menu); |
| 27 | my $cm = $menu->Menu(-tearoff => 0); |
| 28 | $mb->entryconfigure('cascade entry', -menu => $cm); |
| 29 | $cm->command(-label => 'first'); |
| 30 | $cm->command(-label => 'second'); |
| 31 | $mb->separator; |
| 32 | $mb->command(-label => 'Close', |
| 33 | -command => sub {$top->destroy;}); |
| 34 | |
| 35 | my $b1 = $top->Button(-text => "Something Unexpected", |
| 36 | -command => sub {$top->destroy;}); |
| 37 | my $b2 = $top->Button(-text => "Something Else Unexpected"); |
| 38 | $b2->configure(-command => sub {$b2->destroy;}); |
| 39 | |
| 40 | # Pack the created widgets: |
| 41 | $mb->pack(-side => "top", -expand => 1); |
| 42 | $b1->pack(-side => "top", -expand => 1); |
| 43 | $b2->pack(-side => "top", -expand => 1); |
| 44 | |
| 45 | my $t = $top->Text(-height => 10, -cursor => 'top_left_arrow')->pack; |
| 46 | $t->insert('end',<<END); |
| 47 | |
| 48 | Move the mouse cursor over the buttons above and let it linger. |
| 49 | A message will be displayed in status box below and a descriptive |
| 50 | balloon will appear. The top button is a menu button which has |
| 51 | different messages set for each menu entry. This text widget has |
| 52 | a balloon attached to it which will change depending on which word |
| 53 | the mouse is over. |
| 54 | |
| 55 | END |
| 56 | |
| 57 | my $c1 = $top->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8); |
| 58 | my $c2 = $top->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8); |
| 59 | my $id = $c1->create('text', 10, 10, |
| 60 | -anchor => 'nw', |
| 61 | -text => "This is a canvas. You can also attach\nballoons to specific items in a canvas"); |
| 62 | $c1->create('rectangle', 40, 60, 80, 80, |
| 63 | -fill => 'red', |
| 64 | -tags => 'rectangle',); |
| 65 | $c1->create('oval', 100, 50, 140, 90, |
| 66 | -fill => 'blue', |
| 67 | -tags => 'circle',); |
| 68 | $c2->create('text', 10, 10, |
| 69 | -anchor => 'nw', |
| 70 | -text => "Or you can attach the balloon\nto the canvas as a whole."); |
| 71 | |
| 72 | # create the balloon widget |
| 73 | my $b = $top->Balloon(-statusbar => $status); |
| 74 | |
| 75 | $b->attach($mb, |
| 76 | -msg => 'Press and hold this button to see the menu.'); |
| 77 | $b->attach($menu, |
| 78 | #-state => 'status', |
| 79 | -balloonposition => 'mouse', |
| 80 | -msg => ['Use this to tear off the menu.', |
| 81 | 'This is a checkbox entry.', |
| 82 | 'cascade', # Cascade entry (ignored by Balloon) |
| 83 | 'separator', # Separator: never active so no message will be displayed for this entry. |
| 84 | 'This is a command entry - it will close this window.', |
| 85 | ], |
| 86 | ); |
| 87 | $b->attach($cm, |
| 88 | -msg => 'This balloon is attached to the cascade menu, not it\'s entries', |
| 89 | #-statusmsg => 'msg cm', |
| 90 | #-balloonmsg => 'cm msg.', |
| 91 | ); |
| 92 | $b->attach($b1, |
| 93 | -balloonmsg => "Close Window", |
| 94 | -statusmsg => "Press this button to close this window"); |
| 95 | $b->attach($b2, |
| 96 | -balloonmsg => "Self-destruct\nButton", |
| 97 | -statusmsg => "Press this button and it will get rid of itself"); |
| 98 | |
| 99 | my $msg = ''; |
| 100 | my @word = ('', ''); # Indicies surrounding the current word. |
| 101 | my @last = ('', ''); # Same for last word. |
| 102 | $b->attach($t, -msg => \$msg, |
| 103 | -balloonposition => 'mouse', # Not really used since the postcommand returns the real position. |
| 104 | -postcommand => sub { if ($word[0] eq $word[1]) { |
| 105 | # No word under mouse - don't post the balloon. |
| 106 | 0; |
| 107 | } else { |
| 108 | # Have a word under mouse - change the message: |
| 109 | my $word = $t->get($word[0], $word[1]); |
| 110 | # Skip it if it contains non-word chars: |
| 111 | return 0 if $word =~ /\W/; |
| 112 | $msg = "The word under the mouse is: $word"; |
| 113 | $t->tag('add', 'sel', $word[0] => $word[1]); |
| 114 | # Find a good place to put the balloon (right below the last char in the word): |
| 115 | my $i = $t->index("$word[1] - 1 chars"); |
| 116 | my @p = $t->bbox($i); |
| 117 | my $x = $t->rootx + $p[0] + $p[2] - 4; |
| 118 | my $y = $t->rooty + $p[1] + $p[3] + 2; |
| 119 | "$x,$y"; |
| 120 | } |
| 121 | }, |
| 122 | -motioncommand => sub { my $x = $t->pointerx - $t->rootx; |
| 123 | my $y = $t->pointery - $t->rooty; |
| 124 | @word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend")); |
| 125 | if ($word[0] eq $last[0] and $word[1] eq $last[1]) { |
| 126 | # Same word - don't cancel the balloon. |
| 127 | 0; |
| 128 | } else { |
| 129 | # New word under mouse - cancel it so a new balloon will be posted. |
| 130 | $t->SelectionClear; |
| 131 | @last = @word; |
| 132 | 1; |
| 133 | } |
| 134 | }, |
| 135 | ); |
| 136 | $b->attach($c1, |
| 137 | -balloonposition => 'mouse', |
| 138 | -msg => {'rectangle' => 'You are over the red rectangle right now.', |
| 139 | $id => 'You are over the text right now.', |
| 140 | 'circle' => 'You are over the blue circle right now.', |
| 141 | }); |
| 142 | $b->attach($c2, |
| 143 | -msg => 'This balloon is attached to the canvas itself.', |
| 144 | ); |
| 145 | |
| 146 | # destroy the balloons when I am destroyed: |
| 147 | # - Balloon.pm adds bindings to all widgets which we now want to remove if we can. |
| 148 | $top->OnDestroy(sub { $b->destroy; }); |
| 149 | |
| 150 | MainLoop; |
| 151 | |