Mercurial > hg > mercurial-crew-with-dirclash

comparison contrib/hgk @ 4969:b43db44cd047

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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)