File Coverage

blib/lib/Tk/DoubleClick.pm
Criterion Covered Total %
statement 6 47 12.7
branch 0 12 0.0
condition 0 10 0.0
subroutine 2 7 28.5
pod 0 1 0.0
total 8 77 10.3


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