1 # ui-preferences.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 2001-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 proc Pref_Init {userDefaults appDefaults} {
32 global pref
33
34 set pref(uid) 0
35 set pref(userDefaults) $userDefaults
36 set pref(appDefaults) $appDefaults
37
38 PrefReadFile $appDefaults startup
39 if [file exists $userDefaults] {
40 PrefReadFile $userDefaults user
41 }
42 }
43
44 proc PrefReadFile {basename level} {
45 if [catch {option readfile $basename $level} err] {
46 puts stderr "Error in $basename: $err"
47 }
48 }
49
50 proc PrefVar {item} {lindex $item 0}
51 proc PrefRes {item} {lindex $item 1}
52 proc PrefDefault {item} {lindex $item 2}
53 proc PrefComment {item} {lindex $item 3}
54 proc PrefHelp {item} {lindex $item 4}
55
56 proc Pref_Add {prefs} {
57 global pref
58 append pref(items) $prefs " "
59 foreach item $prefs {
60 set varName [PrefVar $item]
61 set resName [PrefRes $item]
62 set value [PrefValue $varName $resName]
63 if {$value == {}} {
64 set default [PrefDefault $item]
65 switch -regexp -- $default {
66 ^CHOICE {
67 PrefValueSet $varName [lindex $default 1]
68 }
69 ^OFF {
70 PrefValueSet $varName 0
71 }
72 ^ON {
73 PrefValueSet $varName 1
74 }
75 default {
76 PrefValueSet $varName $default
77 }
78 }
79 }
80 }
81 }
82
83 proc PrefValue {varName res} {
84 upvar #0 $varName var
85 if [info exists var] {
86 return $var
87 }
88 set var [option get . $res {}]
89 }
90
91 proc PrefValueSet {varName value} {
92 upvar #0 $varName var
93 set var $value
94 }
95
96 proc Pref_Dialog {} {
97 global pref
98 if [catch {toplevel .pref}] {
99 raise .pref
100 } else {
101 wm title .pref "Preferences"
102 set buttons [frame .pref.but -bd 5]
103 pack .pref.but -side top -fill x
104 button $buttons.quit -text Dismiss -command {PrefDismiss}
105 button $buttons.save -text Save -command {PrefSave}
106 button $buttons.reset -text Reset -command {PrefReset; PrefDismiss}
107 label $buttons.label -text "Click labels for info on each item"
108 pack $buttons.label -side left -fill x
109 pack $buttons.quit $buttons.save $buttons.reset -side right -padx 4
110
111 frame .pref.b -borderwidth 2 -relief raised
112 pack .pref.b -fill both
113 set body [frame .pref.b.b -bd 10]
114 pack .pref.b.b -fill both
115
116 set maxWidth 0
117 foreach item $pref(items) {
118 set len [string length [PrefComment $item]]
119 if {$len > $maxWidth} {
120 set maxWidth $len
121 }
122 }
123
124 set pref(uid) 0
125 foreach item $pref(items) {
126 PrefDialogItem $body $item $maxWidth
127 }
128 }
129 }
130
131 proc PrefDialogItem {frame item width} {
132 global pref
133 incr pref(uid)
134 set f [frame $frame.p$pref(uid) -borderwidth 2]
135 pack $f -fill x
136 label $f.label -text [PrefComment $item] -width $width
137 bind $f.label <1> [list PrefItemHelp %X %Y [PrefHelp $item]]
138 pack $f.label -side left
139 set default [PrefDefault $item]
140 if {[regexp "^CHOICE " $default]} {
141 foreach choice [lreplace $default 0 0] {
142 incr pref(uid)
143 radiobutton $f.c$pref(uid) -text $choice \
144 -variable [PrefVar $item] -value $choice
145 pack $f.c$pref(uid) -side left
146 }
147 } else {
148 if {$default == "OFF" || $default == "ON"} {
149 set varName [PrefVar $item]
150 checkbutton $f.check -variable $varName \
151 -command [list PrefFixupBoolean $f.check $varName]
152 PrefFixupBoolean $f.check $varName
153 pack $f.check -side left
154 } else {
155 entry $f.entry -width 10 -relief sunken
156 pack $f.entry -side left -fill x -expand true
157 set pref(entry,[PrefVar $item]) $f.entry
158 set varName [PrefVar $item]
159 $f.entry insert 0 [uplevel #0 [list set $varName]]
160 bind $f.entry <Return> "PrefEntrySet %W $varName"
161 }
162 }
163 }
164
165 proc PrefFixUpBoolean {check varname} {
166 upvar #0 $varname var
167 #Update the checkbutton text each time it changes
168 if {$var} {
169 $check config -text On
170 } else {
171 $check config -text Off
172 }
173 }
174
175 proc PrefEntrySet {entry varName} {
176 PrefValueSet $varName [$entry get]
177 }
178
179 proc PrefItemHelp {x y text} {
180 catch {destroy .prefitemhelp}
181 if {$text == {}} {
182 return
183 }
184 set self [toplevel .prefitemhelp -class Itemhelp]
185 wm title $self "Item help"
186 wm geometry $self +[expr $x+10]+[expr $y+10]
187 wm transient $self .pref
188 message $self.msg -text $text -aspect 1500
189 pack $self.msg
190 bind $self.msg <1> {PrefNukeItemHelp .prefitemhelp}
191 .pref.but.label configure -text "Click on pop-up or another label"
192 }
193
194 proc PrefNukeItemHelp {t} {
195 .pref.but.label configure -text "Click labels for info on each item"
196 destroy $t
197 }
198
199 proc PrefSave {} {
200 global pref
201 if [catch {
202 set old [open $pref(userDefaults) r]
203 set oldValues [split [read $old] \n]
204 close $old
205 }] {
206 set oldValues {}
207 }
208 if [catch {open $pref(userDefaults).new w} out] {
209 .pref.but.label configure -text \
210 "Cannot save in $pref(userDefaults).new: $out"
211 return
212 }
213 foreach line $oldValues {
214 if {$line == \
215 "!!! Lines below here automatically added"} {
216
217 break
218 } else {
219 puts $out $line
220 }
221 }
222 puts $out "!!! Lines below here automatically added"
223 puts $out "!!! [exec date]"
224 puts $out "!!! Do not edit below here"
225 foreach item $pref(items) {
226 set varName [PrefVar $item]
227 set resName [PrefRes $item]
228 if [info exists pref(entry,$varName)] {
229 PrefEntrySet $pref(entry,$varName) $varName
230 }
231 set value [PrefValue $varName $resName]
232 puts $out [format "%s\t%s" *${resName}: $value]
233 }
234 close $out
235 set new [glob $pref(userDefaults).new]
236 set old [file root $new]
237 if [catch {file rename -force $new $old} err] {
238 puts stderr "Cannot install $new: $err"
239 return
240 }
241 PrefDismiss
242 }
243
244 proc PrefReset {} {
245 global pref
246 # Re-read user defaults
247 option clear
248 PrefReadFile $pref(appDefaults) startup
249 PrefReadFile $pref(userDefaults) user
250 # Clear variables
251 set items $pref(items)
252 set pref(items) {}
253 foreach item $items {
254 uplevel #0 [list unset [PrefVar $item]]
255 }
256 # Restore values
257 Pref_Add $items
258 }
259
260
261 proc PrefDismiss {} {
262 destroy .pref
263 catch {destroy .prefitemhelp}
264 }
265
266
267
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.