Recently my "spare-time" program has been a perl/Tk application, where I ran into a problem while trying to detect a double-click event of a mouse button, in that the single-click event is also triggered (actually, triggered twice).
#!/usr/bin/perl -w
#
# Test code for bind_clicks(), which lets a perl/Tk program assign
# two subroutines, for single or double mouse clicks.
#
# July 24, 2009 -- liverpole
##
###############
## Libraries ##
###############
use strict;
use warnings;
use File::Basename;
use Data::Dumper;
use Tk;
use Tk::Font;
##################
## User-defined ##
##################
my $lbcolor = "lightblue";
my $h_rgb = { '0' => '00', '8' => '80', 'f' => 'ff' };
my $a_colors = [
[qw[000 008 00f 080 088 08f 0f0 0f8 0ff ]],
[qw[800 808 80f 880 888 88f 8f0 8f8 8ff ]],
[qw[f00 f08 f0f f80 f88 f8f ff0 ff8 fff ]],
];
my $a_white_bg = [qw[
000000 000080 0000ff 008000 008080
800000 800080 8000ff 808000 808080
]];
my $h_white_bg = { map { "#" .$_ => 1 } @$a_white_bg };
#############
## Globals ##
#############
my $iam = basename $0;
my $nsingle1 = 0; # Total single clicks for mouse-1
my $ndouble1 = 0; # Total double clicks for mouse-1
my $nsingle3 = 0; # Total single clicks for mouse-3
my $ndouble3 = 0; # Total double clicks for mouse-3
##################
## Main program ##
##################
my $title = "Double-click Test -- liverpole 090724";
my $mw = new MainWindow(-title => $title);
my $f0 = frame($mw, 1, "x", "groove");
my $b0 = button($f0, "Exit (escape)", $lbcolor, 0, sub { exit }, 3);
filler($f0, 8, "<");
$mw->bind("<Escape>" => sub { $b0->invoke });
my $en1 = label($f0, "Single-Click 1", $lbcolor, 12, 3);
my $lb1 = label($f0, \$nsingle1, "white", 8, 3);
my $en2 = label($f0, "Double-Click 1", $lbcolor, 12, 3);
my $lb2 = label($f0, \$ndouble1, "white", 8, 3);
my $en3 = label($f0, "Single-Click 3", $lbcolor, 12, 3);
my $lb3 = label($f0, \$nsingle3, "white", 8, 3);
my $en4 = label($f0, "Double-Click 3", $lbcolor, 12, 3);
my $lb4 = label($f0, \$ndouble3, "white", 8, 3);
for (my $i = 0; $i < @$a_colors; $i++) {
my $a_col = $a_colors->[$i];
my $frm = frame($mw, 1, "x", "groove");
foreach my $tag (@$a_col) {
$tag =~ /(.)(.)(.)/;
my $name = $h_rgb->{$1} . $h_rgb->{$2} . $h_rgb->{$3};
my $color = "#$name";
my $btn = button($frm, $name, $color, 10);
my $a_arg1 = [ $lb1, $lb2, $color, \$nsingle1, \$ndouble1 ];
my $a_arg2 = [ $lb3, $lb4, $color, \$nsingle3, \$ndouble3 ];
bind_clicks($btn, 1, \&singleclick, \&doubleclick, $a_arg1);
bind_clicks($btn, 3, \&singleclick, \&doubleclick, $a_arg2);
}
}
MainLoop;
#################
## Subroutines ##
#################
sub frame {
my ($w, $exp, $fill, $rel) = @_;
my $frm = $w->Frame();
if ($rel || 0) {
$frm->configure(-relief => $rel, -borderwidth => 4);
}
$frm->pack(-expand => $exp, -fill => $fill);
return $frm;
}
sub filler {
my ($w, $size, $side) = @_;
my $where = ($side =~ /[<>]/)? "-width": "-height";
my $fill = ($side =~ /[<>]/)? "y": "x";
my $h_side = {qw{ < left > right ^ top v bottom }};
my $frm = $w->Frame($where => $size);
$side = $h_side->{$side};
$frm->pack(-expand => 0, -fill => $fill, -side => $side);
return $frm;
}
sub label {
my ($w, $text, $bg, $width, $bw, $side) = @_;
my $targ = (ref $text eq "SCALAR")? "-textvar": "-text";
my $font = $w->Font(-family => "tahoma", -size => 12);
my $lbl = $w->Label($targ => $text, -height => 3);
$lbl->configure(-font => $font);
($bg || 0) and $lbl->configure(-bg => $bg);
($width || 0) and $lbl->configure(-width => $width);
if ($bw || 0) {
$lbl->configure(-relief => 'groove', -borderwidth => $bw);
}
exists($h_white_bg->{$bg}) and $lbl->configure(-fg => "white");
$lbl->pack(-side => "left");
return $lbl;
}
sub button {
my ($w, $text, $bg, $width, $c_cmd) = @_;
my $btn = $w->Button(-text => $text, -bg => $bg);
my $font = $w->Font(-family => "tahoma", -size => 12);
$btn->configure(-font => $font, -height => 3);
($width || 0) and $btn->configure(-width => $width);
($c_cmd || 0) and $btn->configure(-command => $c_cmd);
exists($h_white_bg->{$bg}) and $btn->configure(-fg => "white");
$btn->pack(-side => "left");
return $btn;
}
sub singleclick {
my ($a_args) = @_;
my $w = $a_args->[0];
my $bg = $a_args->[2];
my $fg = ($h_white_bg->{$bg} || 0)? "white": "black";
$w->configure(-bg => $bg, -fg => $fg);
++${$a_args->[3]};
}
sub doubleclick {
my ($a_args) = @_;
my $w = $a_args->[1];
my $bg = $a_args->[2];
my $fg = ($h_white_bg->{$bg} || 0)? "white": "black";
$w->configure(-bg => $bg, -fg => $fg);
++${$a_args->[4]};
}
#
# Inputs: $1 ... The Tk::Button object
# $2 ... The mouse button number to detect {1, 2 or 3}
# $3 ... The closure to call if it's a single-click
# $4 ... The closure to call if it's a double-click
# $5 ... A list reference to pass to the chosen closure
#
# Results: Detects single-click vs. double-click for the given
# perl/Tk Button object, and calls the appropriate closure
# with the given arguments.
##
sub bind_clicks {
my ($btn, $mousenum, $c_single, $c_double, $a_args) = @_;
# User-configurable
my $delay = 250; # Delay in milliseconds
my $nclicks = 0;
my $c_cmd = sub {
++$nclicks;
$btn->after($delay => sub {
my $count = $nclicks;
$nclicks = 0;
if ($count > 1) {
$c_double->($a_args);
} elsif (1 == $count) {
$c_single->($a_args);
}
});
};
$mousenum ||= 1;
my $button_name = "<Button-$mousenum>";
$btn->bind($button_name => $c_cmd);
}
The idea is fairly simple -- you pass the button object, the number of the mouse button you're detecting single/double clicks for, along with 2 closures (the first to call if it's a single click, the second if it's a double click), and a reference to an array of arguments to send to the chosen closure.
A callback is scheduled for a short time after the first click of the button, and if the second click occurs before the callback triggers, the locally-scoped variable $nclicks gets incremented twice, causing the double-click closure to be invoked. If the callback occurs before the button is clicked for the second time, the single-click closure is called instead.
You can adjust the parameter $delay to specify how much time to wait before deciding that it was a single-click after all.
Update: Fixed a minor bug with click-counters (they were sharing a common variable -- now using separate variables).