} else { upvar #0 $lastEvent last upvar #0 $thisEvent this foreach name [array names last] { set this($name) $last($name) } } return $thisEvent } proc tixPopEventStack {varName} { variable ::tix::EVENT if {$varName ne [lindex $EVENT(nameStack) 0]} { error "unmatched tixPushEventStack and tixPopEventStack calls" } incr EVENT(stackLevel) -1 set EVENT(nameStack) [lindex $EVENT(nameStack) 1] global $varName unset $varName } # Events triggered by tixBind # proc _tixRecordFlags [concat event $::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 {} { variable ::tix::EVENT tixPopEventStack [lindex $EVENT(nameStack) 0] } # programatically trigged events # proc tixEvalCmdBinding {w cmd {subst ""} args} { global tixPriv tix variable ::tix::EVENT 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 {![info exists tix(-extracmdargs)] || [string is true -strict $tix(-extracmdargs)]} { # Compatibility mode set ret [uplevel \#0 $cmd $args] } else { set ret [uplevel 1 $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 variable ::tix::EVENT set varName [lindex $EVENT(nameStack) 0] if {$varName == ""} { error "tixEvent called when no event is being processed" } else { upvar #0 $varName event } switch -exact -- $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) eq "windows"} { 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 {![llength [info commands tixCmdErrorHandler]]} { proc tixCmdErrorHandler {errorMsg} { tixBuiltInCmdErrorHandler $errorMsg } }