"Fossies" - the Fresh Open Source Software Archive 
Member "Tk-804.036/demos/demos/widget_lib/balloon.pl" (15 Nov 2013, 5700 Bytes) of package /linux/misc/Tk-804.036.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
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 $tm = $top->Menu(-title => "Balloon menu");
36 $tm->cascade(-label => "Toplevel menu", -menu => $menu);
37 $top->configure(-menu => $tm);
38
39 my $b1 = $top->Button(-text => "Something Unexpected",
40 -command => sub {$top->destroy;});
41 my $b2 = $top->Button(-text => "Something Else Unexpected");
42 $b2->configure(-command => sub {$b2->destroy;});
43
44 # Pack the created widgets:
45 $mb->pack(-side => "top", -expand => 1);
46 $b1->pack(-side => "top", -expand => 1);
47 $b2->pack(-side => "top", -expand => 1);
48
49 my $t = $top->Text(-height => 10, -cursor => 'top_left_arrow')->pack;
50 $t->insert('end',<<END);
51
52 Move the mouse cursor over the buttons above and let it linger.
53 A message will be displayed in status box below and a descriptive
54 balloon will appear. The top button is a menu button which has
55 different messages set for each menu entry. This text widget has
56 a balloon attached to it which will change depending on which word
57 the mouse is over.
58
59 END
60
61 my $clbf = $top->Frame->pack;
62 my $cf = $clbf->Frame->pack(-side => "left");
63
64 my $c1 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8);
65 my $c2 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8);
66 my $id = $c1->create('text', 10, 10,
67 -anchor => 'nw',
68 -text => "This is a canvas. You can also attach\nballoons to specific items in a canvas");
69 $c1->create('rectangle', 40, 60, 80, 80,
70 -fill => 'red',
71 -tags => 'rectangle',);
72 $c1->create('oval', 100, 50, 140, 90,
73 -fill => 'blue',
74 -tags => 'circle',);
75 $c2->create('text', 10, 10,
76 -anchor => 'nw',
77 -text => "Or you can attach the balloon\nto the canvas as a whole.");
78
79 my $lb = $clbf->Listbox->pack(-side => "left");
80 $lb->insert(qw/end one two three four/);
81
82 # create the balloon widget
83 my $b = $top->Balloon(-statusbar => $status);
84
85 $b->attach($mb,
86 -msg => 'Press and hold this button to see the menu.');
87 $b->attach($menu,
88 #-state => 'status',
89 -balloonposition => 'mouse',
90 -msg => ['Use this to tear off the menu.',
91 'This is a checkbox entry.',
92 'cascade', # Cascade entry (ignored by Balloon)
93 'separator', # Separator: never active so no message will be displayed for this entry.
94 'This is a command entry - it will close this window.',
95 ],
96 );
97 $b->attach($cm,
98 -msg => 'This balloon is attached to the cascade menu, not it\'s entries',
99 #-statusmsg => 'msg cm',
100 #-balloonmsg => 'cm msg.',
101 );
102 $b->attach($b1,
103 -balloonmsg => "Close Window",
104 -statusmsg => "Press this button to close this window");
105 $b->attach($b2,
106 -balloonmsg => "Self-destruct\nButton",
107 -statusmsg => "Press this button and it will get rid of itself");
108
109 my $msg = '';
110 my @word = ('', ''); # Indicies surrounding the current word.
111 my @last = ('', ''); # Same for last word.
112 $b->attach($t, -msg => \$msg,
113 -balloonposition => 'mouse', # Not really used since the postcommand returns the real position.
114 -postcommand => sub { if ($word[0] eq $word[1]) {
115 # No word under mouse - don't post the balloon.
116 0;
117 } else {
118 # Have a word under mouse - change the message:
119 my $word = $t->get($word[0], $word[1]);
120 # Skip it if it contains non-word chars:
121 return 0 if $word =~ /\W/;
122 $msg = "The word under the mouse is: $word";
123 $t->tag('add', 'sel', $word[0] => $word[1]);
124 # Find a good place to put the balloon (right below the last char in the word):
125 my $i = $t->index("$word[1] - 1 chars");
126 my @p = $t->bbox($i);
127 my $x = $t->rootx + $p[0] + $p[2] - 4;
128 my $y = $t->rooty + $p[1] + $p[3] + 2;
129 "$x,$y";
130 }
131 },
132 -motioncommand => sub { my $x = $t->pointerx - $t->rootx;
133 my $y = $t->pointery - $t->rooty;
134 @word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend"));
135 if ($word[0] eq $last[0] and $word[1] eq $last[1]) {
136 # Same word - don't cancel the balloon.
137 0;
138 } else {
139 # New word under mouse - cancel it so a new balloon will be posted.
140 $t->SelectionClear;
141 @last = @word;
142 1;
143 }
144 },
145 );
146 $b->attach($c1,
147 -balloonposition => 'mouse',
148 -msg => {'rectangle' => 'You are over the red rectangle right now.',
149 $id => 'You are over the text right now.',
150 'circle' => 'You are over the blue circle right now.',
151 });
152 $b->attach($c2,
153 -msg => 'This balloon is attached to the canvas itself.',
154 );
155
156 $b->attach($lb,
157 -balloonposition => 'mouse',
158 -msg => [qw/1 2 3 4/],
159 );
160
161 # As $b is a child of $top it is destroyed when $top is destroyed.
162 # Balloon.pm now registers a handler for that, and so
163 # this hackery is no longer required (and did not actually work
164 # before).
165 # $top->OnDestroy(sub { $b->destroy; });
166
167 MainLoop;
168