Subversion Repositories or1k

# 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

    }

}