share/redhat/gui/bindings.tcl

# bindings.tcl - Procs to handle bindings.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.

# Reorder the bindtags so that the tag appears before the widget.
# Tries to preserve other relative orderings as much as possible.  In
# particular, nothing changes if the widget is already after the tag.
proc bind_widget_after_tag {w tag} {
  set seen_tag 0
  set seen_widget 0
  set new_list {}
  foreach tag [bindtags $w] {
    if {$tag == $tag} then {
      lappend new_list $tag
      if {$seen_widget} then {
	lappend new_list $w
      }
      set seen_tag 1
    } elseif {$tag == $w} then {
      if {$seen_tag} then {
	lappend new_list $tag
      }
      set seen_widget 1
    } else {
      lappend new_list $tag
    }
  }

  if {! $seen_widget} then {
    lappend new_list $w
  }

  bindtags $w $new_list
}

# Reorder the bindtags so that the class appears before the widget.
# Tries to preserve other relative orderings as much as possible.  In
# particular, nothing changes if the widget is already after the
# class.
proc bind_widget_after_class {w} {
  bind_widget_after_tag $w [winfo class $w]
}

# Make the specified binding for KEY and empty bindings for common
# modifiers for KEY.  This can be used to ensure that a binding won't
# also be triggered by (eg) Alt-KEY.  This proc also makes the binding
# case-insensitive.  KEY is either the name of a key, or a key with a
# single modifier.
proc bind_plain_key {w key binding} {
  set l [split $key -]
  if {[llength $l] == 1} then {
    set mod {}
    set part $key
  } else {
    set mod "[lindex $l 0]-"
    set part [lindex $l 1]
  }

  set modifiers {Meta- Alt- Control-}

  set part_list [list $part]
  # If we just have a single letter, then we can't look for
  # Shift-PART; we must use the uppercase equivalent.
  if {[string length $part] == 1} then {
    # This is nasty: if we bind Control-L, we won't see the events we
    # want.  Instead we have to bind Shift-Control-L.  Actually, we
    # must also bind Control-L so that we'll see the event if the Caps
    # Lock key is down.
    if {$mod != ""} then {
      lappend part_list "Shift-[string toupper $part]"
    }
    lappend part_list [string toupper $part]
  } else {
    lappend modifiers Shift-
  }

  foreach part $part_list {
    # Bind the key itself (with modifier if required).
    bind $w <${mod}${part}> $binding

    # Ignore any modifiers other than the one we like.
    foreach onemod $modifiers {
      if {$onemod != $mod} then {
	bind $w <${onemod}${part}> {;}
      }
    }
  }
}