# 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
    }
}

