1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Configuration definitions and Menu generation
7 ;;; --------------------------------------------------------------------------
9 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
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 ;;; --------------------------------------------------------------------------
29 (defun find-configuration-variables ()
30 (let ((all-groups nil
)
32 (maphash (lambda (key val
)
33 (pushnew (configvar-group val
) all-groups
:test
#'string-equal
)
34 (push (list key
(configvar-group val
)) all-variables
))
36 (values all-groups all-variables
)))
39 (defun find-symbol-function (function)
40 (with-all-internal-symbols (symbol :clfswm
)
41 (when (and (fboundp symbol
) (equal (symbol-function symbol
) function
))
42 (return-from find-symbol-function symbol
))))
44 (defun escape-conf-value (value)
45 (cond ((or (equal value t
) (equal value nil
))
46 (format nil
"~S" value
))
48 (format nil
"(quote ~S)" value
))
50 (format nil
"'~S" value
))
52 (format nil
"'~S" (find-symbol-function value
)))
54 (format nil
"(->color #x~X)" (color->rgb value
)))
55 (t (format nil
"~S" value
))))
57 (defun escape-conf-symbol-value (symbol)
58 (let ((value (symbol-value symbol
)))
59 (escape-conf-value value
)))
61 (defun get-config-value (value)
62 (ignore-errors (eval (read-from-string value
))))
64 (defun reset-config-to-default-value (symbol)
65 (setf (symbol-value symbol
) (config-default-value symbol
)))
68 ;;; Save configuration variables part
69 (defun temp-conf-file-name ()
70 (let ((name (conf-file-name)))
71 (make-pathname :directory
(pathname-directory name
)
72 :name
(concatenate 'string
(pathname-name name
) "-tmp"))))
75 (defun copy-previous-conf-file-begin (stream-in stream-out
)
76 (loop for line
= (read-line stream-in nil nil
)
78 until
(zerop (or (search ";;; ### Internal variables definitions" line
) -
1))
79 do
(format stream-out
"~A~%" line
)))
81 (defun copy-previous-conf-file-end (stream-in stream-out
)
82 (loop for line
= (read-line stream-in nil nil
)
84 until
(zerop (or (search ";;; ### End of internal variables definitions" line
) -
1)))
85 (loop for line
= (read-line stream-in nil nil
)
87 do
(format stream-out
"~A~%" line
)))
91 (defun save-variables-in-conf-file (stream)
92 (multiple-value-bind (all-groups all-variables
)
93 (find-configuration-variables)
94 (format stream
"~&;;; ### Internal variables definitions ### ;;;~%")
95 (format stream
";;; ### You can edit this part when clfswm is not running ### ;;;~%")
96 (format stream
";;; ### And you can remove this part to revert to the ### ;;;~%")
97 (format stream
";;; ### original configuration variables values. ### ;;;~%")
98 (format stream
"(in-package :clfswm)~2%")
99 (format stream
"(setf~%")
100 (dolist (group all-groups
)
101 (format stream
" ;; ~A:~%" (config-group->string group
))
102 (dolist (var all-variables
)
103 (unless (equal (escape-conf-symbol-value (first var
))
104 (escape-conf-value (config-default-value (first var
))))
105 (when (string-equal (second var
) group
)
106 (format stream
" ~A ~A~%" (first var
)
107 (escape-conf-symbol-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 (format nil
"conf-~A" group
)) :clfswm
))
134 (defun query-conf-value (var string original
)
135 (labels ((warn-wrong-type (result original
)
136 (if (equal (simple-type-of result
) (simple-type-of original
))
138 (if (query-yes-or-no "~A and ~A are not of the same type (~A and ~A). Do you really want to use this value?"
139 (escape-conf-value result
) (escape-conf-value original
)
140 (type-of result
) (type-of original
))
143 (ask-set-default-value (original-val)
144 (let ((default (config-default-value var
)))
145 (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original
(escape-conf-value default
))
148 (multiple-value-bind (result return
)
149 (query-string (format nil
"Configure ~A - ~A (blank=Default: ~A)" string
150 (documentation var
'variable
)
151 (escape-conf-value (config-default-value var
)))
153 (let ((original-val (get-config-value original
)))
154 (if (equal return
:Return
)
155 (if (string= result
"")
156 (ask-set-default-value original-val
)
157 (let ((result-val (get-config-value result
)))
158 (warn-wrong-type result-val original-val
)))
162 (defun create-conf-function (var)
163 (let* ((string (remove #\
* (format nil
"~A" var
)))
164 (symbol (intern (format nil
"CONFIGURE-~A" string
) :clfswm
)))
165 (setf (symbol-function symbol
) (lambda ()
166 (setf (symbol-value var
) (query-conf-value var string
(escape-conf-symbol-value var
)))
167 (open-menu (find-menu 'configuration-menu
)))
168 (documentation symbol
'function
) (format nil
"Configure ~A" string
))
172 (defun create-configuration-menu (&key clear
)
175 (clear-sub-menu 'main
'configuration-menu
))
176 (multiple-value-bind (all-groups all-variables
)
177 (find-configuration-variables)
178 (loop for group in all-groups
180 do
(let ((menu (group->menu group
)))
181 (add-sub-menu 'configuration-menu
(number->char i
) menu
(config-group->string group
))
182 (loop for var in all-variables
184 do
(when (equal (second var
) group
)
185 (add-menu-key menu
(number->char
(incf j
))
186 (create-conf-function (first var
))))))))
187 (add-menu-key 'configuration-menu
"F2" 'save-configuration-variables
)
188 (add-menu-key 'configuration-menu
"F3" 'reset-all-config-variables
))
192 (defun reset-all-config-variables ()
193 "Reset all configuration variables to their default values"
194 (when (query-yes-or-no "Do you really want to reset all values to their default?")
195 (maphash (lambda (key val
)
196 (declare (ignore val
))
197 (reset-config-to-default-value key
))
199 (open-menu (find-menu 'configuration-menu
)))