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

    }

}