Server : Apache System : Linux server1.cgrithy.com 3.10.0-1160.95.1.el7.x86_64 #1 SMP Mon Jul 24 13:59:37 UTC 2023 x86_64 User : nobody ( 99) PHP Version : 8.1.23 Disable Function : NONE Directory : /lib64/tcl8.5/Tix8.4.3/ |
# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- # # $Id: Event.tcl,v 1.6 2004/04/09 21:37:01 hobbs 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. # Copyright (c) 2004 ActiveState # # 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!!!!! # #---------------------------------------------------------------------- namespace eval ::tix { variable event_flags "" set evs [list % \# a b c d f h k m o p s t w x y A B E K N R S T W X Y] foreach ev $evs { lappend event_flags "%$ev" } # 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) variable EVENT set EVENT(nameStack) "" set EVENT(stackLevel) 0 } proc tixBind {tag event action} { set cmd [linsert $::tix::event_flags 0 _tixRecordFlags $event] append cmd "; $action; _tixDeleteFlags;" bind $tag $event $cmd } proc tixPushEventStack {} { variable ::tix::EVENT set lastEvent [lindex $EVENT(nameStack) 0] incr EVENT(stackLevel) set thisEvent ::tix::_event$EVENT(stackLevel) set EVENT(nameStack) [list $thisEvent $EVENT(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} { 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 } }