Mercurial > hg > mercurial-crew-with-dirclash
comparison contrib/hgk @ 4969:b43db44cd047
hgk: enable mouse wheel under Windows.
For some reason, MouseWheel events are not routed under windows even in latest ActiveTcl 8.4.15 while they are under linux and macosx. These events are activated using code supplied with Tcl Tip 171: <http://www.tcl.tk/cgi-bin/tct/tip/171.html>. Strangely, the Tip code almost work but generates some unexpected infinite loop which is fixed using a simple boolean to check reentrancy.
author | Patrick Mezard <pmezard@gmail.com> |
---|---|
date | Sun, 22 Jul 2007 16:21:49 +0200 |
parents | 713426631adf |
children | d4fa6bafc43a |
comparison
equal
deleted
inserted
replaced
4968:713426631adf | 4969:b43db44cd047 |
---|---|
2 | 2 |
3 # Copyright (C) 2005 Paul Mackerras. All rights reserved. | 3 # Copyright (C) 2005 Paul Mackerras. All rights reserved. |
4 # This program is free software; it may be used, copied, modified | 4 # This program is free software; it may be used, copied, modified |
5 # and distributed under the terms of the GNU General Public Licence, | 5 # and distributed under the terms of the GNU General Public Licence, |
6 # either version 2, or (at your option) any later version. | 6 # either version 2, or (at your option) any later version. |
7 | |
8 | |
9 # Modified version of Tip 171: | |
10 # http://www.tcl.tk/cgi-bin/tct/tip/171.html | |
11 # | |
12 # The in_mousewheel global was added to fix strange reentrancy issues. | |
13 # The whole snipped is activated only under windows, mouse wheel | |
14 # bindings working already under MacOSX and Linux. | |
15 | |
16 if {[tk windowingsystem] eq "win32"} { | |
17 | |
18 set mw_classes [list Text Listbox Table TreeCtrl] | |
19 foreach class $mw_classes { bind $class <MouseWheel> {} } | |
20 | |
21 set in_mousewheel 0 | |
22 | |
23 proc ::tk::MouseWheel {wFired X Y D {shifted 0}} { | |
24 global in_mousewheel | |
25 if { $in_mousewheel != 0 } { return } | |
26 # Set event to check based on call | |
27 set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>" | |
28 # do not double-fire in case the class already has a binding | |
29 if {[bind [winfo class $wFired] $evt] ne ""} { return } | |
30 # obtain the window the mouse is over | |
31 set w [winfo containing $X $Y] | |
32 # if we are outside the app, try and scroll the focus widget | |
33 if {![winfo exists $w]} { catch {set w [focus]} } | |
34 if {[winfo exists $w]} { | |
35 | |
36 if {[bind $w $evt] ne ""} { | |
37 # Awkward ... this widget has a MouseWheel binding, but to | |
38 # trigger successfully in it, we must give it focus. | |
39 catch {focus} old | |
40 if {$w ne $old} { focus $w } | |
41 set in_mousewheel 1 | |
42 event generate $w $evt -rootx $X -rooty $Y -delta $D | |
43 set in_mousewheel 0 | |
44 if {$w ne $old} { focus $old } | |
45 return | |
46 } | |
47 | |
48 # aqua and x11/win32 have different delta handling | |
49 if {[tk windowingsystem] ne "aqua"} { | |
50 set delta [expr {- ($D / 30)}] | |
51 } else { | |
52 set delta [expr {- ($D)}] | |
53 } | |
54 # scrollbars have different call conventions | |
55 if {[string match "*Scrollbar" [winfo class $w]]} { | |
56 catch {tk::ScrollByUnits $w \ | |
57 [string index [$w cget -orient] 0] $delta} | |
58 } else { | |
59 set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \ | |
60 scroll $delta units] | |
61 # Walking up to find the proper widget (handles cases like | |
62 # embedded widgets in a canvas) | |
63 while {[catch $cmd] && [winfo toplevel $w] ne $w} { | |
64 set w [winfo parent $w] | |
65 } | |
66 } | |
67 } | |
68 } | |
69 | |
70 bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0] | |
71 | |
72 # end of win32 section | |
73 } | |
74 | |
7 | 75 |
8 proc gitdir {} { | 76 proc gitdir {} { |
9 global env | 77 global env |
10 if {[info exists env(GIT_DIR)]} { | 78 if {[info exists env(GIT_DIR)]} { |
11 return $env(GIT_DIR) | 79 return $env(GIT_DIR) |