URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [library/] [OptMenu.tcl] - Blame information for rev 1778

Go to most recent revision | Details | Compare with Previous | View Log


# OptMenu.tcl --
#
#       This file implements the TixOptionMenu widget.
#
# Copyright (c) 1996, Expert Interface Technologies
#
# 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
}

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tix/] [library/] [OptMenu.tcl] - Blame information for rev 1778

Line No.	Rev	Author	Line
1	578	markom	`# 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			`}`