venv/tcl/tk8.6/ttk/utils.tcl

   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*