line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Tk::DoubleClick; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.02'; |
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
23899
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
40
|
|
8
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
613
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 NAME |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
Tk::DoubleClick - Correctly handle single-click vs double-click events, |
13
|
|
|
|
|
|
|
calling only the appropriate callback for the given event. |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 VERSION |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
Version 0.02 |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 SYNOPSIS |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
use Tk::Doubleclick; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
bind_clicks( |
24
|
|
|
|
|
|
|
$widget, |
25
|
|
|
|
|
|
|
[ \&single_callback, @args ], # Single callback with args |
26
|
|
|
|
|
|
|
\&double_callback, # Double callback without args |
27
|
|
|
|
|
|
|
-delay => 500, |
28
|
|
|
|
|
|
|
-button => 'right', |
29
|
|
|
|
|
|
|
); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 EXPORT |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
bind_clicks() |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head1 REQUIRED PARAMETERS |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=over 5 |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
=item $widget |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
Widget to bind to mousebuttons. Typically a Tk::Button object, but could |
43
|
|
|
|
|
|
|
actually be almost any widget. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=item [ \&single_click_callback, @single_click_args ], |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
The callback subroutine to invoke when the event is a single-click, along |
48
|
|
|
|
|
|
|
with the arguments to pass. When no arguments are passed, the brackets |
49
|
|
|
|
|
|
|
can be omitted. |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=item [ \&double_click_callback, @double_click_args ], |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
The callback subroutine to invoke when the event is a double-click, along |
54
|
|
|
|
|
|
|
with the arguments to pass. When no arguments are passed, the brackets |
55
|
|
|
|
|
|
|
can be omitted. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=back |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=head1 OPTIONS |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=over 5 |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=item -delay |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
Maximum delay time detween clicks in milliseconds. Default is 300. |
66
|
|
|
|
|
|
|
If the second click of a two proximate mouse clicks occurs within the given |
67
|
|
|
|
|
|
|
delay time, the event is considered a double-click. If not, the two clicks |
68
|
|
|
|
|
|
|
are considered two separate (albeit nearly simultaneous) single-clicks. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=item -button |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
Mouse button to bind. Options are 1, 2, 3, or the corresponding synonyms |
73
|
|
|
|
|
|
|
'left', 'middle', or 'right'. The default is 1 ('left'). |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=back |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=head1 EXAMPLE |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# Libraries |
80
|
|
|
|
|
|
|
use strict; |
81
|
|
|
|
|
|
|
use warnings; |
82
|
|
|
|
|
|
|
use Tk; |
83
|
|
|
|
|
|
|
use Tk::DoubleClick; |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# User-defined |
86
|
|
|
|
|
|
|
my $a_colors = [ |
87
|
|
|
|
|
|
|
[ '#8800FF', '#88FF88', '#88FFFF' ], |
88
|
|
|
|
|
|
|
[ '#FF0000', '#FF0088', '#FF00FF' ], |
89
|
|
|
|
|
|
|
[ '#FF8800', '#FF8888', '#FF88FF' ], |
90
|
|
|
|
|
|
|
[ '#FFFF00', '#FFFF88', '#FFFFFF' ], |
91
|
|
|
|
|
|
|
]; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Main program |
94
|
|
|
|
|
|
|
my $nsingle = my $ndouble = 0; |
95
|
|
|
|
|
|
|
my $mw = new MainWindow(-title => "Double-click example"); |
96
|
|
|
|
|
|
|
my $f1 = $mw->Frame->pack(-expand => 1, -fill => 'both'); |
97
|
|
|
|
|
|
|
my @args = qw( -width 12 -height 2 -relief groove -borderwidth 4 ); |
98
|
|
|
|
|
|
|
my @pack = qw( -side left -expand 1 -fill both ); |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# Display single/double click counts |
101
|
|
|
|
|
|
|
my $lb1 = $f1->Label(-text => "Single Clicks", @args); |
102
|
|
|
|
|
|
|
my $lb2 = $f1->Label(-textvar => \$nsingle, @args); |
103
|
|
|
|
|
|
|
my $lb3 = $f1->Label(-text => "Double Clicks", @args); |
104
|
|
|
|
|
|
|
my $lb4 = $f1->Label(-textvar => \$ndouble, @args); |
105
|
|
|
|
|
|
|
$lb1->pack($lb2, $lb3, $lb4, @pack); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# Create button for each color, and bind single/double clicks to it |
108
|
|
|
|
|
|
|
foreach my $a_color (@$a_colors) { |
109
|
|
|
|
|
|
|
my $fr = $mw->Frame->pack(-expand => 1, -fill => 'both'); |
110
|
|
|
|
|
|
|
foreach my $bg (@$a_color) { |
111
|
|
|
|
|
|
|
my $b = $fr->Button(-bg => $bg, -text => $bg, @args); |
112
|
|
|
|
|
|
|
$b->pack(@pack); |
113
|
|
|
|
|
|
|
bind_clicks($b, [\&single, $lb2, $bg], [\&double, $lb4, $bg]); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# Make 'Escape' quit the program |
118
|
|
|
|
|
|
|
$mw->bind("" => sub { exit }); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
MainLoop; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Callbacks |
124
|
|
|
|
|
|
|
sub single { |
125
|
|
|
|
|
|
|
my ($lbl, $color) = @_; |
126
|
|
|
|
|
|
|
$lbl->configure(-bg => $color); |
127
|
|
|
|
|
|
|
++$nsingle; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub double { |
131
|
|
|
|
|
|
|
my ($lbl, $color) = @_; |
132
|
|
|
|
|
|
|
$lbl->configure(-bg => $color); |
133
|
|
|
|
|
|
|
++$ndouble; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
Thanks to Mark Freeman for numerous great suggestions and documentation help. |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=head1 AUTHOR |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
John C. Norton, C<< >> |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=head1 BUGS |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
148
|
|
|
|
|
|
|
the web interface at L. I will be notified, and then you'll |
149
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=head1 SUPPORT |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
perldoc Tk::DoubleClick |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
You can also look for information at: |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
=over 4 |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
L |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
L |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=item * CPAN Ratings |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
L |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=item * Search CPAN |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
L |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=back |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
Thanks to Mark Freeman for numerous great suggestions and documentation help. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
Copyright 2009 John C. Norton. |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
192
|
|
|
|
|
|
|
under the terms of either: the GNU General Public License as published |
193
|
|
|
|
|
|
|
by the Free Software Foundation; or the Artistic License. |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
See http://dev.perl.org/licenses/ for more information. |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=cut |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
require Exporter; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
204
|
|
|
|
|
|
|
our @EXPORT = qw(bind_clicks); |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# Track last-clicked mouse number, widget, "after" event id and callback. |
208
|
|
|
|
|
|
|
my $h_pend = { 'mn' => 0, 'wi' => 0, 'id' => 0, 'cb' => 0 }; |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub bind_clicks { |
212
|
0
|
|
|
0
|
0
|
|
my ($widget, $a_single, $a_double, %args) = @_; |
213
|
|
|
|
|
|
|
|
214
|
0
|
|
0
|
|
|
|
my $delay = delete $args{-delay} || 300; |
215
|
0
|
|
0
|
|
|
|
my $button = delete $args{-button} || 'left'; |
216
|
0
|
|
|
|
|
|
my $h_button = { left => 1, middle => 2, right => 3 }; |
217
|
0
|
|
0
|
|
|
|
my $mousenum = $h_button->{$button} || $button; |
218
|
0
|
0
|
|
|
|
|
($mousenum =~ /^[123]$/) or $mousenum = 1; |
219
|
|
|
|
|
|
|
|
220
|
0
|
|
|
|
|
|
my $c_single = $a_single; |
221
|
0
|
0
|
|
|
|
|
if (ref $a_single eq 'ARRAY') { |
222
|
0
|
|
|
|
|
|
my $c_cmd = shift @$a_single; |
223
|
0
|
|
|
0
|
|
|
$c_single = sub { $c_cmd->(@$a_single) }; |
|
0
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
0
|
|
|
|
|
|
my $c_double = $a_double; |
227
|
0
|
0
|
|
|
|
|
if (ref $a_double eq 'ARRAY') { |
228
|
0
|
|
|
|
|
|
my $c_cmd = shift @$a_double; |
229
|
0
|
|
|
0
|
|
|
$c_double = sub { $c_cmd->(@$a_double) }; |
|
0
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
0
|
|
|
|
|
|
my $button_name = ""; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
my $c_pending = sub { |
235
|
0
|
|
|
0
|
|
|
my ($mousenum, $widget, $id) = @_; |
236
|
0
|
|
|
|
|
|
$h_pend->{'mn'} = $mousenum; |
237
|
0
|
|
|
|
|
|
$h_pend->{'wi'} = $widget; |
238
|
0
|
|
|
|
|
|
$h_pend->{'id'} = $id; |
239
|
0
|
|
|
|
|
|
$h_pend->{'cb'} = $c_single; |
240
|
0
|
|
|
|
|
|
}; |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
my $c_cmd = sub { |
243
|
0
|
|
|
0
|
|
|
my $b_sched = 0; # Schedule new single-click? |
244
|
|
|
|
|
|
|
|
245
|
0
|
0
|
|
|
|
|
if (!$h_pend->{'id'}) { |
246
|
|
|
|
|
|
|
# No click is pending -- schedule a new one |
247
|
0
|
|
|
|
|
|
$b_sched = 1; |
248
|
|
|
|
|
|
|
} else { |
249
|
|
|
|
|
|
|
# Cancel pending single-click event |
250
|
0
|
|
|
|
|
|
$h_pend->{'wi'}->afterCancel($h_pend->{'id'}); |
251
|
0
|
|
|
|
|
|
$h_pend->{'id'} = 0; |
252
|
|
|
|
|
|
|
|
253
|
0
|
0
|
0
|
|
|
|
if ($h_pend->{'mn'} == $mousenum and $h_pend->{'wi'} eq $widget) { |
254
|
|
|
|
|
|
|
# Invoke double-click callback and reset pending event |
255
|
0
|
|
|
|
|
|
$c_double->(); |
256
|
0
|
|
|
|
|
|
$c_pending->(0, 0, 0); |
257
|
|
|
|
|
|
|
} else { |
258
|
|
|
|
|
|
|
# Invoke previous single-click, and schedule a new one |
259
|
0
|
|
|
|
|
|
$h_pend->{'cb'}->(); |
260
|
0
|
|
|
|
|
|
$b_sched = 1; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# Schedule new single-click subroutine when $delay expires |
265
|
0
|
0
|
|
|
|
|
if ($b_sched) { |
266
|
0
|
|
|
|
|
|
my $c_after = sub { $c_pending->(0, 0, 0); $c_single->() }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
267
|
0
|
|
|
|
|
|
my $id = $widget->after($delay => $c_after); |
268
|
0
|
|
|
|
|
|
$c_pending->($mousenum, $widget, $id); |
269
|
|
|
|
|
|
|
} |
270
|
0
|
|
|
|
|
|
}; |
271
|
|
|
|
|
|
|
|
272
|
0
|
|
|
|
|
|
$widget->bind($button_name => $c_cmd); |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
1; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
|