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 (defun get-config-value (value)
  61   (ignore-errors (eval (read-from-string value))))
  62
  63
  64 ;;; Configuration variables save
  65
  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))))
  70
  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"))))
  75
  76
  77 (defun copy-previous-conf-file-begin (stream-in stream-out)
  78   (loop for line = (read-line stream-in nil nil)
  79      while line
  80      until (zerop (or (search ";;; ### Internal variables definitions" line) -1))
  81      do (format stream-out "~A~%" line)))
  82
  83 (defun copy-previous-conf-file-end (stream-in stream-out)
  84   (loop for line = (read-line stream-in nil nil)
  85      while line
  86      until (zerop (or (search ";;; ### End of internal variables definitions" line) -1)))
  87   (loop for line = (read-line stream-in nil nil)
  88      while line
  89      do (format stream-out "~A~%" line)))
  90
  91
  92
  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 ### ;;;~%")))
 111
 112
 113
 114
 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)
 126     nil))
 127
 128
 129 ;;; Configuration menu definition
 130
 131 (defun group->menu (group)
 132   (intern (string-upcase
 133            (format nil "conf-~A" (substitute #\- #\Space group)))
 134           :clfswm))
 135
 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))
 139                  result
 140                  (if (query-yes-or-no "~S and ~S are not of the same type (~A and ~A). Do you really want to use this value?"
 141                                       result original (type-of result) (type-of original))
 142                      result
 143                      original)))
 144            (ask-set-default-value (original-val)
 145              (let ((default (extract-config-default-value var)))
 146                (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original default)
 147                    (get-config-value default)
 148                    original-val))))
 149     (multiple-value-bind (result return)
 150         (query-string (format nil "Configure ~A - ~A" string
 151                               (remove-config-group (documentation var 'variable)))
 152                       original)
 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)))
 159             original-val)))))
 160
 161
 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-value var)))
 167                                      (open-menu (find-menu 'configuration-menu)))
 168           (documentation symbol 'function) (format nil "Configure ~A" string))
 169     symbol))
 170
 171
 172 (defun create-configuration-menu (&key clear)
 173   "Configuration menu"
 174   (when 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
 179        for i from 0
 180        do (let ((menu (group->menu group)))
 181             (add-sub-menu 'configuration-menu (number->char i) menu group)
 182             (loop for var in all-variables
 183                with j = -1
 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))
 189
 190
 191
 192 ;;; Default documentation string utility
 193 (defparameter *config-default-string* "(blank=Default: ")
 194
 195 (defmacro with-config-default-value-position ((symbol doc pos1 pos2) &body body)
 196   `(let* ((,doc (documentation ,symbol 'variable))
 197           (length (length ,doc))
 198           (,pos2 (and (plusp length) (1- length))))
 199      (when (and ,pos2 (char= (char ,doc ,pos2) #\)))
 200        (let ((,pos1 (awhen (search *config-default-string* ,doc :from-end t)
 201                       (+ it (length *config-default-string*)))))
 202          (when ,pos1
 203            ,@body)))))
 204
 205 (defun remove-config-default-value (symbol)
 206   (with-config-default-value-position (symbol doc pos1 pos2)
 207     (setf (documentation symbol 'variable)
 208           (string-trim " " (subseq doc 0 pos1)))))
 209
 210 (defun extract-config-default-value (symbol)
 211   (with-config-default-value-position (symbol doc pos1 pos2)
 212     (string-trim " " (subseq doc pos1 pos2))))
 213
 214
 215 (defun change-config-default-value (symbol)
 216   (remove-config-default-value symbol)
 217   (setf (documentation symbol 'variable)
 218         (format nil "~A ~A~A)" (documentation symbol 'variable)
 219                 *config-default-string*
 220                 (escape-conf-value symbol))))
 221
 222 (defun reset-config-to-default-value (symbol)
 223   (let ((default (extract-config-default-value symbol)))
 224     (setf (symbol-value symbol) (get-config-value default))))
 225
 226
 227 (defun add-all-config-default-value ()
 228   (with-all-internal-symbols (symbol :clfswm)
 229     (when (is-config-p symbol)
 230       (change-config-default-value symbol))))
 231
 232
 233 (defun reset-all-config-variables ()
 234   "Reset all configuration variables to there default values"
 235   (when (query-yes-or-no "Do you really want to reset all values to there default?")
 236     (with-all-internal-symbols (symbol :clfswm)
 237       (when (is-config-p symbol)
 238         (reset-config-to-default-value symbol))))
 239   (open-menu (find-menu 'configuration-menu)))
 240