1 # ui-tk.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1996-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/common/ui-tk.tcl,v 1.21 2002/05/28 23:22:02 weitsang Exp $
32
33
34 import Configuration Application
35
36 #
37 # An abstract base class for defining some common methods for tk
38 # windows. TkWindows are not necessarily toplevel windows.
39 #
40 Class TkWindow -configuration {
41 background gray85
42 }
43
44 #
45 # An abstract base class for defining some common methods for toplevel
46 # windows. <p>
47 # All concrete subclasses representing toggle-able windows should
48 # implement a <i>build</i> method.
49 #
50 Class TopLevelWindow -superclass TkWindow
51
52 #
53 # Add the <i>path</i> of this tk widget to the data structure.
54 #
55 TkWindow public init {path} {
56 $self next
57 $self instvar path_
58 set path_ $path
59 }
60
61 #
62 # Accessor function.
63 #
64 TkWindow public widget_path {} {
65 $self instvar path_
66 return $path_
67 }
68
69 #
70 # Check if a given $x $y point falls into this window.
71 #
72 TkWindow public contain {x y} {
73 $self instvar path_
74 set rootx [winfo rootx $path_]
75 set rooty [winfo rooty $path_]
76 set w [winfo width $path_]
77 set h [winfo height $path_]
78 if {$x > $rootx && $x < $rootx + $w} {
79 if {$y > $rooty && $y < $rooty + $h} {
80 return 1
81 }
82 }
83 return 0
84 }
85
86 #
87 # A mechanism for deleting the widget represented by this TkWindow,
88 # including all its children.
89 #
90 TkWindow instproc destroy {} {
91 $self instvar path_
92 if [winfo exists $path_] {
93 destroy $path_
94 }
95 $self next
96 }
97
98 #
99 # Color the background of this widget and all its children.
100 #
101 TkWindow instproc highlight { color } {
102 $self instvar path_
103
104 if { $path_ != "" } {
105 $path_ configure -background $color
106 foreach child [winfo children $path_] {
107 window_highlight $child $color
108 }
109 }
110 }
111
112 #
113 # Color the background of the window.
114 #
115 TkWindow instproc set_background { color } {
116 $self instvar path_
117 $path_ configure -background $color
118 }
119
120 #
121 # Builds the window itself if one does not already exist by this
122 # TkWindow's widgetpath.
123 #
124 TopLevelWindow public build_window {} {
125 $self instvar path_
126 if ![winfo exists $path_] {
127 $self build $path_
128 }
129 }
130
131
132 #
133 # If the window does not already exist, build it. If the window is
134 # currently being displayed, withdraw it. If the window is not
135 # currently being displayed, map it (i.e. display it).
136 #
137 TopLevelWindow instproc toggle {} {
138 $self build_window
139 $self instvar path_
140 set w $path_
141 $self instvar __mappedBefore__
142 if { [winfo ismapped $w] } {
143 wm withdraw $w
144 return
145 } elseif ![info exists __mappedBefore__] {
146 set __mappedBefore__ 1
147 wm transient $w .
148 update idletasks
149 set x [winfo rootx .]
150 set y [winfo rooty .]
151 incr y [winfo height .]
152 incr y -[winfo reqheight $w]
153 incr y -20
154 # adjust for virtual desktops
155 incr x [winfo vrootx .]
156 incr y [winfo vrooty .]
157 if { $y < 0 } { set y 0 }
158 if { $x < 0 } {
159 set x 0
160 } else {
161 set right [expr [winfo screenwidth .] - \
162 [winfo reqwidth $w]]
163 if { $x > $right } {
164 set x $right
165 }
166 }
167 wm geometry $w +$x+$y
168 }
169 wm deiconify $w
170 }
171
172 #
173 # Instantiate, but do not yet display or iconify, a toplevel using
174 # the provided widgetpath, <i>w</i>. Also label this window and its icon
175 # with the provided <i>title</i>.
176 #
177 TopLevelWindow instproc create-window { w title } {
178 Application toplevel $w
179 set title "[$self get_option iconPrefix] $title"
180 wm transient $w .
181 wm title $w $title
182 wm iconname $w $title
183 bind $w <Enter> "focus $w"
184 wm withdraw $w
185 }
186
187 #
188 # A toggle-able toplevel window for displaying bulleted text-items.
189 #
190 Class HelpWindow -superclass TopLevelWindow
191
192 #
193 # Instantiate, but do not yet display or iconify, a toplevel window using the
194 # provided widgetpath, <i>w</i>. Within <i>w</i>, create a bulleted
195 # message for each member of the <i>items</i> list, which should be a
196 # series of quoted chunks of text. Include a "Dismiss" button to unmap
197 # this window. Also label this window and its icon with the provided
198 # <i>title</i>.
199 #
200 HelpWindow instproc create-window { w title items } {
201 $self next $w $title
202 frame $w.frame -borderwidth 0 -relief flat
203 set p $w.frame
204 set n 0
205 foreach m $items {
206 set h $w.h$n
207 incr n
208 frame $h
209 $self helpitem $h $m
210 pack $h -expand 1 -fill both
211 }
212 button $w.frame.ok -text " Dismiss " -borderwidth 2 -relief raised \
213 -command "wm withdraw $w" -font [$self get_option medfont]
214 pack $w.frame.ok -pady 6 -padx 6 -anchor e
215 pack $w.frame -expand 1 -fill both
216 wm protocol $w WM_DELETE_WINDOW "wm withdraw $w"
217 }
218
219 #
220 # Within the provided widget, <i>w</i>, display a bulleted tk-message
221 # widget containing the provided <i>text</i>. <br> The options database
222 # must define helpFont before invoking this method.
223 #
224 HelpWindow instproc helpitem { w text } {
225 set f [$self get_option helpFont]
226 canvas $w.bullet -width 12 -height 12
227 $w.bullet create oval 6 3 12 9 -fill black
228 message $w.msg -justify left -anchor w -font $f -width 450 -text $text
229 pack $w.bullet -side left -anchor ne -pady 5
230 pack $w.msg -side left -expand 1 -fill x -anchor nw
231 }
232
233 #
234 # A toplevel window at ".dialog" for presenting the user with an error message.
235 #
236 Class ErrorWindow -superclass TopLevelWindow
237 #FIXME
238
239 #
240 # Creates a toplevel window that displays the <i>text</i> error message.
241 # The window includes an "OK" button that must be selected before
242 # continuing execution. <br>
243 # The options database must include medfont before this method is invoked.
244 #
245 ErrorWindow public init text {
246 set w .dialog
247 $self next $w
248 catch "destroy $w"
249 #FIXME
250 global V
251 set applname [Application name]
252 if { $applname == "" } {
253 set applname "mash shell"
254 }
255 $self create-window $w "$applname error"
256
257 label $w.label -text "$applname: $text" -font [$self get_option medfont] \
258 -borderwidth 2 -relief groove
259 button $w.button -text OK -command "$self destroy" \
260 -font [$self get_option medfont]
261 pack $w.label -expand 1 -fill x -ipadx 4 -ipady 4
262 pack $w.button -pady 4
263
264 wm withdraw $w
265 update idletasks
266 set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
267 - [winfo vrootx [winfo parent $w]]]
268 set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
269 - [winfo vrooty [winfo parent $w]]]
270 wm geom $w +$x+$y
271 wm deiconify $w
272
273 bind $w <Enter> "focus $w"
274 tkwait window .dialog
275 }
276
277 #
278 Class CheckButton
279
280 #
281 CheckButton public init { w args } {
282 $self instvar var_ path_
283 set path_ $w
284 set var_ [TclObject getid]
285 eval checkbutton $w -variable $var_ $args
286 }
287
288 #
289 CheckButton instproc get_val {} {
290 $self instvar var_
291 global $var_
292 return [set $var_]
293 }
294
295 #
296 CheckButton instproc set_val v {
297 $self instvar var_
298 global $var_
299 set $var_ $v
300 }
301
302 # backward compat
303 CheckButton instproc set-val v { $self set_val $v }
304 # backward compat
305 CheckButton instproc get-val {} { $self get_val }
306
307 #
308 # pass undefined methods to tk widget
309 #
310 CheckButton instproc unknown args {
311 $self instvar path_
312 eval $path_ $args
313 }
314
315
316 #
317 Class RadioButtonsObj
318
319 #
320 RadioButtonsObj public init { w labelsList args } {
321 $self instvar var_ path_ numButtons_
322 set path_ $w
323 set var_ [TclObject getid]
324 set c 0
325 #set labelsList [lindex $labelsList 0]
326 foreach i $labelsList {
327 eval radiobutton $w.rb$c -variable $var_ $args
328 $w.rb$c configure -text [list $i]
329 $w.rb$c configure -value [list $i]
330 pack $w.rb$c -in $w -anchor w
331 incr c
332 }
333 set numButtons_ $c
334 }
335
336 #
337 RadioButtonsObj public get_val {} {
338 $self instvar var_
339 global $var_
340 return [set $var_]
341 }
342
343 #
344 RadioButtonsObj public set_val {v} {
345 $self instvar var_
346 global $var_
347 set $var_ $v
348 }
349
350 #
351 RadioButtonsObj private unknown args {
352 $self instvar path_ numButtons_
353 for {set i 0} {$i < $numButtons_} {incr i} {
354 eval $path_.rb$i $args
355 }
356 }
357
358 #
359 Class ScaleObj
360
361 #
362 ScaleObj public init { w args } {
363 $self instvar var_ path_
364 set path_ $w
365 set var_ [TclObject getid]
366 eval scale $w -variable $var_ $args
367 }
368
369 #
370 ScaleObj public get_val {} {
371 $self instvar var_
372 global $var_
373 return [set $var_]
374 }
375
376 #
377 ScaleObj public set_val {v} {
378 $self instvar var_
379 global $var_
380 set $var_ $v
381 }
382
383 #
384 ScaleObj private unknown args {
385 $self instvar path_
386 eval $path_ $args
387 }
388
389 #
390 Class EntryObj
391
392 #
393 EntryObj public init { w args } {
394 $self instvar var_ path_
395 set path_ $w
396 set var_ [TclObject getid]
397 eval entry $w -textvariable $var_ $args
398 }
399
400 #
401 EntryObj public get_val {} {
402 $self instvar var_
403 global $var_
404 return [set $var_]
405 }
406
407 #
408 EntryObj private unknown args {
409 $self instvar path_
410 eval $path_ $args
411 }
412
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.