golden hour

/lib64/tcl8.5/Tix8.4.3

File/Folder	Size	Actions
Balloon.tcl	12.97 KB
BtnBox.tcl	2.61 KB
CObjView.tcl	7.56 KB
ChkList.tcl	4.97 KB
ComboBox.tcl	35.42 KB
Compat.tcl	870 B
Console.tcl	14.95 KB
Control.tcl	12.11 KB
DefSchm.tcl	2.94 KB
DialogS.tcl	4.2 KB
DirBox.tcl	5.3 KB
DirDlg.tcl	2.15 KB
DirList.tcl	6.9 KB
DirTree.tcl	8.76 KB
DragDrop.tcl	3.93 KB
DtlList.tcl	1002 B
EFileBox.tcl	11.12 KB
EFileDlg.tcl	1.68 KB
Event.tcl	5.11 KB
FileBox.tcl	14 KB
FileCbx.tcl	2.42 KB
FileDlg.tcl	2.13 KB
FileEnt.tcl	7.15 KB
FloatEnt.tcl	3.1 KB
Grid.tcl	21.16 KB
HList.tcl	17.72 KB
HListDD.tcl	4.39 KB
IconView.tcl	5.97 KB
Init.tcl	6.05 KB
LabEntry.tcl	2.09 KB
LabFrame.tcl	1.15 KB
LabWidg.tcl	3.86 KB
ListNBk.tcl	3.5 KB
Meter.tcl	3.04 KB
MultView.tcl	3.62 KB
NoteBook.tcl	6.02 KB
OldUtil.tcl	2.98 KB
OptMenu.tcl	9.17 KB
PanedWin.tcl	27.68 KB
PopMenu.tcl	5.37 KB
Primitiv.tcl	10.28 KB
README.txt	987 B
ResizeH.tcl	12.94 KB
SGrid.tcl	5.8 KB
SHList.tcl	3.7 KB
SListBox.tcl	6.97 KB
STList.tcl	2.37 KB
SText.tcl	3.09 KB
SWidget.tcl	9.52 KB
SWindow.tcl	6.75 KB
Select.tcl	7.04 KB
Shell.tcl	1.06 KB
SimpDlg.tcl	1.13 KB
StackWin.tcl	1.95 KB
StatBar.tcl	1.31 KB
StdBBox.tcl	1.62 KB
StdShell.tcl	1.15 KB
TList.tcl	17.59 KB
Tix.tcl	9.51 KB
Tree.tcl	4.57 KB
Utils.tcl	10.54 KB
VResize.tcl	4.95 KB
VStack.tcl	9.42 KB
VTree.tcl	4.31 KB
Variable.tcl	2.5 KB
WInfo.tcl	965 B
bitmaps	-
fs.tcl	3.9 KB
html	-
libTix.so	320.71 KB
license.terms	2.76 KB
pkgIndex.tcl	122 B
pref	-

Edit: OptMenu.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
}