library/focus.tcl

   1 # focus.tcl --
   2 #
   3 # This file defines several procedures for managing the input
   4 # focus.
   5 #
   6 # Copyright (c) 1994-1995 Sun Microsystems, Inc.
   7 #
   8 # See the file "license.terms" for information on usage and redistribution
   9 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10 #
  11
  12 set ckPriv(restrictWindow) {}
  13
  14 # ck_focusNext --
  15 # This procedure returns the name of the next window after "w" in
  16 # "focus order" (the window that should receive the focus next if
  17 # Tab is typed in w).  "Next" is defined by a pre-order search
  18 # of the current window and its descendants, with the stacking
  19 # order determining the order of siblings.  The "-takefocus" options
  20 # on windows determine whether or not they should be skipped.
  21 #
  22 # Arguments:
  23 # w -           Name of a window.
  24
  25 proc ck_focusNext w {
  26     global ckPriv
  27     set cur $w
  28     while 1 {
  29
  30         # Descend to just before the first child of the current widget.
  31
  32         set parent $cur
  33         set children [winfo children $cur]
  34         set i -1
  35
  36         # Look for the next sibling that isn't a top-level.
  37
  38         while 1 {
  39             incr i
  40             if {$i < [llength $children]} {
  41                 set cur [lindex $children $i]
  42                 if {[winfo toplevel $cur] == $cur} {
  43                     continue
  44                 } else {
  45                     break
  46                 }
  47             }
  48
  49             # No more siblings, so go to the current widget's parent.
  50             # If it's a top-level, break out of the loop, otherwise
  51             # look for its next sibling.
  52
  53             set cur $parent
  54             if {$parent == $ckPriv(restrictWindow)} break
  55             if {[winfo toplevel $cur] == $cur} {
  56                 break
  57             }
  58             set parent [winfo parent $parent]
  59             set children [winfo children $parent]
  60             set i [lsearch -exact $children $cur]
  61         }
  62         if {($cur == $w) || [ckFocusOK $cur]} {
  63             return $cur
  64         }
  65     }
  66 }
  67
  68 # ck_focusPrev --
  69 # This procedure returns the name of the previous window before "w" in
  70 # "focus order" (the window that should receive the focus next if
  71 # Shift-Tab is typed in w).  "Next" is defined by a pre-order search
  72 # of the current and its descendants, with the stacking
  73 # order determining the order of siblings.  The "-takefocus" options
  74 # on windows determine whether or not they should be skipped.
  75 #
  76 # Arguments:
  77 # w    -        Name of a window.
  78
  79 proc ck_focusPrev w {
  80     global ckPriv
  81     set cur $w
  82     while 1 {
  83
  84         # Collect information about the current window's position
  85         # among its siblings.
  86
  87         # Collect information about the current window's position
  88         # among its siblings.  Also, if the window is a top-level,
  89         # then reposition to just after the last child of the window.
  90
  91         if {[winfo toplevel $cur] == $cur || \
  92             $cur == $ckPriv(restrictWindow)}  {
  93             set parent $cur
  94             set children [winfo children $cur]
  95             set i [llength $children]
  96         } else {
  97             set parent [winfo parent $cur]
  98             set children [winfo children $parent]
  99             set i [lsearch -exact $children $cur]
 100         }
 101
 102         # Go to the previous sibling, then descend to its last descendant
 103         # (highest in stacking order.  While doing this, ignore top-levels
 104         # and their descendants.  When we run out of descendants, go up
 105         # one level to the parent.
 106
 107         while {$i > 0} {
 108             incr i -1
 109             set cur [lindex $children $i]
 110             if {[winfo toplevel $cur] == $cur} {
 111                 continue
 112             }
 113             set parent $cur
 114             set children [winfo children $parent]
 115             set i [llength $children]
 116         }
 117         set cur $parent
 118         if {($cur == $w) || [ckFocusOK $cur]} {
 119             return $cur
 120         }
 121     }
 122 }
 123
 124 # ckFocusOK --
 125 #
 126 # This procedure is invoked to decide whether or not to focus on
 127 # a given window.  It returns 1 if it's OK to focus on the window,
 128 # 0 if it's not OK.  The code first checks whether the window is
 129 # viewable.  If not, then it never focuses on the window.  Then it
 130 # checks the -takefocus option for the window and uses it if it's
 131 # set.  If there's no -takefocus option, the procedure checks to
 132 # see if (a) the widget isn't disabled, and (b) it has some key
 133 # bindings.  If all of these are true, then 1 is returned.
 134 #
 135 # Arguments:
 136 # w -           Name of a window.
 137
 138 proc ckFocusOK w {
 139     global ckPriv
 140     if {![winfo ismapped $w]} {return 0}
 141     if {$ckPriv(restrictWindow) != ""} {
 142         if {[winfo toplevel $w] == [winfo toplevel $ckPriv(restrictWindow)]} {
 143             if {[string first $ckPriv(restrictWindow) $w] != 0} {return 0}
 144         }
 145     }
 146     set code [catch {$w cget -takefocus} value]
 147     if {($code == 0) && ($value != "")} {
 148         if {$value == 0} {
 149             return 0
 150         } elseif {$value == 1} {
 151             # For listboxes: don't take focus if nothing selectable
 152             if {[winfo class $w] == "Listbox" && [$w size] == 0} {
 153                 return 0
 154             }
 155             return 1
 156         } else {
 157             set value [uplevel #0 $value $w]
 158             if {$value != ""} {
 159                 return $value
 160             }
 161         }
 162     }
 163     set code [catch {$w cget -state} value]
 164     if {($code == 0) && ($value == "disabled")} {
 165         return 0
 166     }
 167     regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
 168 }
 169
 170 # ck_RestrictFocus --
 171 #
 172 # This procedure implements restriction of keyboard focus on a
 173 # subtree of the widget hierarchy not including toplevels within
 174 # that subtree.
 175 #
 176 # Argument formats:
 177 #
 178 # w         -       Name of a window on which the restriction is placed.
 179 # current   -       Returns the current restrict window or an empty
 180 #                   string, if there's no restriction active.
 181 # release w -       If w is the current restrict window, the restriction is
 182 #                   released.
 183
 184 proc ck_RestrictFocus args {
 185     global ckPriv
 186     set len [llength $args]
 187     set opt [lindex $args 0]
 188     switch -glob -- $opt {
 189         .* {
 190             if {$len != 1} {
 191                 error "bad # arguments: must be \"ck_RestrictFocus window\""
 192             }
 193             if {![winfo exists $opt]} {
 194                 error "bad window pathname \"$opt\""
 195             }
 196             if {![winfo ismapped $opt]} {
 197                 error "window \"$opt\" not viewable"
 198             }
 199             set ckPriv(restrictWindow) $opt
 200             bind $opt <Destroy> {ck_Unrestrict %W}
 201             bind $opt <Unmap> {ck_Unrestrict %W}
 202         }
 203         c* {
 204             if {$len != 1} {
 205                 error "bad # arguments: must be \"ck_RestrictFocus current\""
 206             }
 207             return $ckPriv(restrictWindow)
 208         }
 209         r* {
 210             if {$len != 2} {
 211                 error \
 212         "bad # arguments: must be \"ck_RestrictFocus release window\""
 213             }
 214             set w [lindex $args 1]
 215             ck_Unrestrict $w
 216         }
 217         default {
 218             error "bad option \"$opt\": must be current or release"
 219         }
 220     }
 221 }
 222
 223 # ck_Unrestrict --
 224 #
 225 # This procedure is invoked on Destroy or Unmap events in order
 226 # to release a restriction on a window.
 227 #
 228 # Arguments:
 229 # w -           Name of a window.
 230
 231 proc ck_Unrestrict w {
 232     global ckPriv
 233     if {$w == $ckPriv(restrictWindow)} {
 234         set ckPriv(restrictWindow) {}
 235     }
 236     bind $w <Destroy> {# nothing}
 237     bind $w <Unmap> {# nothing}
 238 }