| Subject: | Feature suggestion: DynamicMouseWheelBind |
The attached files provide a small addon to Tk::Widget. MouseWheel
events are directed to the widgets under the Cursor instead of the
focused widget.
I could make it a cpan package, but it might also be nice to have it in
the core distribution.
usage:
require Tk::DynaMouseWheelBind;
..
$mw->DynaMouseWheelBind('Tk::Canvas',
'Tk::Text',
'Tk::Pane',
'Whatever needs to be scrolled'
);
| Subject: | dyna_mousewheel_bind.t |
#!/usr/bin/perl
use Tk;
use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 10;
require_ok ('Tk::DynaMouseWheelBind');
my $mw = MainWindow->new();
my $e = $mw->Entry->pack;
$mw->DynaMouseWheelBind('Tk::Canvas',
'Tk::Text',
'Tk::Pane',
);
my $t = $mw->Scrolled('Text', -height => 10 )->pack();
$t = $t->Subwidget('scrolled');
$t->insert('end', "line $_\n") for (1..100);
my $c = $mw->Scrolled('Canvas',
-scrollregion => [0,0,1000,1000],
-bg => 'white',
)->pack;
$c = $c->Subwidget('scrolled');
$c->createText(50,250,
-text => 'a text item',
);
my $p = $mw->Scrolled('Pane')->pack;
$p = $p->Subwidget('scrolled');
for (1..20){
$p->Entry->pack;
}
$mw->update;
for ($p, $c, $t){
$_->yview(moveto => .5);
}
$e->focus;
$mw->update;
for my $ev(['<5>'],['<4>'],['<MouseWheel>',-delta => -120]){
for my $w($t, $c, $p){
# $mw->eventGenerate('<Motion>',
# -x => $w->rootx + ($w->width) /2 - $mw->rootx ,
# -y => $w->rooty + ($w->height) /2 - $mw->rooty ,
# -warp => 1);
$w->eventGenerate('<Enter>');
my $y = ($w->yview)[0];
$e->eventGenerate(@$ev);
my $delta = abs ($y - ($w->yview)[0]);
ok($delta > 0.01 , "$w scrolling delta: $delta");
}
}
#MainLoop();
| Subject: | DynaMouseWheelBind.pm |
require Tk::Widget;
package Tk::Widget;
use strict;
use warnings;
# keep Tk::Widgets namespace clean
my($motion,
$do_scroll,
$mousewheel_event,
$setup,
);
sub DynaMouseWheelBind{
my $w = shift;
my @classes = @_;
my $mw = $w->MainWindow;
$setup->($mw);
for my $class (@classes) {
eval "require $class" or die $@;
# initialize class bindings so the following changes
# won't get overridden
$class->InitClass($mw);
# replace MouseWheel bindings - these should be processed
# through the $mw binding only
my @mw_events = ('<MouseWheel>',
'<4>',
'<5>',
);
$mw->bind($class,$_,'') for (@mw_events);
$mw->bind($class,'<<DynaMouseWheel>>',$do_scroll);
}
}
# setup two bindings to track the window under the cursor
# and globally receive <MouseWheel>
$setup = sub{
my $mw = shift;
$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]);
};
{
my $under_cursor ;
my $scrollable;
my $delta;
$motion = sub {
$under_cursor = $_[0]->XEvent->Info('W');
};
$do_scroll = sub{
$scrollable->yview('scroll',
-($delta/120)*3,
'units');
};
$mousewheel_event = sub{
my $widget = shift;
$delta = shift;
# just in case, the mouse has not been moved yet:
my $w = $under_cursor ||= $widget;
# print "under_cursor:[$under_cursor]\n";
my @tags = $w->bindtags;
my $has_binding;
until ($has_binding || $w->isa('Tk::Toplevel')){
if($w->Tk::bind(ref($w),'<<DynaMouseWheel>>')){
$has_binding = 1 ;
}else{
$w = $w->parent;
}
}
if ($has_binding) {
$scrollable = $w;
$w->eventGenerate('<<DynaMouseWheel>>');
}
};
} # end of scope for $under_cursor, $scrollable, $delta
1;