| 1 |
578 |
markom |
# 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 |
|
|
}
|
