394 lines
9.2 KiB
Tcl
394 lines
9.2 KiB
Tcl
# -*- 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
|
|
}
|