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