1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Configuration definitions and Menu generation
7 ;;; --------------------------------------------------------------------------
9 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
11 ;;; This program is free software; you can redistribute it and/or modify
12 ;;; it under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation; either version 3 of the License, or
14 ;;; (at your option) any later version.
16 ;;; This program is distributed in the hope that it will be useful,
17 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU General Public License for more details.
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with this program; if not, write to the Free Software
23 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25 ;;; --------------------------------------------------------------------------
30 (defun find-configuration-variables ()
31 (let ((all-groups nil
)
33 (with-all-internal-symbols (symbol :clfswm
)
34 (when (is-config-p symbol
)
35 (pushnew (config-group symbol
) all-groups
:test
#'string-equal
)
36 (push (list symbol
(config-group symbol
)) all-variables
)))
37 (values all-groups all-variables
)))
40 (defun escape-conf-value (value)
41 (let ((value (symbol-value value
)))
42 (cond ((or (equal value t
) (equal value nil
))
43 (format nil
"~S" value
))
45 (format nil
"(quote ~S)" value
))
47 (format nil
"'~S" value
))
49 (format nil
"'~S" (find-symbol-function value
)))
51 (format nil
"(->color #x~X)" (color->rgb value
)))
52 (t (format nil
"~S" value
)))))
54 (defun remove-config-group (documentation)
55 (let ((pos (position #\
: documentation
)))
57 (string-trim " " (subseq documentation
(1+ pos
)))
60 (defun get-config-value (value)
61 (ignore-errors (eval (read-from-string value
))))
64 ;;; Configuration variables save
66 (defun find-symbol-function (function)
67 (with-all-internal-symbols (symbol :clfswm
)
68 (when (and (fboundp symbol
) (equal (symbol-function symbol
) function
))
69 (return-from find-symbol-function symbol
))))
71 (defun temp-conf-file-name ()
72 (let ((name (conf-file-name)))
73 (make-pathname :directory
(pathname-directory name
)
74 :name
(concatenate 'string
(pathname-name name
) "-tmp"))))
77 (defun copy-previous-conf-file-begin (stream-in stream-out
)
78 (loop for line
= (read-line stream-in nil nil
)
80 until
(zerop (or (search ";;; ### Internal variables definitions" line
) -
1))
81 do
(format stream-out
"~A~%" line
)))
83 (defun copy-previous-conf-file-end (stream-in stream-out
)
84 (loop for line
= (read-line stream-in nil nil
)
86 until
(zerop (or (search ";;; ### End of internal variables definitions" line
) -
1)))
87 (loop for line
= (read-line stream-in nil nil
)
89 do
(format stream-out
"~A~%" line
)))
93 (defun save-variables-in-conf-file (stream)
94 (multiple-value-bind (all-groups all-variables
)
95 (find-configuration-variables)
96 (format stream
"~&;;; ### Internal variables definitions ### ;;;~%")
97 (format stream
";;; ### You can edit this part when clfswm is not running ### ;;;~%")
98 (format stream
";;; ### And you can remove this part to revert to the ### ;;;~%")
99 (format stream
";;; ### original configuration variables values. ### ;;;~%")
100 (format stream
"(in-package :clfswm)~2%")
101 (format stream
"(setf~%")
102 (dolist (group all-groups
)
103 (format stream
" ;; ~A:~%" group
)
104 (dolist (var all-variables
)
105 (when (string-equal (second var
) group
)
106 (format stream
" ~A ~A~%" (first var
)
107 (escape-conf-value (first var
)))))
108 (format stream
"~%"))
109 (format stream
")~%")
110 (format stream
";;; ### End of internal variables definitions ### ;;;~%")))
115 (defun save-configuration-variables ()
116 "Save all configuration variables in clfswmrc"
117 (let ((conffile (conf-file-name))
118 (tempfile (temp-conf-file-name)))
119 (with-open-file (stream-in conffile
:direction
:input
:if-does-not-exist
:create
)
120 (with-open-file (stream-out tempfile
:direction
:output
:if-exists
:supersede
)
121 (copy-previous-conf-file-begin stream-in stream-out
)
122 (save-variables-in-conf-file stream-out
)
123 (copy-previous-conf-file-end stream-in stream-out
)))
124 (delete-file conffile
)
125 (rename-file tempfile conffile
)
129 ;;; Configuration menu definition
131 (defun group->menu
(group)
132 (intern (string-upcase
133 (format nil
"conf-~A" (substitute #\-
#\Space group
)))
136 (defun query-conf-value (var string original
)
137 (labels ((warn-wrong-type (result original
)
138 (if (equal (simple-type-of result
) (simple-type-of original
))
142 (format nil
"~S and ~S are not of the same type (~A and ~A). Do you really want to use this value?"
143 result original
(type-of result
) (type-of original
))
148 (ask-set-default-value (original-val)
149 (let ((default (extract-config-default-value var
)))
151 (query-string (format nil
"Reset ~A from ~A to ~A?" var original default
)
154 (get-config-value default
)
156 (multiple-value-bind (result return
)
157 (query-string (format nil
"Configure ~A - ~A" string
158 (remove-config-group (documentation var
'variable
)))
160 (let ((original-val (get-config-value original
)))
161 (if (equal return
:Return
)
162 (if (string= result
"")
163 (ask-set-default-value original-val
)
164 (let ((result-val (get-config-value result
)))
165 (warn-wrong-type result-val original-val
)))
169 (defun create-conf-function (var)
170 (let* ((string (remove #\
* (format nil
"~A" var
)))
171 (symbol (intern (format nil
"CONFIGURE-~A" string
) :clfswm
)))
172 (setf (symbol-function symbol
) (lambda ()
173 (setf (symbol-value var
) (query-conf-value var string
(escape-conf-value var
)))
174 (open-menu (find-menu 'configuration-menu
)))
175 (documentation symbol
'function
) (format nil
"Configure ~A" string
))
179 (defun create-configuration-menu (&key clear
)
182 (clear-sub-menu 'main
'configuration-menu
))
183 (multiple-value-bind (all-groups all-variables
)
184 (find-configuration-variables)
185 (loop for group in all-groups
187 do
(let ((menu (group->menu group
)))
188 (add-sub-menu 'configuration-menu
(number->char i
) menu group
)
189 (loop for var in all-variables
191 do
(when (equal (second var
) group
)
192 (add-menu-key menu
(number->char
(incf j
))
193 (create-conf-function (first var
))))))))
194 (add-menu-key 'configuration-menu
"F2" 'save-configuration-variables
)
195 (add-menu-key 'configuration-menu
"F3" 'reset-all-config-variables
))
199 ;;; Default documentation string utility
200 (defparameter *config-default-string
* "(blank=Default: ")
202 (defmacro with-config-default-value-position
((symbol doc pos1 pos2
) &body body
)
203 `(let* ((,doc
(documentation ,symbol
'variable
))
204 (length (length ,doc
))
205 (,pos2
(and (plusp length
) (1- length
))))
206 (when (and ,pos2
(char= (char ,doc
,pos2
) #\
)))
207 (let ((,pos1
(awhen (search *config-default-string
* ,doc
:from-end t
)
208 (+ it
(length *config-default-string
*)))))
212 (defun remove-config-default-value (symbol)
213 (with-config-default-value-position (symbol doc pos1 pos2
)
214 (setf (documentation symbol
'variable
)
215 (string-trim " " (subseq doc
0 pos1
)))))
217 (defun extract-config-default-value (symbol)
218 (with-config-default-value-position (symbol doc pos1 pos2
)
219 (string-trim " " (subseq doc pos1 pos2
))))
222 (defun change-config-default-value (symbol)
223 (remove-config-default-value symbol
)
224 (setf (documentation symbol
'variable
)
225 (format nil
"~A ~A~A)" (documentation symbol
'variable
)
226 *config-default-string
*
227 (escape-conf-value symbol
))))
229 (defun reset-config-to-default-value (symbol)
230 (let ((default (extract-config-default-value symbol
)))
231 (setf (symbol-value symbol
) (get-config-value default
))))
234 (defun add-all-config-default-value ()
235 (with-all-internal-symbols (symbol :clfswm
)
236 (when (is-config-p symbol
)
237 (change-config-default-value symbol
))))
240 (defun reset-all-config-variables ()
241 "Reset all configuration variables to there default values"
244 "Do you really want to reset all values to there default?"
247 (with-all-internal-symbols (symbol :clfswm
)
248 (when (is-config-p symbol
)
249 (reset-config-to-default-value symbol
))))
250 (open-menu (find-menu 'configuration-menu
)))