[clfswm-cvs] r261 - in clfswm: . contrib src

[Philippe Brochard]

Author: pbrochard
Date: Thu Nov 12 16:38:56 2009
New Revision: 261

Log:
save-configuration-variables): New function to save all configuration variables in clfswmrc.

Modified:
   clfswm/ChangeLog
   clfswm/contrib/reboot-halt.lisp
   clfswm/src/clfswm-util.lisp
   clfswm/src/clfswm.lisp
   clfswm/src/xlib-util.lisp

Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog	(original)
+++ clfswm/ChangeLog	Thu Nov 12 16:38:56 2009
@@ -1,3 +1,8 @@
+2009-11-12  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-util.lisp (save-configuration-variables): New
+	function to save all configuration variables in clfswmrc.
+
 2009-11-11  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/clfswm-info.lisp (info-mode): Begining of mouse support in

Modified: clfswm/contrib/reboot-halt.lisp
==============================================================================
--- clfswm/contrib/reboot-halt.lisp	(original)
+++ clfswm/contrib/reboot-halt.lisp	Thu Nov 12 16:38:56 2009
@@ -56,12 +56,9 @@
 
 (unless (find-menu 'reboot-halt-menu)
   (add-sub-menu 'help-menu "Pause" 'reboot-halt-menu "Suspend/Reboot/Halt menu")
-
   (add-menu-key 'reboot-halt-menu "s" 'do-suspend)
   (add-menu-key 'reboot-halt-menu "r" 'do-reboot)
-  (add-menu-key 'reboot-halt-menu "h" 'do-halt)
-  (add-menu-key 'reboot-halt-menu "Return" 'do-suspend)
-  (add-menu-key 'reboot-halt-menu "space" 'do-suspend))
+  (add-menu-key 'reboot-halt-menu "h" 'do-halt))
 
 
 (defun reboot-halt-binding ()

Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp	(original)
+++ clfswm/src/clfswm-util.lisp	Thu Nov 12 16:38:56 2009
@@ -25,6 +25,23 @@
 
 (in-package :clfswm)
 
+
+;;; Configuration file
+(defun xdg-config-home ()
+  (pathname-directory (concatenate 'string (or (getenv "XDG_CONFIG_HOME")
+					       (getenv "HOME"))
+				   "/")))
+
+(defun conf-file-name ()
+  (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
+	 (etc-conf (probe-file #p"/etc/clfswmrc"))
+	 (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
+						      :name "clfswmrc"))))
+    (or config-user-conf user-conf etc-conf)))
+
+
+
+
 (defun load-contrib (file)
   "Load a file in the contrib directory"
   (let ((truename (concatenate 'string *contrib-dir* "contrib/" file)))
@@ -1256,3 +1273,83 @@
 	    (#\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/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp	(original)
+++ clfswm/src/clfswm.lisp	Thu Nov 12 16:38:56 2009
@@ -265,11 +265,6 @@
 
 
 
-(defun xdg-config-home ()
-  (pathname-directory (concatenate 'string (or (getenv "XDG_CONFIG_HOME")
-					       (getenv "HOME"))
-				   "/")))
-
 
 (defun read-conf-file ()
   (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))

Modified: clfswm/src/xlib-util.lisp
==============================================================================
--- clfswm/src/xlib-util.lisp	(original)
+++ clfswm/src/xlib-util.lisp	Thu Nov 12 16:38:56 2009
@@ -613,6 +613,15 @@
   "White")
 
 
+(defun color->rgb (color)
+  (multiple-value-bind (r g b)
+      (xlib:color-rgb color)
+    (+ (ash (round (* 256 r)) +16)
+       (ash (round (* 256 g)) +8)
+       (round (* 256 b)))))
+
+
+
 
 
 (defmacro my-character->keysyms (ch)