Import build of Tcl/Tk 8.6.10
This commit is contained in:
Steve Dower
@@ -1,217 +1,217 @@
|
||||
# -*- 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
|
||||
}
|
||||
}
|
||||
|
||||
# -*- 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
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user