#!/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);
}
[download]

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).