Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Detect perl/Tk Button double-clicks vs. single-clicks

by liverpole (Monsignor)
on Jul 25, 2009 at 03:26 UTC ( [id://783121]=CUFP: print w/replies, xml ) Need Help??

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

A little googling took me right back to the Monastery; to this node of more than 5 years ago.  The one answer which looked like it addressed the problem didn't seem to do what I was after; it uses a global variable, and doesn't let you specify which mouse button (eg. 1, 2 or 3).  (To be fair, I didn't even try it until just now).  This seemed a fun chance to write a more general purpose subroutine bind_clicks(), which appears at the end of the following complete test program:

Update:  I've made some improvements to the module, and am requesting comments to the updated version here.  Thanks to wol's post, which addresses some of the bugs in the original, and thanks to hangon for turning the subroutine into its own module, and for providing documentation.

#!/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).


s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

Replies are listed 'Best First'.
Re: Detect perl/Tk Button double-clicks vs. single-clicks
by hangon (Deacon) on Jul 26, 2009 at 00:47 UTC

    ++ Works great, I could have used this on some past projects. It's surprising the doubleclick bug has never been fixed. Here's my rough cut at a module version of your code, called in more of a Perl Tk style.

    package Tk::Doubleclick; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(bindClicks); sub bindClicks { my %arg = @_; my $btn = delete $arg{-widget}; my $delay = delete $arg{-delay} || 300; my $args1 = delete $arg{-single}; my $args2 = delete $arg{-double}; my $clicked = delete $arg{-button} || 'left'; my %btnTable = ( left => 1, center => 2, right => 3 ); my $mousenum = $btnTable{$clicked} || $clicked; $mousenum = 1 unless ($mousenum =~ /^[123]$/); my $single = $args1; if (ref $args1 eq 'ARRAY'){ $single = shift @$args1; }else{ $args1 = []; } my $double = $args2; if (ref $args2 eq 'ARRAY'){ $double = shift @$args2; }else{ $args2 = []; } my $nclicks = 0; my $c_cmd = sub { ++$nclicks; $btn->after($delay => sub { my $count = $nclicks; $nclicks = 0; if ($count > 1) { $double->(@$args2); } elsif ($count == 1) { $single->(@$args1); } }); }; my $button_name = "<Button-$mousenum>"; $btn->bind($button_name => $c_cmd); } 1; =head1 NAME Tk::Doubleclick - Correct handling of single vs double click callback +bindings =head1 SYNOPSIS use Tk::Doubleclick; bindClicks( -delay => 500, -widget => $button_widget, -button => 'left', -single => [ \&callback, @args ], # with arguments -double => \&callback, # without arguments ); =head1 OPTIONS =over 5 =item -delay Maximum delay time detween clicks in milliseconds. Default = 300. =item -widget Widget to bind to mousebuttons. =item -button Mouse button to bind. Options are left, center, right, 1, 2, 3. Defaul +t = left. =item -single Single click callback. To include arguments, use array reference. =item -double Double click callback. To include arguments, use array reference. =back =cut

    Update: fixed typo

      This problem is a difficult one to address generally, independent of the language.
      • Should the user have to wait half a second before their single click is processed?
      • Ditto for double clicks.
      • Shouldn't there be some kind of immediate feedback when the user click the first time? Can the kind of feedback it gives be common?
      • Is there any way that treble clicks can be detected?
      Even working on an obsolete platform many years ago, they took the same basic approach as Tk:
      • Every time a double click event comes through, you can assume that there was a single click event that came through a moment ago.
      • Don't define single and double click events for a widget so that the handlers are "not compatible"
      This does mean that if you want to handle a double click on a particular item, then there are some limitations on what you can do in the single click handler (don't open a dialog for eg, especially a modal one!).

      That said, I can imagine that the solution here may be quite apropriate in some cases, so it's great that it can be handled on a widget by widget basis. ++ from me.

      --
      use JAPH;
      print JAPH::asString();

      It's surprising the doubleclick bug has never been fixed.

      It isn't considered a bug.

        It isn't considered a bug.

        A double click is a single distinct user action, and the expected behavior would be for it to trigger a single distinct event. The fact that it triggers a series of two events, one of them also associated with a different action, is not logical, useful or documented. Whether or not you think it's a bug, it most certainly is a problem. Again, ++ to liverpole for coming up with a solution.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://783121]
Approved by planetscape
Front-paged by planetscape
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others imbibing at the Monastery: (5)
As of 2024-03-28 08:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found