figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

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*