tix/library/OptMenu.tcl

   1 # OptMenu.tcl --
   2 #
   3 #       This file implements the TixOptionMenu widget.
   4 #
   5 # Copyright (c) 1996, Expert Interface Technologies
   6 #
   7 # See the file "license.terms" for information on usage and redistribution
   8 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
   9 #
  10
  11
  12 tixWidgetClass tixOptionMenu {
  13     -classname TixOptionMenu
  14     -superclass tixLabelWidget
  15     -method {
  16         add delete disable enable entrycget entryconfigure entries
  17     }
  18     -flag {
  19         -command -disablecallback -dynamicgeometry -value -variable
  20         -validatecmd -state
  21     }
  22     -forcecall {
  23         -variable -state
  24     }
  25     -configspec {
  26         {-command command Command ""}
  27         {-disablecallback disableCallback DisableCallback 0 tixVerifyBoolean}
  28         {-dynamicgeometry dynamicGeometry DynamicGeometry 0 tixVerifyBoolean}
  29         {-state state State normal}
  30         {-value value Value ""}
  31         {-validatecmd validateCmd ValidateCmd ""}
  32         {-variable variable Variable ""}
  33     }
  34     -default {
  35         {.highlightThickness                    0}
  36         {.takeFocus                             0}
  37         {.frame.menubutton.relief               raised}
  38         {.frame.menubutton.borderWidth          2}
  39         {.frame.menubutton.anchor               w}
  40         {.frame.menubutton.highlightThickness   2}
  41         {.frame.menubutton.takeFocus            1}
  42     }
  43 }
  44
  45 proc tixOptionMenu:InitWidgetRec {w} {
  46     upvar #0 $w data
  47
  48     tixChainMethod $w InitWidgetRec
  49
  50     set data(nItems)    0
  51     set data(items)     ""
  52     set data(posted)    0
  53     set data(varInited) 0
  54     set data(maxWidth)  0
  55 }
  56
  57 proc tixOptionMenu:ConstructFramedWidget {w frame} {
  58     upvar #0 $w data
  59
  60     tixChainMethod $w ConstructFramedWidget $frame
  61
  62     set data(w:menubutton) [menubutton $frame.menubutton -indicatoron 1]
  63     set data(w:menu)       [menu $frame.menubutton.menu -tearoff 0]
  64     pack $data(w:menubutton) -side left -expand yes -fill both
  65
  66     $data(w:menubutton) config -menu $data(w:menu)
  67
  68     bind $data(w:menubutton) <Up>   [bind Menubutton <space>]
  69     bind $data(w:menubutton) <Down> [bind Menubutton <space>]
  70
  71     tixSetMegaWidget $data(w:menubutton) $w
  72 }
  73
  74 proc tixOptionMenu:SetBindings {w} {
  75     upvar #0 $w data
  76
  77     tixChainMethod $w SetBindings
  78 }
  79
  80 #----------------------------------------------------------------------
  81 # Private methods
  82 #----------------------------------------------------------------------
  83 proc tixOptionMenu:Invoke {w name} {
  84     upvar #0 $w data
  85
  86     if {"$data(-state)" == "normal"} {
  87         tixOptionMenu:SetValue $w $name
  88     }
  89 }
  90
  91 proc tixOptionMenu:SetValue {w value {noUpdate 0}} {
  92     upvar #0 $w data
  93
  94     if {$data(-validatecmd) != ""} {
  95         set value [tixEvalCmdBinding $w $data(-validatecmd) "" $value]
  96     }
  97
  98     set name $value
  99
 100     if {$name == "" || [info exists data(varInited)]} {
 101         # variable may contain a bogus value
 102         if {![info exists data($name,index)]} {
 103             set data(-value) ""
 104             tixVariable:UpdateVariable $w
 105             $data(w:menubutton) config -text ""
 106             return
 107         }
 108     }
 109
 110     if [info exists data($name,index)] {
 111        $data(w:menubutton) config -text $data($name,label)
 112
 113        set data(-value) $value
 114
 115        if {! $noUpdate} {
 116            tixVariable:UpdateVariable $w
 117        }
 118
 119        if {$data(-command) != "" && !$data(-disablecallback)} {
 120            if {![info exists data(varInited)]} {
 121                set bind(specs) ""
 122                tixEvalCmdBinding $w $data(-command) bind $value
 123            }
 124        }
 125     } else {
 126         error "item \"$value\" does not exist"
 127     }
 128 }
 129
 130 proc tixOptionMenu:SetMaxWidth {w} {
 131     upvar #0 $w data
 132
 133     foreach name $data(items) {
 134         set len [string length $data($name,label)]
 135         if {$data(maxWidth) < $len} {
 136             set data(maxWidth) $len
 137         }
 138     }
 139
 140     if {$data(maxWidth) > 0} {
 141         $data(w:menubutton) config -width $data(maxWidth)
 142     }
 143 }
 144
 145 #----------------------------------------------------------------------
 146 # Configuration
 147 #----------------------------------------------------------------------
 148 proc tixOptionMenu:config-state {w value} {
 149     upvar #0 $w data
 150
 151     if ![info exists data(w:label)] {
 152         return
 153     }
 154
 155     if {$value == "normal"} {
 156         catch {
 157             $data(w:label) config -fg \
 158                 [$data(w:menubutton) cget -foreground]
 159         }
 160         $data(w:menubutton) config -state $value
 161     } else {
 162         catch {
 163             $data(w:label) config -fg \
 164                 [$data(w:menubutton) cget -disabledforeground]
 165         }
 166         $data(w:menubutton) config -state $value
 167     }
 168 }
 169
 170 proc tixOptionMenu:config-value {w value} {
 171     upvar #0 $w data
 172
 173     tixOptionMenu:SetValue $w $value
 174
 175     # This will tell the Intrinsics: "Please use this value"
 176     # because "value" might be altered by SetValues
 177     #
 178     return $data(-value)
 179 }
 180
 181 proc tixOptionMenu:config-variable {w arg} {
 182     upvar #0 $w data
 183
 184     if [tixVariable:ConfigVariable $w $arg] {
 185        # The value of data(-value) is changed if tixVariable:ConfigVariable
 186        # returns true
 187        tixOptionMenu:SetValue $w $data(-value) 1
 188     }
 189     catch {
 190         unset data(varInited)
 191     }
 192     set data(-variable) $arg
 193 }
 194
 195 #----------------------------------------------------------------------
 196 # Public Methdos
 197 #----------------------------------------------------------------------
 198 proc tixOptionMenu:add {w type name args} {
 199     upvar #0 $w data
 200
 201     if [info exists data($name,index)] {
 202         error "item $name already exists in the option menu $w"
 203     }
 204
 205     case $type {
 206         "command" {
 207             set validOptions {
 208                 -command -label
 209             }
 210             set opt(-command)           ""
 211             set opt(-label)             $name
 212
 213             tixHandleOptions -nounknown opt $validOptions $args
 214
 215             if {$opt(-command)  != ""} {
 216                 error "option -command cannot be specified"
 217             }
 218
 219             # Create a new item inside the menu
 220             #
 221             eval $data(w:menu) add command $args \
 222                 [list -label $opt(-label) \
 223                 -command "tixOptionMenu:Invoke $w \{$name\}"]
 224             set index $data(nItems)
 225
 226             # Store info about this item
 227             #
 228             set data($index,name) $name
 229             set data($name,type) cmd
 230             set data($name,label) $opt(-label)
 231             set data($name,index) $index
 232
 233             if {$index == 0} {
 234                 $data(w:menubutton) config -text $data($name,label)
 235                 tixOptionMenu:SetValue $w $name
 236             }
 237
 238             incr data(nItems)
 239             lappend data(items) $name
 240
 241             if $data(-dynamicgeometry) {
 242                 tixOptionMenu:SetMaxWidth $w
 243             }
 244         }
 245         "separator" {
 246             $data(w:menu) add separator
 247
 248             set index $data(nItems)
 249             # Store info about this item
 250             #
 251             set data($index,name) $name
 252             set data($name,type) sep
 253             set data($name,label) ""
 254             set data($name,index) $index
 255
 256             incr data(nItems)
 257             lappend data(items) $name
 258         }
 259         default {
 260             error "only types \"separator\" and \"command\" are allowed"
 261         }
 262     }
 263
 264     return ""
 265 }
 266
 267 proc tixOptionMenu:delete {w item} {
 268     upvar #0 $w data
 269
 270     if {![info exists data($item,index)]} {
 271         error "item $item does not exist in $w"
 272     }
 273
 274     # Rehash the item list
 275     set newItems ""
 276     set oldIndex 0
 277     set newIndex 0
 278     foreach name $data(items) {
 279         if {$item == $name} {
 280             unset data($name,label)
 281             unset data($name,index)
 282             unset data($name,type)
 283             $data(w:menu) delete $oldIndex
 284         } else {
 285             set data($name,index)    $newIndex
 286             set data($newIndex,name) $name
 287             incr newIndex
 288             lappend newItems $name
 289         }
 290         incr oldIndex
 291     }
 292     incr oldIndex -1; unset data($oldIndex,name)
 293     set data(nItems) $newIndex
 294     set data(items) $newItems
 295
 296     if {$data(-value) == $item} {
 297         set newVal ""
 298         foreach item $data(items) {
 299             if {$data($item,type) == "cmd"} {
 300                 set newVal $item
 301             }
 302         }
 303         tixOptionMenu:SetValue $w $newVal
 304     }
 305
 306     return ""
 307 }
 308
 309
 310 proc tixOptionMenu:disable {w item} {
 311     upvar #0 $w data
 312
 313     if {![info exists data($item,index)]} {
 314         error "item $item does not exist in $w"
 315     } else {
 316         catch {$data(w:menu) entryconfig $data($item,index) -state disabled}
 317     }
 318 }
 319
 320 proc tixOptionMenu:enable {w item} {
 321     upvar #0 $w data
 322
 323     if {![info exists data($item,index)]} {
 324         error "item $item does not exist in $w"
 325     } else {
 326         catch {$data(w:menu) entryconfig $data($item,index) -state normal}
 327     }
 328 }
 329
 330 proc tixOptionMenu:entryconfigure {w item args} {
 331     upvar #0 $w data
 332
 333     if {![info exists data($item,index)]} {
 334         error "item $item does not exist in $w"
 335     } else {
 336         return [eval $data(w:menu) entryconfig $data($item,index) $args]
 337     }
 338 }
 339
 340 proc tixOptionMenu:entrycget {w item arg} {
 341     upvar #0 $w data
 342
 343     if {![info exists data($item,index)]} {
 344         error "item $item does not exist in $w"
 345     } else {
 346         return [$data(w:menu) entrycget $data($item,index) $arg]
 347     }
 348 }
 349
 350 proc tixOptionMenu:entries {w} {
 351     upvar #0 $w data
 352
 353     return $data(items)
 354 }
 355
 356
 357 proc tixOptionMenu:Destructor {w} {
 358
 359     tixVariable:DeleteVariable $w
 360
 361     # Chain this to the superclass
 362     #
 363     tixChainMethod $w Destructor
 364 }
 365
 366 #----------------------------------------------------------------------
 367 # Obsolete
 368 # These have been replaced by new commands in Tk 4.0
 369 #
 370 proc tixOptionMenu:Post {w} {
 371     upvar #0 $w data
 372
 373     set rootx [winfo rootx $data(w:frame)]
 374     set rooty [winfo rooty $data(w:frame)]
 375
 376     # adjust for the border of the menu and frame
 377     #
 378     incr rootx [lindex [$data(w:menu)  config -border] 4]
 379     incr rooty [lindex [$data(w:frame) config -border] 4]
 380     incr rooty [lindex [$data(w:menu)  config -border] 4]
 381
 382     set value $data(-value)
 383     set y [$data(w:menu) yposition $data($value,index)]
 384
 385     $data(w:menu) post $rootx [expr $rooty - $y]
 386     $data(w:menu) activate $data($value,index)
 387     grab -global $data(w:menubutton)
 388     set data(posted) 1
 389 }