comment on

After posting the first version of this module here, and getting some very useful ideas, code suggestions, and documentation help from hangon, (plus a nice synopsis of some of the bugs/issues from wol), I've updated the original code to fix many of the inherent issues. This documents the updated module, and is also a request for comments, prior to posting this at CPAN.

The new version below addresses the following bugs in the original:

A single click could theoretically happen between the two clicks of a double click (especially if the delay is a long one). In this case, it is also a bad thing that the double click callback happens prior to the single click callback.
Double or single clicks of different mouse buttons could theoretically be interlaced (especially if the delay is a long one). If a single click is pending for a given mouse button, a click of a different button should cause it to invoke immediately, and not consider it the first of a double click.
The delay should only affect a single click, because when the second click of a double click event occurs, it immediately identifies the event as a double click, and should therefore invoke immediately.
A triple click can register as a double click; instead it should count as a double click followed by either a single click, or the first click of a separate double click. (It would be quite easy to extend the module to handle triple clicks, although double clicks would then require waiting for the same delay as the single click currently does).

Update 2: The module is now available on Cpan. Feel free to continue to give me feedback (naturally!)

Update 1: Here is the updated module (now containing pod, as well as an example):



package Tk::DoubleClick;

our $VERSION = '1.000';

use strict;
use warnings;

require Exporter;

our @ISA    = qw(Exporter);
our @EXPORT = qw(bind_clicks);

#  Track last-clicked mouse number, widget, "after" event id and callb
+ack.
my $h_pend = { 'mn' => 0, 'wi' => 0, 'id' => 0, 'cb' => 0 };


sub bind_clicks {
    my ($widget, $a_single, $a_double, %args)  = @_;

    my $delay    = delete $args{-delay}  || 300;
    my $button   = delete $args{-button} || 'left';
    my $h_button = { left => 1, middle => 2, right => 3 };
    my $mousenum = $h_button->{$button} || $button;
    ($mousenum  =~ /^[123]$/) or $mousenum = 1;

    my $c_single = $a_single;
    if (ref $a_single eq 'ARRAY') {
        my $c_cmd = shift @$a_single;
        $c_single = sub { $c_cmd->(@$a_single) };
    }

    my $c_double = $a_double;
    if (ref $a_double eq 'ARRAY') {
        my $c_cmd = shift @$a_double;
        $c_double = sub { $c_cmd->(@$a_double) };
    }

    my $button_name    = "<Button-$mousenum>";

    my $c_pending = sub {
        my ($mousenum, $widget, $id) = @_;
        $h_pend->{'mn'} = $mousenum;
        $h_pend->{'wi'} = $widget;
        $h_pend->{'id'} = $id;
        $h_pend->{'cb'} = $c_single;
    };

    my $c_cmd = sub {
        my $b_sched  = 0;    # Schedule new single-click?

        if (!$h_pend->{'id'}) {
            # No click is pending -- schedule a new one
            $b_sched = 1;
        } else {
            # Cancel pending single-click event
            $h_pend->{'wi'}->afterCancel($h_pend->{'id'});
            $h_pend->{'id'} = 0;

            if ($h_pend->{'mn'} == $mousenum and $h_pend->{'wi'} eq $w
+idget) {
                # Invoke double-click callback and reset pending event
                $c_double->();
                $c_pending->(0, 0, 0);
            } else {
                # Invoke previous single-click, and schedule a new one
                $h_pend->{'cb'}->();
                $b_sched = 1;
            }
        }

        # Schedule new single-click subroutine when $delay expires
        if ($b_sched) {
            my $c_after = sub { $c_pending->(0, 0, 0); $c_single->() }
+;
            my $id = $widget->after($delay => $c_after);
            $c_pending->($mousenum, $widget, $id);
        }
    };

    $widget->bind($button_name => $c_cmd);
}


1;


=head1 NAME

Tk::Doubleclick - Correctly handle single click vs double click events
+,
calling only the appropriate callback for the given event.

=head1 SYNOPSIS

    use Tk::Doubleclick;

    bind_clicks(
        $widget,
        [ \&single_callback, @args ],    # Single callback with args
        \&double_callback,               # Double callback without arg
+s
        -delay  => 500,
        -button => 'right',
    );


=head1 REQUIRED PARAMETERS

=over 5

=item $widget

Widget to bind to mousebuttons.  Typically a Tk::Button object, but co
+uld
actually be almost any widget.

=item [ \&single_click_callback, @single_click_args ],

The callback subroutine to invoke when the event is a single-click, al
+ong
with the arguments to pass.  When no arguments are passed, the bracket
+s
can be omitted.

=item [ \&double_click_callback, @double_click_args ],

The callback subroutine to invoke when the event is a double-click, al
+ong
with the arguments to pass.  When no arguments are passed, the bracket
+s
can be omitted.

=back

=head1 OPTIONS

=over 5

=item -delay

Maximum delay time detween clicks in milliseconds. Default is 300.
If the second click of a two proximate mouse clicks occurs within the 
+given
delay time, the event is considered a double-click.  If not, the two c
+licks
are considered two separate (albeit nearly simultaneous) single-clicks
+.

=item -button

Mouse button to bind. Options are 1, 2, 3, or the corresponding synony
+ms
'left', 'middle', or 'right'.  The default is 1 ('left').

=back

=head1 EXAMPLE

    # Libraries
    use strict;
    use warnings;
    use Tk;
    use Tk::DoubleClick;

    # User-defined
    my $a_colors  = [
        [ '#8800FF', '#88FF88', '#88FFFF' ],
        [ '#FF0000', '#FF0088', '#FF00FF' ],
        [ '#FF8800', '#FF8888', '#FF88FF' ],
        [ '#FFFF00', '#FFFF88', '#FFFFFF' ],
    ];

    # Main program
    my $nsingle = my $ndouble = 0;
    my $mw      = new MainWindow(-title => "Double-click example");
    my $f1      = $mw->Frame->pack(-expand => 1, -fill => 'both');
    my @args    = qw( -width 12 -height 2 -relief groove -borderwidth 
+4 );
    my @pack    = qw( -side left -expand 1 -fill both );

    # Display single/double click counts
    my $lb1 = $f1->Label(-text    => "Single Clicks", @args);
    my $lb2 = $f1->Label(-textvar => \$nsingle,       @args);
    my $lb3 = $f1->Label(-text    => "Double Clicks", @args);
    my $lb4 = $f1->Label(-textvar => \$ndouble,       @args);
    $lb1->pack($lb2, $lb3, $lb4, @pack);

    # Create button for each color, and bind single/double clicks to i
+t
    foreach my $a_color (@$a_colors) {
        my $fr = $mw->Frame->pack(-expand => 1, -fill => 'both');
        foreach my $bg (@$a_color) {
            my $b = $fr->Button(-bg => $bg, -text => $bg, @args);
            $b->pack(@pack);
            bind_clicks($b, [\&single, $lb2, $bg], [\&double, $lb4, $b
+g]);
        }
    }

    # Make 'Escape' quit the program
    $mw->bind("<Escape>" => sub { exit });

    MainLoop;


    # Callbacks
    sub single {
        my ($lbl, $color) = @_;
        $lbl->configure(-bg => $color);
        ++$nsingle;
    }

    sub double {
        my ($lbl, $color) = @_;
        $lbl->configure(-bg => $color);
        ++$ndouble;
    }


=head1 ACKNOWLEDGEMENTS

Thanks to Mark Freeman for numerous great suggestions and documentatio
+n help.

=head1 AUTHOR

John C. Norton        liverpole@perlmonk.org

Copyright (c) 2009 John C. Norton. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 VERSION

Version 1.000  (August 2009)

=head1 REQUIREMENTS

The Tk module is required.

=head1 SEE ALSO

perl(1)

=cut
[download]

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

In reply to RFC: A Tk module for handling double clicks - Tk::DoubleClick by liverpole

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		`&`
	<		`<`
	>		`>`
	[		`[`
	]		`]`

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.