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 (string-equal
 141                       (query-string
 142                        (format nil "~S and ~S are not of the same type (~A and ~A). Do you really want to use this value?"
 143                                result original (type-of result) (type-of original))
 144                        "" '("yes" "no"))
 145                       "yes")
 146                      result
 147                      original)))
 148            (ask-set-default-value (original-val)
 149              (let ((default (extract-config-default-value var)))
 150                (if (string-equal
 151                     (query-string (format nil "Reset ~A from ~A to ~A?" var original default)
 152                                   "" '("yes" "no"))
 153                     "yes")
 154                    (get-config-value default)
 155                    original-val))))
 156     (multiple-value-bind (result return)
 157         (query-string (format nil "Configure ~A - ~A" string
 158                               (remove-config-group (documentation var 'variable)))
 159                       original)
 160       (let ((original-val (get-config-value original)))
 161         (if (equal return :Return)
 162             (if (string= result "")
 163                 (ask-set-default-value original-val)
 164                 (let ((result-val (get-config-value result)))
 165                   (warn-wrong-type result-val original-val)))
 166             original-val)))))
 167
 168
 169 (defun create-conf-function (var)
 170   (let* ((string (remove #\* (format nil "~A" var)))
 171          (symbol (intern (format nil "CONFIGURE-~A" string) :clfswm)))
 172     (setf (symbol-function symbol) (lambda ()
 173                                      (setf (symbol-value var) (query-conf-value var string (escape-conf-value var)))
 174                                      (open-menu (find-menu 'configuration-menu)))
 175           (documentation symbol 'function) (format nil "Configure ~A" string))
 176     symbol))
 177
 178
 179 (defun create-configuration-menu (&key clear)
 180   "Configuration menu"
 181   (when clear
 182     (clear-sub-menu 'main 'configuration-menu))
 183   (multiple-value-bind (all-groups all-variables)
 184       (find-configuration-variables)
 185     (loop for group in all-groups
 186        for i from 0
 187        do (let ((menu (group->menu group)))
 188             (add-sub-menu 'configuration-menu (number->char i) menu group)
 189             (loop for var in all-variables
 190                with j = -1
 191                do (when (equal (second var) group)
 192                     (add-menu-key menu (number->char (incf j))
 193                                   (create-conf-function (first var))))))))
 194   (add-menu-key 'configuration-menu "F2" 'save-configuration-variables)
 195   (add-menu-key 'configuration-menu "F3" 'reset-all-config-variables))
 196
 197
 198
 199 ;;; Default documentation string utility
 200 (defparameter *config-default-string* "(blank=Default: ")
 201
 202 (defmacro with-config-default-value-position ((symbol doc pos1 pos2) &body body)
 203   `(let* ((,doc (documentation ,symbol 'variable))
 204           (length (length ,doc))
 205           (,pos2 (and (plusp length) (1- length))))
 206      (when (and ,pos2 (char= (char ,doc ,pos2) #\)))
 207        (let ((,pos1 (awhen (search *config-default-string* ,doc :from-end t)
 208                       (+ it (length *config-default-string*)))))
 209          (when ,pos1
 210            ,@body)))))
 211
 212 (defun remove-config-default-value (symbol)
 213   (with-config-default-value-position (symbol doc pos1 pos2)
 214     (setf (documentation symbol 'variable)
 215           (string-trim " " (subseq doc 0 pos1)))))
 216
 217 (defun extract-config-default-value (symbol)
 218   (with-config-default-value-position (symbol doc pos1 pos2)
 219     (string-trim " " (subseq doc pos1 pos2))))
 220
 221
 222 (defun change-config-default-value (symbol)
 223   (remove-config-default-value symbol)
 224   (setf (documentation symbol 'variable)
 225         (format nil "~A ~A~A)" (documentation symbol 'variable)
 226                 *config-default-string*
 227                 (escape-conf-value symbol))))
 228
 229 (defun reset-config-to-default-value (symbol)
 230   (let ((default (extract-config-default-value symbol)))
 231     (setf (symbol-value symbol) (get-config-value default))))
 232
 233
 234 (defun add-all-config-default-value ()
 235   (with-all-internal-symbols (symbol :clfswm)
 236     (when (is-config-p symbol)
 237       (change-config-default-value symbol))))
 238
 239
 240 (defun reset-all-config-variables ()
 241   "Reset all configuration variables to there default values"
 242   (when (string-equal
 243          (query-string
 244           "Do you really want to reset all values to there default?"
 245           "" '("yes" "no"))
 246          "yes")
 247     (with-all-internal-symbols (symbol :clfswm)
 248       (when (is-config-p symbol)
 249         (reset-config-to-default-value symbol))))
 250   (open-menu (find-menu 'configuration-menu)))
 251