DynaMouseWheelBind.pm 2.79 KB
Newer Older
Christian Fibich's avatar
Christian Fibich committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
#-------------------------------------------------------------------------------
#  University of Applied Sciences Technikum Wien
#
#  Department of Embedded Systems
#  http://embsys.technikum-wien.at
#
#  Josef Ressel Center for Verification of Embedded Computing Systems
#  http://vecs.technikum-wien.at
#
#-------------------------------------------------------------------------------
#  File:              DynaMouseWheelBind.pm
#  Created on:        25.02.2015
#  $LastChangedBy$
#  $LastChangedDate$
#
#  Description:
#  https://rt.cpan.org/Public/Bug/Display.html?id=33655
#-------------------------------------------------------------------------------

20
21
22
# https://rt.cpan.org/Public/Bug/Display.html?id=33655

require Tk::Widget;
23

24
25
26
27
28
29
30
package Tk::Widget;
use strict;
use warnings;

use constant SCROLL_FACTOR => 2;

# keep Tk::Widgets namespace clean
Christian Fibich's avatar
Christian Fibich committed
31
my ($motion, $do_scroll, $mousewheel_event, $setup,);
32
33
34

sub DynaMouseWheelBind {
    my $w       = shift;
35
    my @classes = @_;
36
    my $mw      = $w->MainWindow;
37
38
39
    $setup->($mw);
    for my $class (@classes) {
        eval "require $class" or die $@;
40

41
42
43
        # initialize class bindings so the following changes
        # won't get overridden
        $class->InitClass($mw);
44

45
46
        # replace MouseWheel bindings - these should be processed
        # through the $mw binding only
Christian Fibich's avatar
Christian Fibich committed
47
48
49
        my @mw_events = ('<MouseWheel>', '<4>', '<5>',);
        $mw->bind($class, $_, '') for (@mw_events);
        $mw->bind($class, '<<DynaMouseWheel>>', $do_scroll);
50
51
52
53
54
55
    }
}

# setup two bindings to track the window under the cursor
# and globally receive <MouseWheel>

56
$setup = sub {
57
    my $mw = shift;
Christian Fibich's avatar
Christian Fibich committed
58
59
60
61
    $mw->bind('all', '<Enter>', $motion);
    $mw->bind('all', '<MouseWheel>', [$mousewheel_event, Tk::Ev('D')]);
    $mw->bind('all', '<4>',          [$mousewheel_event, 120]);
    $mw->bind('all', '<5>',          [$mousewheel_event, -120]);
62
63
64
};

{
65
    my $under_cursor;
66
67
68
69
70
71
72
    my $scrollable;
    my $delta;

    $motion = sub {
        $under_cursor = $_[0]->XEvent->Info('W');
    };

73
    $do_scroll = sub {
Christian Fibich's avatar
Christian Fibich committed
74
        $scrollable->yview('scroll', -($delta / 120) * SCROLL_FACTOR, 'units');
75
76
    };

77
    $mousewheel_event = sub {
78
79
        my $widget = shift;
        $delta = shift;
80

81
82
        # just in case, the mouse has not been moved yet:
        my $w = $under_cursor ||= $widget;
83
84

        #  print "under_cursor:[$under_cursor]\n";
85
86
        my @tags = $w->bindtags;
        my $has_binding;
Christian Fibich's avatar
Christian Fibich committed
87
88
        until ($has_binding || $w->isa('Tk::Toplevel')) {
            if ($w->Tk::bind(ref($w), '<<DynaMouseWheel>>')) {
89
90
                $has_binding = 1;
            } else {
91
92
93
94
95
96
97
98
                $w = $w->parent;
            }
        }
        if ($has_binding) {
            $scrollable = $w;
            $w->eventGenerate('<<DynaMouseWheel>>');
        }
    };
99
}    # end of scope for $under_cursor, $scrollable, $delta
100
101

1;