--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/python-2.5.2/win32/tcl/tix8.4/OptMenu.tcl Fri Apr 03 17:19:34 2009 +0100
@@ -0,0 +1,394 @@
+# -*- 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
+}