From 729f89a2b1924dc14e7c5db219a9c059700e87a1 Mon Sep 17 00:00:00 2001
From: etienne
Date: Thu, 7 Oct 2004 15:27:43 +0000
Subject: Added wheelmouse bindings for Tk::Tree and Tk::Text widget. It
 doesn't work for Tk::Pane.

---
 Perl/Zinc/Debug.pm | 19 ++++++++++++++++++-
 1 file changed, 18 insertions(+), 1 deletion(-)

(limited to 'Perl')

diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm
index 66738da..6cdd53d 100644
--- a/Perl/Zinc/Debug.pm
+++ b/Perl/Zinc/Debug.pm
@@ -447,6 +447,7 @@ sub showtree {
 				       &undohighlightitem(undef, $zinc)});
 			       },
 			       );
+    &wheelmousebindings($tree);
     $tree->bind('<1>', [sub {
 	my $path = $tree->nearest($_[1]);
 	my $item = (split(/\./, $path))[-1];
@@ -1220,7 +1221,6 @@ sub showresult {
 					      -height => 200,
 					      -width => 1024,
 					      );
-    
     my $fm2 = $result_fm->Frame->pack;
     # attributes display
     &showattributes($zinc, $fm2, $label, \@items);
@@ -2152,6 +2152,7 @@ sub showHelpAboutTree {
 					-foreground => 'gray10',
 					-scrollbars => 'osoe',
 					);
+    &wheelmousebindings($text);
     $text->tagConfigure('keyword', -foreground => 'darkblue');
     $text->insert('end', "\nNAVIGATION IN TREE\n\n");
     $text->insert('end', "<Up>", "keyword");
@@ -2209,6 +2210,7 @@ sub showHelpAboutAttributes {
 				      -foreground => 'gray10',
 				      -scrollbars => 'oe',
 				      );
+    &wheelmousebindings($text);
     $text->tagConfigure('keyword', -foreground => 'darkblue');
     $text->tagConfigure('title', -foreground => 'ivory',
 			-background => 'gray60',
@@ -2260,6 +2262,7 @@ sub showHelpAboutCoords {
 				      -foreground => 'gray10',
 				      -scrollbars => 'oe',
 				      );
+    &wheelmousebindings($text);
     $text->tagConfigure('keyword', -foreground => 'darkblue');
     $text->tagConfigure('title', -foreground => 'ivory',
 			-background => 'gray60',
@@ -2786,6 +2789,20 @@ sub iconify {
 
 } # end iconify
 
+# wheelmousebindings doesn't work for Tk::Pane widgets...
+sub wheelmousebindings {
+    my $w = shift;
+    my $count = shift;
+    my $count = 3 unless $count > 0;
+    $w->bind('<Control-ButtonPress-4>', sub {$w->yview('scroll', -1, 'page')});
+    $w->bind('<Shift-ButtonPress-4>', sub {$w->yview('scroll', -1, 'unit')});
+    $w->bind('<ButtonPress-4>', sub {$w->yview('scroll', -$count, 'unit')});
+    
+    $w->bind('<Control-ButtonPress-5>', sub {$w->yview('scroll', 1, 'page')});
+    $w->bind('<Shift-ButtonPress-5>', sub {$w->yview('scroll', 1, 'unit')});
+    $w->bind('<ButtonPress-5>', sub {$w->yview('scroll', $count, 'unit')});
+
+} # end wheelmousebindings
 
 1;
 
-- 
cgit v1.1