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 (defun find-configuration-variables ()
  30   (let ((all-groups nil)
  31         (all-variables nil))
  32     (maphash (lambda (key val)
  33                (pushnew  (configvar-group val) all-groups :test #'string-equal)
  34                (push (list key (configvar-group val)) all-variables))
  35              *config-var-table*)
  36     (values all-groups all-variables)))
  37
  38
  39 (defun find-symbol-function (function)
  40   (with-all-internal-symbols (symbol :clfswm)
  41     (when (and (fboundp symbol) (equal (symbol-function symbol) function))
  42       (return-from find-symbol-function symbol))))
  43
  44 (defun escape-conf-value (value)
  45   (cond ((or (equal value t) (equal value nil))
  46          (format nil "~S" value))
  47         ((consp value)
  48          (format nil "(quote ~S)" value))
  49         ((symbolp value)
  50          (format nil "'~S" value))
  51         ((functionp value)
  52          (format nil "'~S" (find-symbol-function value)))
  53         ((xlib:color-p value)
  54          (format nil "(->color #x~X)" (color->rgb value)))
  55         (t (format nil "~S" value))))
  56
  57 (defun escape-conf-symbol-value (symbol)
  58   (let ((value (symbol-value symbol)))
  59     (escape-conf-value value)))
  60
  61 (defun get-config-value (value)
  62   (ignore-errors (eval (read-from-string value))))
  63
  64 (defun reset-config-to-default-value (symbol)
  65   (setf (symbol-value symbol) (config-default-value symbol)))
  66
  67
  68 ;;; Save configuration variables part
  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:~%" (config-group->string group))
 102       (dolist (var all-variables)
 103         (unless (equal (escape-conf-symbol-value (first var))
 104                        (escape-conf-value (config-default-value (first var))))
 105           (when (string-equal (second var) group)
 106             (format stream "  ~A ~A~%" (first var)
 107                     (escape-conf-symbol-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 (format nil "conf-~A" group)) :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 (query-yes-or-no "~A and ~A are not of the same type (~A and ~A). Do you really want to use this value?"
 139                                       (escape-conf-value result) (escape-conf-value original)
 140                                       (type-of result) (type-of original))
 141                      result
 142                      original)))
 143            (ask-set-default-value (original-val)
 144              (let ((default (config-default-value var)))
 145                (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original (escape-conf-value default))
 146                    default
 147                    original-val))))
 148     (multiple-value-bind (result return)
 149         (query-string (format nil "Configure ~A - ~A (blank=Default: ~A)" string
 150                               (documentation var 'variable)
 151                               (escape-conf-value (config-default-value var)))
 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-symbol-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 (config-group->string 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 (defun reset-all-config-variables ()
 193   "Reset all configuration variables to there default values"
 194   (when (query-yes-or-no "Do you really want to reset all values to there default?")
 195     (maphash (lambda (key val)
 196                (declare (ignore val))
 197                (reset-config-to-default-value key))
 198              *config-var-table*))
 199   (open-menu (find-menu 'configuration-menu)))
 200