diff options
Diffstat (limited to 'tix/library/Event.tcl')
| -rw-r--r-- | tix/library/Event.tcl | 239 |
1 files changed, 239 insertions, 0 deletions
diff --git a/tix/library/Event.tcl b/tix/library/Event.tcl new file mode 100644 index 00000000000..c04f60a395c --- /dev/null +++ b/tix/library/Event.tcl @@ -0,0 +1,239 @@ +# Event.tcl -- +# +# Handles the event bindings of the -command and -browsecmd options +# (and various of others such as -validatecmd). +# +# Copyright (c) 1996, Expert Interface Technologies +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#---------------------------------------------------------------------- +# Evaluate high-level bindings (-command, -browsecmd, etc): +# with % subsitution or without (compatibility mode) +# +# +# BUG : if a -command is intercepted by a hook, the hook must use +# the same record name as the issuer of the -command. For the time +# being, you must use the name "bind" as the record name!!!!! +# +#---------------------------------------------------------------------- +set _tix_event_flags "" +append _tix_event_flags " %%" +append _tix_event_flags " %#" +#append _tix_event_flags " %a" +append _tix_event_flags " %b" +append _tix_event_flags " %c" +append _tix_event_flags " %d" +append _tix_event_flags " %f" +append _tix_event_flags " %h" +append _tix_event_flags " %k" +append _tix_event_flags " %m" +append _tix_event_flags " %o" +append _tix_event_flags " %p" +append _tix_event_flags " %s" +append _tix_event_flags " %t" +append _tix_event_flags " %w" +append _tix_event_flags " %x" +append _tix_event_flags " %y" +append _tix_event_flags " %A" +append _tix_event_flags " %B" +append _tix_event_flags " %E" +append _tix_event_flags " %K" +append _tix_event_flags " %N" +append _tix_event_flags " %R" +#append _tix_event_flags " %S" +append _tix_event_flags " %T" +append _tix_event_flags " %W" +append _tix_event_flags " %X" +append _tix_event_flags " %Y" + +proc tixBind {tag event action} { + global _tix_event_flags + + append cmd "_tixRecordFlags $event $_tix_event_flags;" + append cmd "$action; " + append cmd "_tixDeleteFlags" + + bind $tag $event $cmd +} + +# This is a "name stack" for storing the "bind" structures +# +# The bottom of the event stack is usually a raw event (generated by tixBind) +# but it may also be a programatically triggered (caused by tixEvalCmdBinding) +# +# + +set tixEvent(nameStack) "" +set tixEvent(stackLevel) 0 + +proc tixPushEventStack {} { + global tixEvent + + set lastEvent [lindex $tixEvent(nameStack) 0] + incr tixEvent(stackLevel) + set thisEvent _tix_event$tixEvent(stackLevel) + + set tixEvent(nameStack) \ + [list $thisEvent $tixEvent(nameStack)] + + if {$lastEvent == ""} { + upvar #0 $thisEvent this + set this(type) <Application> + } else { + upvar #0 $lastEvent last + upvar #0 $thisEvent this + + foreach name [array names last] { + set this($name) $last($name) + } + } + + return $thisEvent +} + +proc tixPopEventStack {varName} { + global tixEvent + + if {$varName != [lindex $tixEvent(nameStack) 0]} { + error "unmatched tixPushEventStack and tixPopEventStack calls" + } + incr tixEvent(stackLevel) -1 + set tixEvent(nameStack) [lindex $tixEvent(nameStack) 1] + global $varName + unset $varName +} + + +# Events triggered by tixBind +# +proc _tixRecordFlags [concat event $_tix_event_flags] { + global _tix_event_flags + + set thisName [tixPushEventStack]; upvar #0 $thisName this + + set this(type) $event + foreach f $_tix_event_flags { + set this($f) [set $f] + } +} + +proc _tixDeleteFlags {} { + global tixEvent + + tixPopEventStack [lindex $tixEvent(nameStack) 0] +} + +# programatically trigged events +# +proc tixEvalCmdBinding {w cmd {subst ""} args} { + global tixPriv tixEvent tix + + set thisName [tixPushEventStack]; upvar #0 $thisName this + + if {$subst != ""} { + upvar $subst bind + + if [info exists bind(specs)] { + foreach spec $bind(specs) { + set this($spec) $bind($spec) + } + } + if [info exists bind(type)] { + set this(type) $bind(type) + } + } + + if [catch { + if [tixGetBoolean -nocomplain $tix(-extracmdargs)] { + # Compatibility mode + # + set ret [uplevel #0 $cmd $args] + } else { + set ret [uplevel $cmd] + } + } error] { + if [catch { + tixCmdErrorHandler $error + } error] { + # double fault: just print out + tixBuiltInCmdErrorHandler $error + } + tixPopEventStack $thisName + return "" + } else { + tixPopEventStack $thisName + + return $ret + } +} + +proc tixEvent {option args} { + global tixPriv tixEvent + set varName [lindex $tixEvent(nameStack) 0] + + if {$varName == ""} { + error "tixEvent called when no event is being processed" + } else { + upvar #0 $varName event + } + + case $option { + type { + return $event(type) + } + value { + if [info exists event(%V)] { + return $event(%V) + } else { + return "" + } + } + flag { + set f %[lindex $args 0] + if [info exists event($f)] { + return $event($f) + } + error "The flag \"[lindex $args 0]\" does not exist" + } + match { + return [string match [lindex $args 0] $event(type)] + } + default { + error "unknown option \"$option\"" + } + } +} + +# tixBuiltInCmdErrorHandler -- +# +# Default method to report command handler errors. This procedure is +# also called if double-fault happens (command handler causes error, +# then tixCmdErrorHandler causes error). +# +proc tixBuiltInCmdErrorHandler {errorMsg} { + global errorInfo tcl_platform + if ![info exists errorInfo] { + set errorInfo "???" + } + if {$tcl_platform(platform) == "windows"} then { + bgerror "Tix Error: $errorMsg" + } else { + puts "Error:\n $errorMsg\n$errorInfo" + } +} + +# tixCmdErrorHandler -- +# +# You can redefine this command to handle the errors that occur +# in the command handlers. See the programmer's documentation +# for details +# +if ![string compare [info command tixCmdErrorHandler] ""] { + proc tixCmdErrorHandler {errorMsg} { + tixBuiltInCmdErrorHandler $errorMsg + } +} + |