Skip Menu |
 

This queue is for tickets about the Tk CPAN distribution.

Report information
The Basics
Id: 33655
Status: open
Priority: 0/
Queue: Tk

People
Owner: Nobody in particular
Requestors: lamprecht [...] cpan.org
Cc:
AdminCc:

Bug Information
Severity: Unimportant
Broken in: (no value)
Fixed in: (no value)



Subject: Feature suggestion: DynamicMouseWheelBind
Download (untitled) / with headers
text/plain 480b
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;
Download (untitled) / with headers
text/plain 909b
On Thu Feb 28 05:52:48 2008, LAMPRECHT wrote: Show quoted text
> 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. >
Well, I think it should go really first into an own CPAN distribution. Later it could be decided if it can go into core. Just one hint when building a CPAN distro. Because the namespace Tk::Widget is already taken you have to use a trick to get the module still indexed. Best is to write it as this: package Tk::DynaMouseWheelBind; require Tk::Widget; package # hide from PAUSE indexer Tk::Widget; The first package statement will be used for indexing the module, and by writing "package Tk::Widget" it won't be seen by the PAUSE indexer, so there will be no namespace clash. Regards, Slaven


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.