You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
89 lines
2.5 KiB
Tcl
89 lines
2.5 KiB
Tcl
15 years ago
|
# 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}> {;}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|