libgui/library/bindings.tcl

   1 # bindings.tcl - Procs to handle bindings.
   2 # Copyright (C) 1997 Cygnus Solutions.
   3 # Written by Tom Tromey <tromey@cygnus.com>.
   4
   5 # Reorder the bindtags so that the tag appears before the widget.
   6 # Tries to preserve other relative orderings as much as possible.  In
   7 # particular, nothing changes if the widget is already after the tag.
   8 proc bind_widget_after_tag {w tag} {
   9   set seen_tag 0
  10   set seen_widget 0
  11   set new_list {}
  12   foreach tag [bindtags $w] {
  13     if {$tag == $tag} then {
  14       lappend new_list $tag
  15       if {$seen_widget} then {
  16         lappend new_list $w
  17       }
  18       set seen_tag 1
  19     } elseif {$tag == $w} then {
  20       if {$seen_tag} then {
  21         lappend new_list $tag
  22       }
  23       set seen_widget 1
  24     } else {
  25       lappend new_list $tag
  26     }
  27   }
  28
  29   if {! $seen_widget} then {
  30     lappend new_list $w
  31   }
  32
  33   bindtags $w $new_list
  34 }
  35
  36 # Reorder the bindtags so that the class appears before the widget.
  37 # Tries to preserve other relative orderings as much as possible.  In
  38 # particular, nothing changes if the widget is already after the
  39 # class.
  40 proc bind_widget_after_class {w} {
  41   bind_widget_after_tag $w [winfo class $w]
  42 }
  43
  44 # Make the specified binding for KEY and empty bindings for common
  45 # modifiers for KEY.  This can be used to ensure that a binding won't
  46 # also be triggered by (eg) Alt-KEY.  This proc also makes the binding
  47 # case-insensitive.  KEY is either the name of a key, or a key with a
  48 # single modifier.
  49 proc bind_plain_key {w key binding} {
  50   set l [split $key -]
  51   if {[llength $l] == 1} then {
  52     set mod {}
  53     set part $key
  54   } else {
  55     set mod "[lindex $l 0]-"
  56     set part [lindex $l 1]
  57   }
  58
  59   set modifiers {Meta- Alt- Control-}
  60
  61   set part_list [list $part]
  62   # If we just have a single letter, then we can't look for
  63   # Shift-PART; we must use the uppercase equivalent.
  64   if {[string length $part] == 1} then {
  65     # This is nasty: if we bind Control-L, we won't see the events we
  66     # want.  Instead we have to bind Shift-Control-L.  Actually, we
  67     # must also bind Control-L so that we'll see the event if the Caps
  68     # Lock key is down.
  69     if {$mod != ""} then {
  70       lappend part_list "Shift-[string toupper $part]"
  71     }
  72     lappend part_list [string toupper $part]
  73   } else {
  74     lappend modifiers Shift-
  75   }
  76
  77   foreach part $part_list {
  78     # Bind the key itself (with modifier if required).
  79     bind $w <${mod}${part}> $binding
  80
  81     # Ignore any modifiers other than the one we like.
  82     foreach onemod $modifiers {
  83       if {$onemod != $mod} then {
  84         bind $w <${onemod}${part}> {;}
  85       }
  86     }
  87   }
  88 }