[clfswm-cvs] r263 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sat Nov 14 22:38:11 UTC 2009
Author: pbrochard
Date: Sat Nov 14 17:38:10 2009
New Revision: 263
Log:
Configuration menu: New menu to configure all clfswm variables while clfswm is running.
Added:
clfswm/src/clfswm-configuration.lisp
Modified:
clfswm/ChangeLog
clfswm/clfswm.asd
clfswm/src/clfswm-util.lisp
clfswm/src/menu-def.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sat Nov 14 17:38:10 2009
@@ -1,3 +1,8 @@
+2009-11-14 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-configuration.lisp (create-configuration-menu): New
+ menu to configure all clfswm variables while clfswm is running.
+
2009-11-12 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-util.lisp (save-configuration-variables): New
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Sat Nov 14 17:38:10 2009
@@ -65,13 +65,16 @@
:depends-on ("clfswm" "clfswm-util" "clfswm-second-mode"))
(:file "clfswm-nw-hooks"
:depends-on ("package" "clfswm-util" "clfswm-info" "clfswm-layout" "menu-def"))
+ (:file "clfswm-configuration"
+ :depends-on ("package" "config" "clfswm-internal" "clfswm-util" "clfswm-query"
+ "clfswm-menu"))
+ (:file "menu-def"
+ :depends-on ("clfswm-menu" "clfswm-configuration" "clfswm" "clfswm-util" "clfswm-info"))
(:file "bindings"
:depends-on ("clfswm" "clfswm-internal" "clfswm-util" "clfswm-menu"))
(:file "bindings-second-mode"
:depends-on ("clfswm" "clfswm-util" "clfswm-query" "bindings" "clfswm-pack" "clfswm-menu" "menu-def"
- "clfswm-layout"))
- (:file "menu-def"
- :depends-on ("clfswm-menu" "clfswm" "clfswm-util" "clfswm-info"))))))
+ "clfswm-layout"))))))
Added: clfswm/src/clfswm-configuration.lisp
==============================================================================
--- (empty file)
+++ clfswm/src/clfswm-configuration.lisp Sat Nov 14 17:38:10 2009
@@ -0,0 +1,176 @@
+;;; --------------------------------------------------------------------------
+;;; CLFSWM - FullScreen Window Manager
+;;;
+;;; --------------------------------------------------------------------------
+;;; Documentation: Configuration definitions and Menu generation
+;;;
+;;; --------------------------------------------------------------------------
+;;;
+;;; (C) 2005 Philippe Brochard <hocwp at free.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+;;;
+;;; --------------------------------------------------------------------------
+
+(in-package :clfswm)
+
+
+(defun find-configuration-variables ()
+ (let ((all-groups nil)
+ (all-variables nil))
+ (with-all-internal-symbols (symbol :clfswm)
+ (when (is-config-p symbol)
+ (pushnew (config-group symbol) all-groups :test #'string-equal)
+ (push (list symbol (config-group symbol)) all-variables)))
+ (values all-groups all-variables)))
+
+
+(defun escape-conf-value (value)
+ (let ((value (symbol-value value)))
+ (cond ((or (equal value t) (equal value nil))
+ (format nil "~S" value))
+ ((consp value)
+ (format nil "(quote ~S)" value))
+ ((symbolp value)
+ (format nil "'~S" value))
+ ((functionp value)
+ (format nil "'~S" (find-symbol-function value)))
+ ((xlib:color-p value)
+ (format nil "(->color #x~X)" (color->rgb value)))
+ (t (format nil "~S" value)))))
+
+
+
+;;; Configuration variables save
+
+(defun find-symbol-function (function)
+ (with-all-internal-symbols (symbol :clfswm)
+ (when (and (fboundp symbol) (equal (symbol-function symbol) function))
+ (return-from find-symbol-function symbol))))
+
+(defun temp-conf-file-name ()
+ (let ((name (conf-file-name)))
+ (make-pathname :directory (pathname-directory name)
+ :name (concatenate 'string (pathname-name name) "-tmp"))))
+
+
+(defun copy-previous-conf-file-begin (stream-in stream-out)
+ (loop for line = (read-line stream-in nil nil)
+ while line
+ until (zerop (or (search ";;; ### Internal variables definitions" line) -1))
+ do (format stream-out "~A~%" line)))
+
+(defun copy-previous-conf-file-end (stream-in stream-out)
+ (loop for line = (read-line stream-in nil nil)
+ while line
+ until (zerop (or (search ";;; ### End of internal variables definitions" line) -1)))
+ (loop for line = (read-line stream-in nil nil)
+ while line
+ do (format stream-out "~A~%" line)))
+
+
+
+(defun save-variables-in-conf-file (stream)
+ (multiple-value-bind (all-groups all-variables)
+ (find-configuration-variables)
+ (format stream "~2&;;; ### Internal variables definitions ### ;;;~%")
+ (format stream ";;; ### You can edit this part when clfswm is not running ### ;;;~%")
+ (format stream "(in-package :clfswm)~2%")
+ (format stream "(setf~%")
+ (dolist (group all-groups)
+ (format stream " ;; ~A:~%" group)
+ (dolist (var all-variables)
+ (when (string-equal (second var) group)
+ (format stream " ~A ~A~%" (first var)
+ (escape-conf-value (first var)))))
+ (format stream "~%"))
+ (format stream ")~%")
+ (format stream ";;; ### End of internal variables definitions ### ;;;~%")))
+
+
+
+
+(defun save-configuration-variables ()
+ "Save all configuration variables in clfswmrc"
+ (let ((conffile (conf-file-name))
+ (tempfile (temp-conf-file-name)))
+ (with-open-file (stream-in conffile :direction :input :if-does-not-exist :create)
+ (with-open-file (stream-out tempfile :direction :output :if-exists :supersede)
+ (copy-previous-conf-file-begin stream-in stream-out)
+ (save-variables-in-conf-file stream-out)
+ (copy-previous-conf-file-end stream-in stream-out)))
+ (delete-file conffile)
+ (rename-file tempfile conffile)
+ nil))
+
+
+;;; Configuration menu definition
+
+(defun group->menu (group)
+ (intern (string-upcase
+ (format nil "conf-~A" (substitute #\- #\Space group)))
+ :clfswm))
+
+(defun query-conf-value (string original)
+ (labels ((warn-wrong-type (result original)
+ (if (equal (simple-type-of result) (simple-type-of original))
+ result
+ (if (string-equal
+ (query-string
+ (format nil "~S and ~S are not of the same type (~A and ~A). Do you really want to use this value? (yes/no)"
+ result original (type-of result) (type-of original))
+ "no")
+ "yes")
+ result
+ original))))
+ (multiple-value-bind (result return)
+ (query-string (format nil "Configure ~A" string) original)
+ (let ((result-val (eval (read-from-string result)))
+ (original-val (eval (read-from-string original))))
+ (if (member return '(:Return :Complet))
+ (warn-wrong-type result-val original-val)
+ original-val)))))
+
+
+(defun create-conf-function (var)
+ (let* ((string (remove #\* (format nil "~A" var)))
+ (symbol (intern (format nil "CONFIGURE-~A" string) :clfswm)))
+ (setf (symbol-function symbol) (lambda ()
+ (setf (symbol-value var) (query-conf-value string (escape-conf-value var)))
+ (open-menu (find-menu 'configuration-menu)))
+ (documentation symbol 'function) (format nil "Configure ~A" string))
+ symbol))
+
+
+(defun create-configuration-menu ()
+ "Configuration menu"
+ (multiple-value-bind (all-groups all-variables)
+ (find-configuration-variables)
+ (add-menu-key 'configuration-menu "a" 'save-configuration-variables)
+ (loop for group in all-groups
+ for i from 1
+ do (let ((menu (group->menu group)))
+ (add-sub-menu 'configuration-menu (number->char i) menu group)
+ (loop for var in all-variables
+ with j = -1
+ do (when (equal (second var) group)
+ (add-menu-key menu (number->char (incf j))
+ (create-conf-function (first var)))))))))
+
+
+
+
+
+
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Sat Nov 14 17:38:10 2009
@@ -1272,84 +1272,3 @@
`(,(format nil "Focus window: None")
(#\u unhide-all-windows-in-current-child))))))
-
-;;; Configuration variables save
-
-(defun find-symbol-function (function)
- (with-all-internal-symbols (symbol :clfswm)
- (when (and (fboundp symbol) (equal (symbol-function symbol) function))
- (return-from find-symbol-function symbol))))
-
-(defun temp-conf-file-name ()
- (let ((name (conf-file-name)))
- (make-pathname :directory (pathname-directory name)
- :name (concatenate 'string (pathname-name name) "-tmp"))))
-
-
-(defun copy-previous-conf-file-begin (stream-in stream-out)
- (loop for line = (read-line stream-in nil nil)
- while line
- until (zerop (or (search ";;; ### Internal variables definitions" line) -1))
- do (format stream-out "~A~%" line)))
-
-(defun copy-previous-conf-file-end (stream-in stream-out)
- (loop for line = (read-line stream-in nil nil)
- while line
- until (zerop (or (search ";;; ### End of internal variables definitions" line) -1)))
- (loop for line = (read-line stream-in nil nil)
- while line
- do (format stream-out "~A~%" line)))
-
-
-
-(defun save-variables-in-conf-file (stream)
- (let ((all-groups nil)
- (all-variables nil))
- (with-all-internal-symbols (symbol :clfswm)
- (when (is-config-p symbol)
- (pushnew (config-group symbol) all-groups :test #'string-equal)
- (push (list symbol (config-group symbol)) all-variables)))
- (format stream "~2&;;; ### Internal variables definitions ### ;;;~%")
- (format stream ";;; ### You can edit this part when clfswm is not running ### ;;;~%")
- (format stream "(in-package :clfswm)~2%")
- (format stream "(setf~%")
- (dolist (group all-groups)
- (format stream " ;; ~A:~%" group)
- (dolist (var all-variables)
- (when (string-equal (second var) group)
- (format stream " ~A " (first var))
- (let ((value (symbol-value (first var))))
- (cond ((or (equal value t) (equal value nil))
- (format stream "~S" value))
- ((consp value)
- (format stream "(quote ~S)" value))
- ((symbolp value)
- (format stream "'~S" value))
- ((functionp value)
- (format stream "'~S" (find-symbol-function value)))
- ((xlib:color-p value)
- (format stream "(->color #x~X)" (color->rgb value)))
- (t (format stream "~S" value))))
- (terpri stream)))
- (format stream "~%"))
- (format stream ")~%")
- (format stream ";;; ### End of internal variables definitions ### ;;;~%")))
-
-
-
-
-(defun save-configuration-variables ()
- "Save all configuration variables in clfswmrc"
- (let ((conffile (conf-file-name))
- (tempfile (temp-conf-file-name)))
- (with-open-file (stream-in conffile :direction :input :if-does-not-exist :create)
- (with-open-file (stream-out tempfile :direction :output :if-exists :supersede)
- (copy-previous-conf-file-begin stream-in stream-out)
- (save-variables-in-conf-file stream-out)
- (copy-previous-conf-file-end stream-in stream-out)))
- (delete-file conffile)
- (rename-file tempfile conffile)
- nil))
-
-
-
Modified: clfswm/src/menu-def.lisp
==============================================================================
--- clfswm/src/menu-def.lisp (original)
+++ clfswm/src/menu-def.lisp Sat Nov 14 17:38:10 2009
@@ -56,11 +56,14 @@
(add-sub-menu 'main "n" 'action-by-name-menu "Action by name menu")
(add-sub-menu 'main "u" 'action-by-number-menu "Action by number menu")
(add-sub-menu 'main "y" 'utility-menu "Utility menu")
+(add-sub-menu 'main "o" 'configuration-menu "Configuration menu")
(add-sub-menu 'main "m" 'clfswm-menu "CLFSWM menu")
(update-menus (find-menu 'standard-menu))
+(create-configuration-menu)
+
(add-menu-key 'help-menu "h" 'show-global-key-binding)
(add-menu-key 'help-menu "b" 'show-main-mode-key-binding)
(add-menu-key 'help-menu "s" 'show-second-mode-key-binding)
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Sat Nov 14 17:38:10 2009
@@ -46,6 +46,7 @@
:setf/=
:create-symbol
:number->char
+ :simple-type-of
:nth-insert
:split-string
:append-newline-space
@@ -285,6 +286,12 @@
(defun number->char (number)
(code-char (+ (char-code #\a) number)))
+(defun simple-type-of (object)
+ (let ((type (type-of object)))
+ (typecase type
+ (cons (first type))
+ (t type))))
+
(defun nth-insert (n elem list)
More information about the clfswm-cvs
mailing list