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 (defun remove-config-group (documentation)
  55   (let ((pos (position #\: documentation)))
  56     (if pos
  57         (string-trim " " (subseq documentation (1+ pos)))
  58         documentation)))
  59
  60
  61
  62 ;;; Configuration variables save
  63
  64 (defun find-symbol-function (function)
  65   (with-all-internal-symbols (symbol :clfswm)
  66     (when (and (fboundp symbol) (equal (symbol-function symbol) function))
  67       (return-from find-symbol-function symbol))))
  68
  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"))))
  73
  74
  75 (defun copy-previous-conf-file-begin (stream-in stream-out)
  76   (loop for line = (read-line stream-in nil nil)
  77      while line
  78      until (zerop (or (search ";;; ### Internal variables definitions" line) -1))
  79      do (format stream-out "~A~%" line)))
  80
  81 (defun copy-previous-conf-file-end (stream-in stream-out)
  82   (loop for line = (read-line stream-in nil nil)
  83      while line
  84      until (zerop (or (search ";;; ### End of internal variables definitions" line) -1)))
  85   (loop for line = (read-line stream-in nil nil)
  86      while line
  87      do (format stream-out "~A~%" line)))
  88
  89
  90
  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:~%" group)
 102       (dolist (var all-variables)
 103         (when (string-equal (second var) group)
 104           (format stream "  ~A ~A~%" (first var)
 105                   (escape-conf-value (first var)))))
 106       (format stream "~%"))
 107     (format stream ")~%")
 108     (format stream ";;; ### End of internal variables definitions ### ;;;~%")))
 109
 110
 111
 112
 113 (defun save-configuration-variables ()
 114   "Save all configuration variables in clfswmrc"
 115   (let ((conffile (conf-file-name))
 116         (tempfile (temp-conf-file-name)))
 117     (with-open-file (stream-in conffile :direction :input :if-does-not-exist :create)
 118       (with-open-file (stream-out tempfile :direction :output :if-exists :supersede)
 119         (copy-previous-conf-file-begin stream-in stream-out)
 120         (save-variables-in-conf-file stream-out)
 121         (copy-previous-conf-file-end stream-in stream-out)))
 122     (delete-file conffile)
 123     (rename-file tempfile conffile)
 124     nil))
 125
 126
 127 ;;; Configuration menu definition
 128
 129 (defun group->menu (group)
 130   (intern (string-upcase
 131            (format nil "conf-~A" (substitute #\- #\Space group)))
 132           :clfswm))
 133
 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))
 137                  result
 138                  (if (string-equal
 139                       (query-string
 140                        (format nil "~S and ~S are not of the same type (~A and ~A). Do you really want to use this value? (yes/no)"
 141                                result original (type-of result) (type-of original))
 142                        "no")
 143                       "yes")
 144                      result
 145                      original))))
 146      (multiple-value-bind (result return)
 147          (query-string (format nil "Configure ~A - ~A" string
 148                                (remove-config-group (documentation var 'variable)))
 149                        original)
 150        (let ((result-val (ignore-errors (eval (read-from-string result))))
 151              (original-val (ignore-errors (eval (read-from-string original)))))
 152          (if (equal return :Return)
 153              (warn-wrong-type result-val original-val)
 154              original-val)))))
 155
 156
 157 (defun create-conf-function (var)
 158   (let* ((string (remove #\* (format nil "~A" var)))
 159          (symbol (intern (format nil "CONFIGURE-~A" string) :clfswm)))
 160     (setf (symbol-function symbol) (lambda ()
 161                                      (setf (symbol-value var) (query-conf-value var string (escape-conf-value var)))
 162                                      (open-menu (find-menu 'configuration-menu)))
 163           (documentation symbol 'function) (format nil "Configure ~A" string))
 164     symbol))
 165
 166
 167 (defun create-configuration-menu (&key clear)
 168   "Configuration menu"
 169   (when clear
 170     (clear-sub-menu 'main 'configuration-menu))
 171   (multiple-value-bind (all-groups all-variables)
 172       (find-configuration-variables)
 173     (loop for group in all-groups
 174        for i from 0
 175        do (let ((menu (group->menu group)))
 176             (add-sub-menu 'configuration-menu (number->char i) menu group)
 177             (loop for var in all-variables
 178                with j = -1
 179                do (when (equal (second var) group)
 180                     (add-menu-key menu (number->char (incf j))
 181                                   (create-conf-function (first var))))))))
 182   (add-menu-key 'configuration-menu "F2" 'save-configuration-variables))
 183
 184
 185
 186 ;;; Default documentation string utility
 187 (defun remove-configuration-default-value (symbol)
 188   (let* ((doc (documentation symbol 'variable))
 189          (length (length doc)))
 190     (when (and (plusp length) (char= (char doc (1- length)) #\)))
 191       (let ((pos (position #\( doc :from-end t)))
 192         (when pos
 193           (setf (documentation symbol 'variable)
 194                 (string-trim " " (subseq doc 0 pos))))))))
 195
 196 (defun change-configuration-default-value (symbol)
 197   (remove-configuration-default-value symbol)
 198   (setf (documentation symbol 'variable)
 199         (format nil "~A (~A)" (documentation symbol 'variable)
 200                 (escape-conf-value symbol))))
 201
 202 (defun add-all-configuration-default-value ()
 203   (with-all-internal-symbols (symbol :clfswm)
 204     (when (is-config-p symbol)
 205       (change-configuration-default-value symbol))))
 206
 207
 208
 209