# -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-

#

#	$Id: OptMenu.tcl,v 1.3 2001/12/09 05:04:02 idiscovery Exp $

#

# OptMenu.tcl --

#

#	This file implements the TixOptionMenu widget.

#

# Copyright (c) 1993-1999 Ioi Kim Lam.

# Copyright (c) 2000-2001 Tix Project Group.

#

# See the file "license.terms" for information on usage and redistribution

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#

tixWidgetClass tixOptionMenu {

    -classname TixOptionMenu

    -superclass tixLabelWidget

    -method {

	add delete disable enable entrycget entryconfigure entries

    }

    -flag {

	-command -disablecallback -dynamicgeometry -value -variable

	-validatecmd -state

    }

    -forcecall {

	-variable -state

    }

    -configspec {

	{-command command Command ""}

	{-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean}

	{-dynamicgeometry dynamicGeometry DynamicGeometry 0 tixVerifyBoolean}

	{-state state State normal}

	{-value value Value ""}

	{-validatecmd validateCmd ValidateCmd ""}

	{-variable variable Variable ""}

    }

    -default {

	{.highlightThickness			0}

	{.takeFocus				0}

	{.frame.menubutton.relief		raised}

	{.frame.menubutton.borderWidth		2}

	{.frame.menubutton.anchor		w}

	{.frame.menubutton.highlightThickness	2}

	{.frame.menubutton.takeFocus		1}

    }

}

proc tixOptionMenu:InitWidgetRec {w} {

    upvar #0 $w data

    tixChainMethod $w InitWidgetRec

    set data(nItems)	0

    set data(items)     ""

    set data(posted)	0

    set data(varInited)	0

    set data(maxWidth)  0

}

proc tixOptionMenu:ConstructFramedWidget {w frame} {

    upvar #0 $w data

    tixChainMethod $w ConstructFramedWidget $frame

    set data(w:menubutton) [menubutton $frame.menubutton -indicatoron 1]

    set data(w:menu)       [menu $frame.menubutton.menu -tearoff 0]

    pack $data(w:menubutton) -side left -expand yes -fill both

    $data(w:menubutton) config -menu $data(w:menu)

    bind $data(w:menubutton) <Up>   [bind Menubutton <space>]

    bind $data(w:menubutton) <Down> [bind Menubutton <space>]

    tixSetMegaWidget $data(w:menubutton) $w

}

proc tixOptionMenu:SetBindings {w} {

    upvar #0 $w data

    tixChainMethod $w SetBindings

}

#----------------------------------------------------------------------

# Private methods

#----------------------------------------------------------------------

proc tixOptionMenu:Invoke {w name} {

    upvar #0 $w data

    if {"$data(-state)" == "normal"} {

	tixOptionMenu:SetValue $w $name

    }

}

proc tixOptionMenu:SetValue {w value {noUpdate 0}} {

    upvar #0 $w data

    if {$data(-validatecmd) != ""} {

	set value [tixEvalCmdBinding $w $data(-validatecmd) "" $value]

    }

    set name $value

    if {$name == "" || [info exists data(varInited)]} {

	# variable may contain a bogus value

	if {![info exists data($name,index)]} {

	    set data(-value) ""

	    tixVariable:UpdateVariable $w

	    $data(w:menubutton) config -text ""

	    return

	}

    }

    if {[info exists data($name,index)]} {

       $data(w:menubutton) config -text $data($name,label)

       set data(-value) $value

       if {! $noUpdate} {

	   tixVariable:UpdateVariable $w

       }

       if {$data(-command) != "" && !$data(-disablecallback)} {

	   if {![info exists data(varInited)]} {

	       set bind(specs) ""

	       tixEvalCmdBinding $w $data(-command) bind $value

	   }

       }

    } else {

	error "item \"$value\" does not exist"

    }

}

proc tixOptionMenu:SetMaxWidth {w} {

    upvar #0 $w data

    foreach name $data(items) {

	set len [string length $data($name,label)]

	if {$data(maxWidth) < $len} {

	    set data(maxWidth) $len

	}

    }

    if {$data(maxWidth) > 0} {

	$data(w:menubutton) config -width $data(maxWidth)

    }

}

#----------------------------------------------------------------------

# Configuration

#----------------------------------------------------------------------

proc tixOptionMenu:config-state {w value} {

    upvar #0 $w data

    if {![info exists data(w:label)]} {

	return

    }

    if {$value == "normal"} {

	catch {

	    $data(w:label) config -fg \

		[$data(w:menubutton) cget -foreground]

	}

	$data(w:menubutton) config -state $value

    } else {

	catch {

	    $data(w:label) config -fg \

		[$data(w:menubutton) cget -disabledforeground]

	}

	$data(w:menubutton) config -state $value

    }

}

proc tixOptionMenu:config-value {w value} {

    upvar #0 $w data

    tixOptionMenu:SetValue $w $value

    # This will tell the Intrinsics: "Please use this value"

    # because "value" might be altered by SetValues

    #

    return $data(-value)

}

proc tixOptionMenu:config-variable {w arg} {

    upvar #0 $w data

    if {[tixVariable:ConfigVariable $w $arg]} {

       # The value of data(-value) is changed if tixVariable:ConfigVariable 

       # returns true

       tixOptionMenu:SetValue $w $data(-value) 1

    }

    catch {

	unset data(varInited)

    }

    set data(-variable) $arg

}

#----------------------------------------------------------------------

# Public Methdos

#----------------------------------------------------------------------

proc tixOptionMenu:add {w type name args} {

    upvar #0 $w data

    if {[info exists data($name,index)]} {

	error "item $name already exists in the option menu $w"

    }

    case $type {

	"command" {

	    set validOptions {

		-command -label

	    }

	    set opt(-command)		""

	    set opt(-label)		$name

	    tixHandleOptions -nounknown opt $validOptions $args

	    if {$opt(-command)	!= ""} {

		error "option -command cannot be specified"

	    }

	    # Create a new item inside the menu

	    #

	    eval $data(w:menu) add command $args \

		[list -label $opt(-label) \

		-command "tixOptionMenu:Invoke $w \{$name\}"]

	    set index $data(nItems)

	    # Store info about this item

	    #

	    set data($index,name) $name

	    set data($name,type) cmd

	    set data($name,label) $opt(-label)

	    set data($name,index) $index

	    if {$index == 0} {

		$data(w:menubutton) config -text $data($name,label)

		tixOptionMenu:SetValue $w $name

	    }

	    incr data(nItems)

	    lappend data(items) $name

	    if $data(-dynamicgeometry) {

		tixOptionMenu:SetMaxWidth $w

	    }

	}

	"separator" {

	    $data(w:menu) add separator

	    set index $data(nItems)

	    # Store info about this item

	    #

	    set data($index,name) $name

	    set data($name,type) sep

	    set data($name,label) ""

	    set data($name,index) $index

	    incr data(nItems)

	    lappend data(items) $name

	}

	default {

	    error "only types \"separator\" and \"command\" are allowed"

	}

    }

    return ""

}

proc tixOptionMenu:delete {w item} {

    upvar #0 $w data

    if {![info exists data($item,index)]} {

	error "item $item does not exist in $w"

    }

    # Rehash the item list

    set newItems ""

    set oldIndex 0

    set newIndex 0

    foreach name $data(items) {

	if {$item == $name} {

	    unset data($name,label)

	    unset data($name,index)

	    unset data($name,type)

	    $data(w:menu) delete $oldIndex

	} else {

	    set data($name,index)    $newIndex

	    set data($newIndex,name) $name

	    incr newIndex

	    lappend newItems $name

	}

	incr oldIndex

    }

    incr oldIndex -1; unset data($oldIndex,name)

    set data(nItems) $newIndex

    set data(items) $newItems

    if {$data(-value) == $item} {

	set newVal ""

	foreach item $data(items) {

	    if {$data($item,type) == "cmd"} {

		set newVal $item

	    }

	}

	tixOptionMenu:SetValue $w $newVal

    }

    return ""

}

proc tixOptionMenu:disable {w item} {

    upvar #0 $w data

    if {![info exists data($item,index)]} {

	error "item $item does not exist in $w"

    } else {

	catch {$data(w:menu) entryconfig $data($item,index) -state disabled}

    }

}

proc tixOptionMenu:enable {w item} {

    upvar #0 $w data

    if {![info exists data($item,index)]} {

	error "item $item does not exist in $w"

    } else {

	catch {$data(w:menu) entryconfig $data($item,index) -state normal}

    }

}

proc tixOptionMenu:entryconfigure {w item args} {

    upvar #0 $w data

    if {![info exists data($item,index)]} {

	error "item $item does not exist in $w"

    } else {

	return [eval $data(w:menu) entryconfig $data($item,index) $args]

    }

}

proc tixOptionMenu:entrycget {w item arg} {

    upvar #0 $w data

    if {![info exists data($item,index)]} {

	error "item $item does not exist in $w"

    } else {

	return [$data(w:menu) entrycget $data($item,index) $arg]

    }

}

proc tixOptionMenu:entries {w} {

    upvar #0 $w data

    return $data(items)

}

proc tixOptionMenu:Destructor {w} {

    tixVariable:DeleteVariable $w

    # Chain this to the superclass

    #

    tixChainMethod $w Destructor

}

#----------------------------------------------------------------------

# Obsolete

# These have been replaced by new commands in Tk 4.0

#

proc tixOptionMenu:Post {w} {

    upvar #0 $w data

    set rootx [winfo rootx $data(w:frame)]

    set rooty [winfo rooty $data(w:frame)]

    # adjust for the border of the menu and frame

    #

    incr rootx [lindex [$data(w:menu)  config -border] 4]

    incr rooty [lindex [$data(w:frame) config -border] 4]

    incr rooty [lindex [$data(w:menu)  config -border] 4]

    set value $data(-value)

    set y [$data(w:menu) yposition $data($value,index)]

    $data(w:menu) post $rootx [expr $rooty - $y]

    $data(w:menu) activate $data($value,index)

    grab -global $data(w:menubutton)

    set data(posted) 1

}