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
)))))
56 ;;; Configuration variables save
58 (defun find-symbol-function (function)
59 (with-all-internal-symbols (symbol :clfswm
)
60 (when (and (fboundp symbol
) (equal (symbol-function symbol
) function
))
61 (return-from find-symbol-function symbol
))))
63 (defun temp-conf-file-name ()
64 (let ((name (conf-file-name)))
65 (make-pathname :directory
(pathname-directory name
)
66 :name
(concatenate 'string
(pathname-name name
) "-tmp"))))
69 (defun copy-previous-conf-file-begin (stream-in stream-out
)
70 (loop for line
= (read-line stream-in nil nil
)
72 until
(zerop (or (search ";;; ### Internal variables definitions" line
) -
1))
73 do
(format stream-out
"~A~%" line
)))
75 (defun copy-previous-conf-file-end (stream-in stream-out
)
76 (loop for line
= (read-line stream-in nil nil
)
78 until
(zerop (or (search ";;; ### End of internal variables definitions" line
) -
1)))
79 (loop for line
= (read-line stream-in nil nil
)
81 do
(format stream-out
"~A~%" line
)))
85 (defun save-variables-in-conf-file (stream)
86 (multiple-value-bind (all-groups all-variables
)
87 (find-configuration-variables)
88 (format stream
"~&;;; ### Internal variables definitions ### ;;;~%")
89 (format stream
";;; ### You can edit this part when clfswm is not running ### ;;;~%")
90 (format stream
";;; ### And you can remove this part to revert to the ### ;;;~%")
91 (format stream
";;; ### original configuration variables values. ### ;;;~%")
92 (format stream
"(in-package :clfswm)~2%")
93 (format stream
"(setf~%")
94 (dolist (group all-groups
)
95 (format stream
" ;; ~A:~%" group
)
96 (dolist (var all-variables
)
97 (when (string-equal (second var
) group
)
98 (format stream
" ~A ~A~%" (first var
)
99 (escape-conf-value (first var
)))))
100 (format stream
"~%"))
101 (format stream
")~%")
102 (format stream
";;; ### End of internal variables definitions ### ;;;~%")))
107 (defun save-configuration-variables ()
108 "Save all configuration variables in clfswmrc"
109 (let ((conffile (conf-file-name))
110 (tempfile (temp-conf-file-name)))
111 (with-open-file (stream-in conffile
:direction
:input
:if-does-not-exist
:create
)
112 (with-open-file (stream-out tempfile
:direction
:output
:if-exists
:supersede
)
113 (copy-previous-conf-file-begin stream-in stream-out
)
114 (save-variables-in-conf-file stream-out
)
115 (copy-previous-conf-file-end stream-in stream-out
)))
116 (delete-file conffile
)
117 (rename-file tempfile conffile
)
121 ;;; Configuration menu definition
123 (defun group->menu
(group)
124 (intern (string-upcase
125 (format nil
"conf-~A" (substitute #\-
#\Space group
)))
128 (defun query-conf-value (string original
)
129 (labels ((warn-wrong-type (result original
)
130 (if (equal (simple-type-of result
) (simple-type-of original
))
134 (format nil
"~S and ~S are not of the same type (~A and ~A). Do you really want to use this value? (yes/no)"
135 result original
(type-of result
) (type-of original
))
140 (multiple-value-bind (result return
)
141 (query-string (format nil
"Configure ~A" string
) original
)
142 (let ((result-val (ignore-errors (eval (read-from-string result
))))
143 (original-val (ignore-errors (eval (read-from-string original
)))))
144 (if (member return
'(:Return
:Complet
))
145 (warn-wrong-type result-val original-val
)
149 (defun create-conf-function (var)
150 (let* ((string (remove #\
* (format nil
"~A" var
)))
151 (symbol (intern (format nil
"CONFIGURE-~A" string
) :clfswm
)))
152 (setf (symbol-function symbol
) (lambda ()
153 (setf (symbol-value var
) (query-conf-value string
(escape-conf-value var
)))
154 (open-menu (find-menu 'configuration-menu
)))
155 (documentation symbol
'function
) (format nil
"Configure ~A" string
))
159 (defun create-configuration-menu ()
161 (multiple-value-bind (all-groups all-variables
)
162 (find-configuration-variables)
163 (loop for group in all-groups
165 do
(let ((menu (group->menu group
)))
166 (add-sub-menu 'configuration-menu
(number->char i
) menu group
)
167 (loop for var in all-variables
169 do
(when (equal (second var
) group
)
170 (add-menu-key menu
(number->char
(incf j
))
171 (create-conf-function (first var
))))))))
172 (add-menu-key 'configuration-menu
"F2" 'save-configuration-variables
))