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 1 1 100.0
total 9 77 11.6


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