Viewing file:  Event.tcl (5.74 KB) -rw-r--r--
Select action/file-type:
 (+) |  (+) |  (+) | Code (+) | Session (+) |  (+) | SDB (+) |  (+) |  (+) |  (+) |  (+) |  (+) |
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
#
# $Id: Event.tcl,v 1.3.2.1 2001/11/03 06:43:50 idiscovery Exp $
#
# Event.tcl --
#
# Handles the event bindings of the -command and -browsecmd options
# (and various of others such as -validatecmd).
#
# Copyright (c) 1993-1999 Ioi Kim Lam.
# Copyright (c) 2000-2001 Tix Project Group.
#
# 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
}
}
|