utils.tcl (8562B)
1 # 2 # Utilities for widget implementations. 3 # 4 5 ### Focus management. 6 # 7 # See also: #1516479 8 # 9 10 ## ttk::takefocus -- 11 # This is the default value of the "-takefocus" option 12 # for ttk::* widgets that participate in keyboard navigation. 13 # 14 # NOTES: 15 # tk::FocusOK (called by tk_focusNext) tests [winfo viewable] 16 # if -takefocus is 1, empty, or missing; but not if it's a 17 # script prefix, so we have to check that here as well. 18 # 19 # 20 proc ttk::takefocus {w} { 21 expr {[$w instate !disabled] && [winfo viewable $w]} 22 } 23 24 ## ttk::GuessTakeFocus -- 25 # This routine is called as a fallback for widgets 26 # with a missing or empty -takefocus option. 27 # 28 # It implements the same heuristics as tk::FocusOK. 29 # 30 proc ttk::GuessTakeFocus {w} { 31 # Don't traverse to widgets with '-state disabled': 32 # 33 if {![catch {$w cget -state} state] && $state eq "disabled"} { 34 return 0 35 } 36 37 # Allow traversal to widgets with explicit key or focus bindings: 38 # 39 if {[regexp {Key|Focus} [concat [bind $w] [bind [winfo class $w]]]]} { 40 return 1; 41 } 42 43 # Default is nontraversable: 44 # 45 return 0; 46 } 47 48 ## ttk::traverseTo $w -- 49 # Set the keyboard focus to the specified window. 50 # 51 proc ttk::traverseTo {w} { 52 set focus [focus] 53 if {$focus ne ""} { 54 event generate $focus <<TraverseOut>> 55 } 56 focus $w 57 event generate $w <<TraverseIn>> 58 } 59 60 ## ttk::clickToFocus $w -- 61 # Utility routine, used in <ButtonPress-1> bindings -- 62 # Assign keyboard focus to the specified widget if -takefocus is enabled. 63 # 64 proc ttk::clickToFocus {w} { 65 if {[ttk::takesFocus $w]} { focus $w } 66 } 67 68 ## ttk::takesFocus w -- 69 # Test if the widget can take keyboard focus. 70 # 71 # See the description of the -takefocus option in options(n) 72 # for details. 73 # 74 proc ttk::takesFocus {w} { 75 if {![winfo viewable $w]} { 76 return 0 77 } elseif {[catch {$w cget -takefocus} takefocus]} { 78 return [GuessTakeFocus $w] 79 } else { 80 switch -- $takefocus { 81 "" { return [GuessTakeFocus $w] } 82 0 { return 0 } 83 1 { return 1 } 84 default { 85 return [expr {[uplevel #0 $takefocus [list $w]] == 1}] 86 } 87 } 88 } 89 } 90 91 ## ttk::focusFirst $w -- 92 # Return the first descendant of $w, in preorder traversal order, 93 # that can take keyboard focus, "" if none do. 94 # 95 # See also: tk_focusNext 96 # 97 98 proc ttk::focusFirst {w} { 99 if {[ttk::takesFocus $w]} { 100 return $w 101 } 102 foreach child [winfo children $w] { 103 if {[set c [ttk::focusFirst $child]] ne ""} { 104 return $c 105 } 106 } 107 return "" 108 } 109 110 ### Grabs. 111 # 112 # Rules: 113 # Each call to [grabWindow $w] or [globalGrab $w] must be 114 # matched with a call to [releaseGrab $w] in LIFO order. 115 # 116 # Do not call [grabWindow $w] for a window that currently 117 # appears on the grab stack. 118 # 119 # See #1239190 and #1411983 for more discussion. 120 # 121 namespace eval ttk { 122 variable Grab ;# map: window name -> grab token 123 124 # grab token details: 125 # Two-element list containing: 126 # 1) a script to evaluate to restore the previous grab (if any); 127 # 2) a script to evaluate to restore the focus (if any) 128 } 129 130 ## SaveGrab -- 131 # Record current grab and focus windows. 132 # 133 proc ttk::SaveGrab {w} { 134 variable Grab 135 136 if {[info exists Grab($w)]} { 137 # $w is already on the grab stack. 138 # This should not happen, but bail out in case it does anyway: 139 # 140 return 141 } 142 143 set restoreGrab [set restoreFocus ""] 144 145 set grabbed [grab current $w] 146 if {[winfo exists $grabbed]} { 147 switch [grab status $grabbed] { 148 global { set restoreGrab [list grab -global $grabbed] } 149 local { set restoreGrab [list grab $grabbed] } 150 none { ;# grab window is really in a different interp } 151 } 152 } 153 154 set focus [focus] 155 if {$focus ne ""} { 156 set restoreFocus [list focus -force $focus] 157 } 158 159 set Grab($w) [list $restoreGrab $restoreFocus] 160 } 161 162 ## RestoreGrab -- 163 # Restore previous grab and focus windows. 164 # If called more than once without an intervening [SaveGrab $w], 165 # does nothing. 166 # 167 proc ttk::RestoreGrab {w} { 168 variable Grab 169 170 if {![info exists Grab($w)]} { # Ignore 171 return; 172 } 173 174 # The previous grab/focus window may have been destroyed, 175 # unmapped, or some other abnormal condition; ignore any errors. 176 # 177 foreach script $Grab($w) { 178 catch $script 179 } 180 181 unset Grab($w) 182 } 183 184 ## ttk::grabWindow $w -- 185 # Records the current focus and grab windows, sets an application-modal 186 # grab on window $w. 187 # 188 proc ttk::grabWindow {w} { 189 SaveGrab $w 190 grab $w 191 } 192 193 ## ttk::globalGrab $w -- 194 # Same as grabWindow, but sets a global grab on $w. 195 # 196 proc ttk::globalGrab {w} { 197 SaveGrab $w 198 grab -global $w 199 } 200 201 ## ttk::releaseGrab -- 202 # Release the grab previously set by [ttk::grabWindow] 203 # or [ttk::globalGrab]. 204 # 205 proc ttk::releaseGrab {w} { 206 grab release $w 207 RestoreGrab $w 208 } 209 210 ### Auto-repeat. 211 # 212 # NOTE: repeating widgets do not have -repeatdelay 213 # or -repeatinterval resources as in standard Tk; 214 # instead a single set of settings is applied application-wide. 215 # (TODO: make this user-configurable) 216 # 217 # (@@@ Windows seems to use something like 500/50 milliseconds 218 # @@@ for -repeatdelay/-repeatinterval) 219 # 220 221 namespace eval ttk { 222 variable Repeat 223 array set Repeat { 224 delay 300 225 interval 100 226 timer {} 227 script {} 228 } 229 } 230 231 ## ttk::Repeatedly -- 232 # Begin auto-repeat. 233 # 234 proc ttk::Repeatedly {args} { 235 variable Repeat 236 after cancel $Repeat(timer) 237 set script [uplevel 1 [list namespace code $args]] 238 set Repeat(script) $script 239 uplevel #0 $script 240 set Repeat(timer) [after $Repeat(delay) ttk::Repeat] 241 } 242 243 ## Repeat -- 244 # Continue auto-repeat 245 # 246 proc ttk::Repeat {} { 247 variable Repeat 248 uplevel #0 $Repeat(script) 249 set Repeat(timer) [after $Repeat(interval) ttk::Repeat] 250 } 251 252 ## ttk::CancelRepeat -- 253 # Halt auto-repeat. 254 # 255 proc ttk::CancelRepeat {} { 256 variable Repeat 257 after cancel $Repeat(timer) 258 } 259 260 ### Bindings. 261 # 262 263 ## ttk::copyBindings $from $to -- 264 # Utility routine; copies bindings from one bindtag onto another. 265 # 266 proc ttk::copyBindings {from to} { 267 foreach event [bind $from] { 268 bind $to $event [bind $from $event] 269 } 270 } 271 272 ### Mousewheel bindings. 273 # 274 # Platform inconsistencies: 275 # 276 # On X11, the server typically maps the mouse wheel to Button4 and Button5. 277 # 278 # On OSX, Tk generates sensible values for the %D field in <MouseWheel> events. 279 # 280 # On Windows, %D must be scaled by a factor of 120. 281 # In addition, Tk redirects mousewheel events to the window with 282 # keyboard focus instead of sending them to the window under the pointer. 283 # We do not attempt to fix that here, see also TIP#171. 284 # 285 # OSX conventionally uses Shift+MouseWheel for horizontal scrolling, 286 # and Option+MouseWheel for accelerated scrolling. 287 # 288 # The Shift+MouseWheel behavior is not conventional on Windows or most 289 # X11 toolkits, but it's useful. 290 # 291 # MouseWheel scrolling is accelerated on X11, which is conventional 292 # for Tk and appears to be conventional for other toolkits (although 293 # Gtk+ and Qt do not appear to use as large a factor). 294 # 295 296 ## ttk::bindMouseWheel $bindtag $command... 297 # Adds basic mousewheel support to $bindtag. 298 # $command will be passed one additional argument 299 # specifying the mousewheel direction (-1: up, +1: down). 300 # 301 302 proc ttk::bindMouseWheel {bindtag callback} { 303 switch -- [tk windowingsystem] { 304 x11 { 305 bind $bindtag <ButtonPress-4> "$callback -1" 306 bind $bindtag <ButtonPress-5> "$callback +1" 307 } 308 win32 { 309 bind $bindtag <MouseWheel> [append callback { [expr {-(%D/120)}]}] 310 } 311 aqua { 312 bind $bindtag <MouseWheel> [append callback { [expr {-(%D)}]} ] 313 } 314 } 315 } 316 317 ## Mousewheel bindings for standard scrollable widgets. 318 # 319 # Usage: [ttk::copyBindings TtkScrollable $bindtag] 320 # 321 # $bindtag should be for a widget that supports the 322 # standard scrollbar protocol. 323 # 324 325 switch -- [tk windowingsystem] { 326 x11 { 327 bind TtkScrollable <ButtonPress-4> { %W yview scroll -5 units } 328 bind TtkScrollable <ButtonPress-5> { %W yview scroll 5 units } 329 bind TtkScrollable <Shift-ButtonPress-4> { %W xview scroll -5 units } 330 bind TtkScrollable <Shift-ButtonPress-5> { %W xview scroll 5 units } 331 } 332 win32 { 333 bind TtkScrollable <MouseWheel> \ 334 { %W yview scroll [expr {-(%D/120)}] units } 335 bind TtkScrollable <Shift-MouseWheel> \ 336 { %W xview scroll [expr {-(%D/120)}] units } 337 } 338 aqua { 339 bind TtkScrollable <MouseWheel> \ 340 { %W yview scroll [expr {-(%D)}] units } 341 bind TtkScrollable <Shift-MouseWheel> \ 342 { %W xview scroll [expr {-(%D)}] units } 343 bind TtkScrollable <Option-MouseWheel> \ 344 { %W yview scroll [expr {-10*(%D)}] units } 345 bind TtkScrollable <Shift-Option-MouseWheel> \ 346 { %W xview scroll [expr {-10*(%D)}] units } 347 } 348 } 349 350 #*EOF*