src/clfswm-configuration.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Configuration definitions and Menu generation
   6 ;;;
   7 ;;; --------------------------------------------------------------------------
   8 ;;;
   9 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
  10 ;;;
  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.
  15 ;;;
  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.
  20 ;;;
  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.
  24 ;;;
  25 ;;; --------------------------------------------------------------------------
  26
  27 (in-package :clfswm)
  28
  29
  30 (defun find-configuration-variables ()
  31   (let ((all-groups nil)
  32         (all-variables 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)))
  38
  39
  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))
  44           ((consp value)
  45            (format nil "(quote ~S)" value))
  46           ((symbolp value)
  47            (format nil "'~S" value))
  48           ((functionp value)
  49            (format nil "'~S" (find-symbol-function value)))
  50           ((xlib:color-p value)
  51            (format nil "(->color #x~X)" (color->rgb value)))
  52           (t (format nil "~S" value)))))
  53
  54
  55
  56 ;;; Configuration variables save
  57
  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))))
  62
  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"))))
  67
  68
  69 (defun copy-previous-conf-file-begin (stream-in stream-out)
  70   (loop for line = (read-line stream-in nil nil)
  71      while line
  72      until (zerop (or (search ";;; ### Internal variables definitions" line) -1))
  73      do (format stream-out "~A~%" line)))
  74
  75 (defun copy-previous-conf-file-end (stream-in stream-out)
  76   (loop for line = (read-line stream-in nil nil)
  77      while line
  78      until (zerop (or (search ";;; ### End of internal variables definitions" line) -1)))
  79   (loop for line = (read-line stream-in nil nil)
  80      while line
  81      do (format stream-out "~A~%" line)))
  82
  83
  84
  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 ### ;;;~%")))
 103
 104
 105
 106
 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)
 118     nil))
 119
 120
 121 ;;; Configuration menu definition
 122
 123 (defun group->menu (group)
 124   (intern (string-upcase
 125            (format nil "conf-~A" (substitute #\- #\Space group)))
 126           :clfswm))
 127
 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))
 131                  result
 132                  (if (string-equal
 133                       (query-string
 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))
 136                        "no")
 137                       "yes")
 138                      result
 139                      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 (equal return :Return)
 145              (warn-wrong-type result-val original-val)
 146              original-val)))))
 147
 148
 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))
 156     symbol))
 157
 158
 159 (defun create-configuration-menu ()
 160   "Configuration menu"
 161   (multiple-value-bind (all-groups all-variables)
 162       (find-configuration-variables)
 163     (loop for group in all-groups
 164        for i from 0
 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
 168                with j = -1
 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))
 173
 174
 175
 176
 177
 178