[clfswm-cvs] r423 - in clfswm: . contrib src
Philippe Brochard
pbrochard at common-lisp.net
Mon Mar 7 22:23:54 UTC 2011
Author: pbrochard
Date: Mon Mar 7 17:23:53 2011
New Revision: 423
Log:
src/clfswm-configuration.lisp (create-configuration-menu): Change the config system with a more lispy one and a less string based one: (defconfig name value group doc).
Modified:
clfswm/ChangeLog
clfswm/TODO
clfswm/contrib/volume-mode.lisp
clfswm/src/clfswm-configuration.lisp
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/clfswm.lisp
clfswm/src/config.lisp
clfswm/src/package.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Mon Mar 7 17:23:53 2011
@@ -1,3 +1,10 @@
+2011-03-07 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-configuration.lisp (create-configuration-menu):
+ Change the config system with a more lispy one and a less string
+ based one: (defconfig name value group doc).
+
+
2011-03-06 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-internal.lisp (show-all-children): Simplify the
Modified: clfswm/TODO
==============================================================================
--- clfswm/TODO (original)
+++ clfswm/TODO Mon Mar 7 17:23:53 2011
@@ -13,15 +13,10 @@
- Make frame/window border size variable.
-- In show-all-children: add the ability to display all child from
- *root-frame* and hide all those who are not in *current-root*.
- -> remove hide-all-children when needed.
-
- Estimate the time to raise/lower a child in show-all-children and
- see if there is a need for a rectangular optimization
-
-- Change the config system with a more lispy one and a less string
- base one: (defconfig name value group doc)
+ see if there is a need for a rectangular optimization:
+ Result: map-window: 1.2E-5 sec. change stack order: 3.14E-4 sec.
+ => It maybe useful to optimize this part.
MAYBE
Modified: clfswm/contrib/volume-mode.lisp
==============================================================================
--- clfswm/contrib/volume-mode.lisp (original)
+++ clfswm/contrib/volume-mode.lisp Mon Mar 7 17:23:53 2011
@@ -63,8 +63,8 @@
(format t "Loading Volume mode code... ")
(defparameter *volume-keys* nil)
-(defparameter *volume-mode-placement* 'bottom-middle-placement
- "Config(Placement group): Volume mode window placement")
+(defconfig *volume-mode-placement* 'bottom-middle-placement
+ 'Placement "Volume mode window placement")
(defvar *volume-window* nil)
@@ -84,22 +84,22 @@
;;; CONFIG - Volume mode
-(defparameter *volume-font-string* *default-font-string*
- "Config(Volume mode group): Volume string window font string")
-(defparameter *volume-background* "black"
- "Config(Volume mode group): Volume string window background color")
-(defparameter *volume-foreground* "green"
- "Config(Volume mode group): Volume string window foreground color")
-(defparameter *volume-border* "red"
- "Config(Volume mode group): Volume string window border color")
-(defparameter *volume-width* 400
- "Config(Volume mode group): Volume mode window width")
-(defparameter *volume-height* 15
- "Config(Volume mode group): Volume mode window height")
-(defparameter *volume-text-limit* 30
- "Config(Volume mode group): Maximum text limit in the volume window")
-(defparameter *volume-external-mixer-cmd* "/usr/bin/gnome-alsamixer"
- "Config(Volume mode group): Command to start an external mixer program")
+(defconfig *volume-font-string* *default-font-string*
+ 'Volume-mode "Volume string window font string")
+(defconfig *volume-background* "black"
+ 'Volume-mode "Volume string window background color")
+(defconfig *volume-foreground* "green"
+ 'Volume-mode "Volume string window foreground color")
+(defconfig *volume-border* "red"
+ 'Volume-mode "Volume string window border color")
+(defconfig *volume-width* 400
+ 'Volume-mode "Volume mode window width")
+(defconfig *volume-height* 15
+ 'Volume-mode "Volume mode window height")
+(defconfig *volume-text-limit* 30
+ 'Volume-mode "Maximum text limit in the volume window")
+(defconfig *volume-external-mixer-cmd* "/usr/bin/gnome-alsamixer"
+ 'Volume-mode "Command to start an external mixer program")
(define-init-hash-table-key *volume-keys* "Volume mode keys")
(define-define-key "volume" *volume-keys*)
Modified: clfswm/src/clfswm-configuration.lisp
==============================================================================
--- clfswm/src/clfswm-configuration.lisp (original)
+++ clfswm/src/clfswm-configuration.lisp Mon Mar 7 17:23:53 2011
@@ -26,48 +26,46 @@
(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)))
+ (maphash (lambda (key val)
+ (pushnew (configvar-group val) all-groups :test #'string-equal)
+ (push (list key (configvar-group val)) all-variables))
+ *config-var-table*)
(values all-groups all-variables)))
+(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 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)))))
-
-(defun remove-config-group (documentation)
- (let ((pos (position #\: documentation)))
- (if pos
- (string-trim " " (subseq documentation (1+ pos)))
- documentation)))
+ (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))))
+
+(defun escape-conf-symbol-value (symbol)
+ (let ((value (symbol-value symbol)))
+ (escape-conf-value value)))
(defun get-config-value (value)
(ignore-errors (eval (read-from-string value))))
+(defun reset-config-to-default-value (symbol)
+ (setf (symbol-value symbol) (config-default-value symbol)))
-;;; 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))))
+;;; Save configuration variables part
(defun temp-conf-file-name ()
(let ((name (conf-file-name)))
(make-pathname :directory (pathname-directory name)
@@ -104,7 +102,7 @@
(dolist (var all-variables)
(when (string-equal (second var) group)
(format stream " ~A ~A~%" (first var)
- (escape-conf-value (first var)))))
+ (escape-conf-symbol-value (first var)))))
(format stream "~%"))
(format stream ")~%")
(format stream ";;; ### End of internal variables definitions ### ;;;~%")))
@@ -129,26 +127,29 @@
;;; Configuration menu definition
(defun group->menu (group)
- (intern (string-upcase
- (format nil "conf-~A" (substitute #\- #\Space group)))
- :clfswm))
+ (intern (string-upcase (format nil "conf-~A" group)) :clfswm))
+
+(defun group-name (group)
+ (format nil "~:(~A~) Group" (substitute #\Space #\- (string group))))
(defun query-conf-value (var string original)
(labels ((warn-wrong-type (result original)
(if (equal (simple-type-of result) (simple-type-of original))
result
- (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?"
- result original (type-of result) (type-of original))
+ (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?"
+ (escape-conf-value result) (escape-conf-value original)
+ (type-of result) (type-of original))
result
original)))
(ask-set-default-value (original-val)
- (let ((default (extract-config-default-value var)))
- (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original default)
- (get-config-value default)
+ (let ((default (config-default-value var)))
+ (if (query-yes-or-no "Reset ~A from ~A to ~A?" var original (escape-conf-value default))
+ default
original-val))))
(multiple-value-bind (result return)
- (query-string (format nil "Configure ~A - ~A" string
- (remove-config-group (documentation var 'variable)))
+ (query-string (format nil "Configure ~A - ~A (blank=Default: ~A)" string
+ (documentation var 'variable)
+ (escape-conf-value (config-default-value var)))
original)
(let ((original-val (get-config-value original)))
(if (equal return :Return)
@@ -163,7 +164,7 @@
(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 var string (escape-conf-value var)))
+ (setf (symbol-value var) (query-conf-value var string (escape-conf-symbol-value var)))
(open-menu (find-menu 'configuration-menu)))
(documentation symbol 'function) (format nil "Configure ~A" string))
symbol))
@@ -178,7 +179,7 @@
(loop for group in all-groups
for i from 0
do (let ((menu (group->menu group)))
- (add-sub-menu 'configuration-menu (number->char i) menu group)
+ (add-sub-menu 'configuration-menu (number->char i) menu (group-name group))
(loop for var in all-variables
with j = -1
do (when (equal (second var) group)
@@ -189,52 +190,12 @@
-;;; Default documentation string utility
-(defparameter *config-default-string* "(blank=Default: ")
-
-(defmacro with-config-default-value-position ((symbol doc pos1 pos2) &body body)
- `(let* ((,doc (documentation ,symbol 'variable))
- (length (length ,doc))
- (,pos2 (and (plusp length) (1- length))))
- (when (and ,pos2 (char= (char ,doc ,pos2) #\)))
- (let ((,pos1 (awhen (search *config-default-string* ,doc :from-end t)
- (+ it (length *config-default-string*)))))
- (when ,pos1
- , at body)))))
-
-(defun remove-config-default-value (symbol)
- (with-config-default-value-position (symbol doc pos1 pos2)
- (setf (documentation symbol 'variable)
- (string-trim " " (subseq doc 0 pos1)))))
-
-(defun extract-config-default-value (symbol)
- (with-config-default-value-position (symbol doc pos1 pos2)
- (string-trim " " (subseq doc pos1 pos2))))
-
-
-(defun change-config-default-value (symbol)
- (remove-config-default-value symbol)
- (setf (documentation symbol 'variable)
- (format nil "~A ~A~A)" (documentation symbol 'variable)
- *config-default-string*
- (escape-conf-value symbol))))
-
-(defun reset-config-to-default-value (symbol)
- (let ((default (extract-config-default-value symbol)))
- (setf (symbol-value symbol) (get-config-value default))))
-
-
-(defun add-all-config-default-value ()
- (with-all-internal-symbols (symbol :clfswm)
- (when (is-config-p symbol)
- (change-config-default-value symbol))))
-
-
(defun reset-all-config-variables ()
"Reset all configuration variables to there default values"
(when (query-yes-or-no "Do you really want to reset all values to there default?")
- (with-all-internal-symbols (symbol :clfswm)
- (when (is-config-p symbol)
- (reset-config-to-default-value symbol))))
+ (maphash (lambda (key val)
+ (declare (ignore val))
+ (reset-config-to-default-value key))
+ *config-var-table*))
(open-menu (find-menu 'configuration-menu)))
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Mon Mar 7 17:23:53 2011
@@ -627,8 +627,8 @@
(with-slots (window show-window-p) frame
(if show-window-p
(when (or *show-root-frame-p* (not (child-equal-p frame *current-root*)))
- (map-window window)
- (set-child-stack-order window previous)
+ (map-window window)
+ (set-child-stack-order window previous)
(display-frame-info frame))
(hide-window window))))
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Mon Mar 7 17:23:53 2011
@@ -1237,10 +1237,10 @@
;;; Standard menu functions - Based on the XDG specifications
-(defparameter *xdg-section-list* (append '(TextEditor FileManager WebBrowser)
- '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility)
- '(TerminalEmulator Archlinux Screensaver))
- "Config(Menu group): Standard menu sections")
+(defconfig *xdg-section-list* (append '(TextEditor FileManager WebBrowser)
+ '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility)
+ '(TerminalEmulator Archlinux Screensaver))
+ 'Menu "Standard menu sections")
(defun um-create-xdg-section-list (menu)
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Mon Mar 7 17:23:53 2011
@@ -252,7 +252,6 @@
(when read-conf-file-p
(read-conf-file))
(create-configuration-menu :clear t)
- (add-all-config-default-value)
(call-hook *main-entrance-hook*)
(handler-case
(open-display display protocol)
Modified: clfswm/src/config.lisp
==============================================================================
--- clfswm/src/config.lisp (original)
+++ clfswm/src/config.lisp Mon Mar 7 17:23:53 2011
@@ -31,32 +31,26 @@
(in-package :clfswm)
-;;; CONFIG - Compress motion notify ?
-;; This variable may be useful to speed up some slow version of CLX.
-;; It is particulary useful with CLISP/MIT-CLX.
-(setf *have-to-compress-notify* t)
-
-
;;; CONFIG - Default modifiers
-(defparameter *default-modifiers* '()
- "Config(): Default modifiers list to append to explicit modifiers
+(defconfig *default-modifiers* '() nil
+ "Default modifiers list to append to explicit modifiers
Example: :mod-2 for num_lock, :lock for Caps_lock...")
;;; CONFIG - Never managed window list
-(defparameter *never-managed-window-list*
- (list (list (equal-wm-class-fun "ROX-Pinboard") nil)
- (list (equal-wm-class-fun "xvkbd") 'raise-window)
- (list 'equal-clfswm-terminal-id 'raise-and-focus-window))
- "Config(): CLFSWM will never manage windows of this type.
+(defconfig *never-managed-window-list*
+ (list (list (equal-wm-class-fun "ROX-Pinboard") nil)
+ (list (equal-wm-class-fun "xvkbd") 'raise-window)
+ (list 'equal-clfswm-terminal-id 'raise-and-focus-window))
+ nil "CLFSWM will never manage windows of this type.
A list of (list match-function handle-function)")
-(defparameter *hide-unmanaged-window* t
- "Config(): Hide or not unmanaged windows when a child is deselected.")
+(defconfig *hide-unmanaged-window* t nil
+ "Hide or not unmanaged windows when a child is deselected.")
;;; CONFIG - Screen size
(defun get-fullscreen-size ()
@@ -68,57 +62,57 @@
;; (values 100 100 800 600))
-(defparameter *corner-size* 3
- "Config(Corner group): The size of the corner square")
+(defconfig *corner-size* 3 'Corner
+ "The size of the corner square")
;;; CONFIG: Corner actions - See in clfswm-corner.lisp for
;;; allowed functions
-(defparameter *corner-main-mode-left-button*
- '((:top-left open-menu)
- (:top-right present-virtual-keyboard)
- (:bottom-right expose-windows-mode)
- (:bottom-left nil))
- "Config(Corner group): Actions on corners in the main mode with the left mouse button")
-
-(defparameter *corner-main-mode-middle-button*
- '((:top-left help-on-clfswm)
- (:top-right ask-close/kill-current-window)
- (:bottom-right nil)
- (:bottom-left nil))
- "Config(Corner group): Actions on corners in the main mode with the middle mouse button")
-
-(defparameter *corner-main-mode-right-button*
- '((:top-left present-clfswm-terminal)
- (:top-right ask-close/kill-current-window)
- (:bottom-right expose-all-windows-mode)
- (:bottom-left nil))
- "Config(Corner group): Actions on corners in the main mode with the right mouse button")
-
-(defparameter *corner-second-mode-left-button*
- '((:top-left nil)
- (:top-right nil)
- (:bottom-right expose-windows-mode)
- (:bottom-left nil))
- "Config(Corner group): Actions on corners in the second mode with the left mouse button")
-
-(defparameter *corner-second-mode-middle-button*
- '((:top-left help-on-clfswm)
- (:top-right nil)
- (:bottom-right nil)
- (:bottom-left nil))
- "Config(Corner group): Actions on corners in the second mode with the middle mouse button")
-
-(defparameter *corner-second-mode-right-button*
- '((:top-left nil)
- (:top-right nil)
- (:bottom-right expose-all-windows-mode)
- (:bottom-left nil))
- "Config(Corner group): Actions on corners in the second mode with the right mouse button")
+(defconfig *corner-main-mode-left-button*
+ '((:top-left open-menu)
+ (:top-right present-virtual-keyboard)
+ (:bottom-right expose-windows-mode)
+ (:bottom-left nil))
+ 'Corner "Actions on corners in the main mode with the left mouse button")
+
+(defconfig *corner-main-mode-middle-button*
+ '((:top-left help-on-clfswm)
+ (:top-right ask-close/kill-current-window)
+ (:bottom-right nil)
+ (:bottom-left nil))
+ 'Corner "Actions on corners in the main mode with the middle mouse button")
+
+(defconfig *corner-main-mode-right-button*
+ '((:top-left present-clfswm-terminal)
+ (:top-right ask-close/kill-current-window)
+ (:bottom-right expose-all-windows-mode)
+ (:bottom-left nil))
+ 'Corner "Actions on corners in the main mode with the right mouse button")
+
+(defconfig *corner-second-mode-left-button*
+ '((:top-left nil)
+ (:top-right nil)
+ (:bottom-right expose-windows-mode)
+ (:bottom-left nil))
+ 'Corner "Actions on corners in the second mode with the left mouse button")
+
+(defconfig *corner-second-mode-middle-button*
+ '((:top-left help-on-clfswm)
+ (:top-right nil)
+ (:bottom-right nil)
+ (:bottom-left nil))
+ 'Corner "Actions on corners in the second mode with the middle mouse button")
+
+(defconfig *corner-second-mode-right-button*
+ '((:top-left nil)
+ (:top-right nil)
+ (:bottom-right expose-all-windows-mode)
+ (:bottom-left nil))
+ 'Corner "Actions on corners in the second mode with the right mouse button")
-(defparameter *virtual-keyboard-cmd* "xvkbd"
- "Config(Corner group): The command to display the virtual keybaord
+(defconfig *virtual-keyboard-cmd* "xvkbd"
+ 'Corner "The command to display the virtual keybaord
Here is an ~/.Xresources example for xvkbd:
xvkbd.windowGeometry: 300x100-0-0
xvkbd*Font: 6x12
@@ -127,12 +121,12 @@
xvkbd.keypad: false
And make it always on top")
-(defparameter *clfswm-terminal-name* "clfswm-terminal"
- "Config(Corner group): The clfswm terminal name")
+(defconfig *clfswm-terminal-name* "clfswm-terminal"
+ 'Corner "The clfswm terminal name")
;;(defparameter *clfswm-terminal-cmd* (format nil "xterm -T ~A -e /bin/bash --noprofile --norc" *clfswm-terminal-name*)
;;(defparameter *clfswm-terminal-cmd* (format nil "urxvt -name ~A" *clfswm-terminal-name*)
-(defparameter *clfswm-terminal-cmd* (format nil "xterm -T ~A" *clfswm-terminal-name*)
- "Config(Corner group): The clfswm terminal command.
+(defconfig *clfswm-terminal-cmd* (format nil "xterm -T ~A" *clfswm-terminal-name*)
+ 'Corner "The clfswm terminal command.
This command must set the window title to *clfswm-terminal-name*")
@@ -148,182 +142,182 @@
;;;
;;; See clfswm.lisp for hooks examples.
-(defparameter *init-hook* '(default-init-hook display-hello-window)
- "Config(Hook group): Init hook. This hook is run just after the first root frame is created")
+(defconfig *init-hook* '(default-init-hook display-hello-window)
+ 'Hook "Init hook. This hook is run just after the first root frame is created")
-(defparameter *close-hook* '(close-notify-window close-clfswm-terminal close-virtual-keyboard)
- "Config(Hook group): Close hook. This hook is run just before closing the display")
+(defconfig *close-hook* '(close-notify-window close-clfswm-terminal close-virtual-keyboard)
+ 'Hook "Close hook. This hook is run just before closing the display")
-(defparameter *default-nw-hook* 'default-frame-nw-hook
- "Config(Hook group): Default action to do on newly created windows")
+(defconfig *default-nw-hook* 'default-frame-nw-hook
+ 'Hook "Default action to do on newly created windows")
;;; CONFIG
-(defparameter *create-frame-on-root* nil
- "Config(): Create frame on root.
+(defconfig *create-frame-on-root* nil
+ nil "Create frame on root.
Set this variable to true if you want to allow to create a new frame
on the root window in the main mode with the mouse")
;;; CONFIG: Main mode colors
-(defparameter *color-selected* "Red"
- "Config(Main mode group): Color of selected window")
-(defparameter *color-unselected* "Blue"
- "Config(Main mode group): Color of unselected color")
-(defparameter *color-maybe-selected* "Yellow"
- "Config(Main mode group): Color of maybe selected windows")
+(defconfig *color-selected* "Red"
+ 'Main-mode "Color of selected window")
+(defconfig *color-unselected* "Blue"
+ 'Main-mode "Color of unselected color")
+(defconfig *color-maybe-selected* "Yellow"
+ 'Main-mode "Color of maybe selected windows")
;;; CONFIG: Frame colors
-(defparameter *frame-background* "Black"
- "Config(Frame colors group): Frame background")
-(defparameter *frame-foreground* "Green"
- "Config(Frame colors group): Frame foreground")
-(defparameter *frame-foreground-root* "Red"
- "Config(Frame colors group): Frame foreground when the frame is the root frame")
-(defparameter *frame-foreground-hidden* "Darkgreen"
- "Config(Frame colors group): Frame foreground for hidden windows")
+(defconfig *frame-background* "Black"
+ 'Frame-colors "Frame background")
+(defconfig *frame-foreground* "Green"
+ 'Frame-colors "Frame foreground")
+(defconfig *frame-foreground-root* "Red"
+ 'Frame-colors "Frame foreground when the frame is the root frame")
+(defconfig *frame-foreground-hidden* "Darkgreen"
+ 'Frame-colors "Frame foreground for hidden windows")
;;; CONFIG: Default window size
-(defparameter *default-window-width* 400
- "Config(): Default window width")
-(defparameter *default-window-height* 300
- "Config(): Default window height")
+(defconfig *default-window-width* 400
+ nil "Default window width")
+(defconfig *default-window-height* 300
+ nil "Default window height")
;;; CONFIG: Second mode colors and fonts
-(defparameter *sm-border-color* "Green"
- "Config(Second mode group): Second mode window border color")
-(defparameter *sm-background-color* "Black"
- "Config(Second mode group): Second mode window background color")
-(defparameter *sm-foreground-color* "Red"
- "Config(Second mode group): Second mode window foreground color")
-(defparameter *sm-font-string* *default-font-string*
- "Config(Second mode group): Second mode window font string")
-(defparameter *sm-width* 300
- "Config(Second mode group): Second mode window width")
-(defparameter *sm-height* 25
- "Config(Second mode group): Second mode window height")
+(defconfig *sm-border-color* "Green"
+ 'Second-mode "Second mode window border color")
+(defconfig *sm-background-color* "Black"
+ 'Second-mode "Second mode window background color")
+(defconfig *sm-foreground-color* "Red"
+ 'Second-mode "Second mode window foreground color")
+(defconfig *sm-font-string* *default-font-string*
+ 'Second-mode "Second mode window font string")
+(defconfig *sm-width* 300
+ 'Second-mode "Second mode window width")
+(defconfig *sm-height* 25
+ 'Second-mode "Second mode window height")
;;; CONFIG - Identify key colors
-(defparameter *identify-font-string* *default-font-string*
- "Config(Identify key group): Identify window font string")
-(defparameter *identify-background* "black"
- "Config(Identify key group): Identify window background color")
-(defparameter *identify-foreground* "green"
- "Config(Identify key group): Identify window foreground color")
-(defparameter *identify-border* "red"
- "Config(Identify key group): Identify window border color")
+(defconfig *identify-font-string* *default-font-string*
+ 'Identify-key "Identify window font string")
+(defconfig *identify-background* "black"
+ 'Identify-key "Identify window background color")
+(defconfig *identify-foreground* "green"
+ 'Identify-key "Identify window foreground color")
+(defconfig *identify-border* "red"
+ 'Identify-key "Identify window border color")
;;; CONFIG - Query string colors
-(defparameter *query-font-string* *default-font-string*
- "Config(Query string group): Query string window font string")
-(defparameter *query-background* "black"
- "Config(Query string group): Query string window background color")
-(defparameter *query-message-color* "yellow"
- "Config(Query string group): Query string window message color")
-(defparameter *query-foreground* "green"
- "Config(Query string group): Query string window foreground color")
-(defparameter *query-cursor-color* "white"
- "Config(Query string group): Query string window foreground cursor color")
-(defparameter *query-parent-color* "blue"
- "Config(Query string group): Query string window parenthesis color")
-(defparameter *query-parent-error-color* "red"
- "Config(Query string group): Query string window parenthesis color when no match")
-(defparameter *query-border* "red"
- "Config(Query string group): Query string window border color")
+(defconfig *query-font-string* *default-font-string*
+ 'Query-string "Query string window font string")
+(defconfig *query-background* "black"
+ 'Query-string "Query string window background color")
+(defconfig *query-message-color* "yellow"
+ 'Query-string "Query string window message color")
+(defconfig *query-foreground* "green"
+ 'Query-string "Query string window foreground color")
+(defconfig *query-cursor-color* "white"
+ 'Query-string "Query string window foreground cursor color")
+(defconfig *query-parent-color* "blue"
+ 'Query-string "Query string window parenthesis color")
+(defconfig *query-parent-error-color* "red"
+ 'Query-string "Query string window parenthesis color when no match")
+(defconfig *query-border* "red"
+ 'Query-string "Query string window border color")
;;; CONFIG - Info mode
-(defparameter *info-background* "black"
- "Config(Info mode group): Info window background color")
-(defparameter *info-foreground* "green"
- "Config(Info mode group): Info window foreground color")
-(defparameter *info-border* "red"
- "Config(Info mode group): Info window border color")
-(defparameter *info-line-cursor* "white"
- "Config(Info mode group): Info window line cursor color color")
-(defparameter *info-selected-background* "blue"
- "Config(Info mode group): Info selected item background color")
-(defparameter *info-font-string* *default-font-string*
- "Config(Info mode group): Info window font string")
+(defconfig *info-background* "black"
+ 'Info-mode "Info window background color")
+(defconfig *info-foreground* "green"
+ 'Info-mode "Info window foreground color")
+(defconfig *info-border* "red"
+ 'Info-mode "Info window border color")
+(defconfig *info-line-cursor* "white"
+ 'Info-mode "Info window line cursor color color")
+(defconfig *info-selected-background* "blue"
+ 'Info-mode "Info selected item background color")
+(defconfig *info-font-string* *default-font-string*
+ 'Info-mode "Info window font string")
-(defparameter *info-click-to-select* t
- "Config(Info mode group): If true, click on info window select item. Otherwise, click to drag the menu")
+(defconfig *info-click-to-select* t
+ 'Info-mode "If true, click on info window select item. Otherwise, click to drag the menu")
;;; CONFIG - Circulate string colors
-(defparameter *circulate-font-string* *default-font-string*
- "Config(Circulate mode group): Circulate string window font string")
-(defparameter *circulate-background* "black"
- "Config(Circulate mode group): Circulate string window background color")
-(defparameter *circulate-foreground* "green"
- "Config(Circulate mode group): Circulate string window foreground color")
-(defparameter *circulate-border* "red"
- "Config(Circulate mode group): Circulate string window border color")
-(defparameter *circulate-width* 400
- "Config(Circulate mode group): Circulate mode window width")
-(defparameter *circulate-height* 15
- "Config(Circulate mode group): Circulate mode window height")
+(defconfig *circulate-font-string* *default-font-string*
+ 'Circulate-mode "Circulate string window font string")
+(defconfig *circulate-background* "black"
+ 'Circulate-mode "Circulate string window background color")
+(defconfig *circulate-foreground* "green"
+ 'Circulate-mode "Circulate string window foreground color")
+(defconfig *circulate-border* "red"
+ 'Circulate-mode "Circulate string window border color")
+(defconfig *circulate-width* 400
+ 'Circulate-mode "Circulate mode window width")
+(defconfig *circulate-height* 15
+ 'Circulate-mode "Circulate mode window height")
-(defparameter *circulate-text-limite* 30
- "Config(Circulate mode group): Maximum text limite in the circulate window")
+(defconfig *circulate-text-limite* 30
+ 'Circulate-mode "Maximum text limite in the circulate window")
;;; CONFIG - Expose string colors
-(defparameter *expose-font-string* *default-font-string*
- "Config(Expose mode group): Expose string window font string")
-(defparameter *expose-background* "black"
- "Config(Expose mode group): Expose string window background color")
-(defparameter *expose-foreground* "green"
- "Config(Expose mode group): Expose string window foreground color")
-(defparameter *expose-border* "red"
- "Config(Expose mode group): Expose string window border color")
-(defparameter *expose-valid-on-key* t
- "Config(Expose mode group): Valid expose mode when an accel key is pressed")
-(defparameter *expose-show-window-title* t
- "Config(Expose mode group): Show the window title on accel window")
+(defconfig *expose-font-string* *default-font-string*
+ 'Expose-mode "Expose string window font string")
+(defconfig *expose-background* "black"
+ 'Expose-mode "Expose string window background color")
+(defconfig *expose-foreground* "green"
+ 'Expose-mode "Expose string window foreground color")
+(defconfig *expose-border* "red"
+ 'Expose-mode "Expose string window border color")
+(defconfig *expose-valid-on-key* t
+ 'Expose-mode "Valid expose mode when an accel key is pressed")
+(defconfig *expose-show-window-title* t
+ 'Expose-mode "Show the window title on accel window")
;;; CONFIG - Show key binding colors
-(defparameter *info-color-title* "Magenta"
- "Config(Info mode group): Colored info title color")
-(defparameter *info-color-underline* "Yellow"
- "Config(Info mode group): Colored info underline color")
-(defparameter *info-color-first* "Cyan"
- "Config(Info mode group): Colored info first color")
-(defparameter *info-color-second* "lightblue"
- "Config(Info mode group): Colored info second color")
+(defconfig *info-color-title* "Magenta"
+ 'Info-mode "Colored info title color")
+(defconfig *info-color-underline* "Yellow"
+ 'Info-mode "Colored info underline color")
+(defconfig *info-color-first* "Cyan"
+ 'Info-mode "Colored info first color")
+(defconfig *info-color-second* "lightblue"
+ 'Info-mode "Colored info second color")
;;; CONFIG - Menu colors
;;; Set *info-foreground* to change the default menu foreground
-(defparameter *menu-color-submenu* "Cyan"
- "Config(Menu group): Submenu color in menu")
-(defparameter *menu-color-comment* "Yellow"
- "Config(Menu group): Comment color in menu")
-(defparameter *menu-color-key* "Magenta"
- "Config(Menu group): Key color in menu")
-(defparameter *menu-color-menu-key* (->color #xFF9AFF)
- "Config(Menu group): Menu key color in menu")
+(defconfig *menu-color-submenu* "Cyan"
+ 'Menu "Submenu color in menu")
+(defconfig *menu-color-comment* "Yellow"
+ 'Menu "Comment color in menu")
+(defconfig *menu-color-key* "Magenta"
+ 'Menu "Key color in menu")
+(defconfig *menu-color-menu-key* (->color #xFF9AFF)
+ 'Menu "Menu key color in menu")
;;; CONFIG - Notify window string colors
-(defparameter *notify-window-font-string* *default-font-string*
- "Config(Notify Window mode group): Notify window font string")
-(defparameter *notify-window-background* "black"
- "Config(Notify Window group): Notify Window background color")
-(defparameter *notify-window-foreground* "green"
- "Config(Notify Window group): Notify Window foreground color")
-(defparameter *notify-window-border* "red"
- "Config(Notify Window group): Notify Window border color")
-(defparameter *notify-window-delay* 10
- "Config(Notify Window group): Notify Window display delay")
+(defconfig *notify-window-font-string* *default-font-string*
+ 'Notify-Window "Notify window font string")
+(defconfig *notify-window-background* "black"
+ 'Notify-Window "Notify Window background color")
+(defconfig *notify-window-foreground* "green"
+ 'Notify-Window "Notify Window foreground color")
+(defconfig *notify-window-border* "red"
+ 'Notify-Window "Notify Window border color")
+(defconfig *notify-window-delay* 10
+ 'Notify-Window "Notify Window display delay")
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Mon Mar 7 17:23:53 2011
@@ -37,12 +37,11 @@
(in-package :clfswm)
-
-
-;;; Compress motion notify ?
-;;; Note: this variable is overwriten in config.lisp
-(defparameter *have-to-compress-notify* t
- "Config(): Compress event notify?
+;;; CONFIG - Compress motion notify ?
+;; This variable may be useful to speed up some slow version of CLX.
+;; It is particulary useful with CLISP/MIT-CLX (and others).
+(defconfig *have-to-compress-notify* t nil
+ "Compress event notify?
This variable may be useful to speed up some slow version of CLX.
It is particulary useful with CLISP/MIT-CLX.")
@@ -59,8 +58,8 @@
(defparameter *root* nil)
(defparameter *no-focus-window* nil)
-(defparameter *loop-timeout* 0.1
- "Config(): Maximum time (in seconds) to wait before calling *loop-hook*")
+(defconfig *loop-timeout* 0.1 nil
+ "Maximum time (in seconds) to wait before calling *loop-hook*")
(defparameter *pixmap-buffer* nil)
@@ -68,26 +67,27 @@
(defparameter *default-font* nil)
;;(defparameter *default-font-string* "9x15")
-(defparameter *default-font-string* "fixed"
- "Config(): The default font used in clfswm")
+(defconfig *default-font-string* "fixed" nil
+ "The default font used in clfswm")
-(defparameter *color-move-window* "DeepPink"
- "Config(Main mode group): Color when moving or resizing a windows")
+(defconfig *color-move-window* "DeepPink" 'Main-mode
+ "Color when moving or resizing a windows")
(defparameter *child-selection* nil)
;;; CONFIG - Default frame datas
-(defparameter *default-frame-data*
+(defconfig *default-frame-data*
(list '(:tile-size 0.8) '(:tile-space-size 0.1)
'(:fast-layout (tile-left-layout tile-layout))
'(:main-layout-windows nil))
- "Config(): Default slots set in frame date")
+ nil
+ "Default slots set in frame date")
;;; CONFIG - Default managed window type for a frame
;;; type can be :all, :normal, :transient, :maxsize, :desktop, :dock, :toolbar, :menu, :utility, :splash, :dialog
-(defparameter *default-managed-type* '(:normal)
- "Config(): Default managed window types")
+(defconfig *default-managed-type* '(:normal) nil
+ "Default managed window types")
;;(defparameter *default-managed-type* '(:normal :maxsize :transient))
;;(defparameter *default-managed-type* '(:normal :transient :maxsize :desktop :dock :toolbar :menu :utility :splash :dialog))
;;(defparameter *default-managed-type* '())
@@ -95,8 +95,8 @@
;;; CONFIG - Default focus policy
-(defparameter *default-focus-policy* :click
- "Config(): Default mouse focus policy. One of :click, :sloppy, :sloppy-strict or :sloppy-select.")
+(defconfig *default-focus-policy* :click nil
+ "Default mouse focus policy. One of :click, :sloppy, :sloppy-strict or :sloppy-select.")
(defclass frame ()
@@ -179,14 +179,14 @@
-(defparameter *binding-hook* nil
- "Config(Hook group): Hook executed when keys/buttons are bounds")
+(defconfig *binding-hook* nil 'Hook
+ "Hook executed when keys/buttons are bounds")
-(defparameter *loop-hook* nil
- "Config(Hook group): Hook executed on each event loop")
+(defconfig *loop-hook* nil 'Hook
+ "Hook executed on each event loop")
-(defparameter *main-entrance-hook* nil
- "Config(Hook group): Hook executed on the main function entrance after
+(defconfig *main-entrance-hook* nil 'Hook
+ "Hook executed on the main function entrance after
loading configuration file and before opening the display.")
@@ -202,20 +202,20 @@
;;; middle-left middle-middle middle-right
;;; bottom-left bottom-middle bottom-right
;;;
-(defparameter *banish-pointer-placement* 'bottom-right-placement
- "Config(Placement group): Pointer banishment placement")
-(defparameter *second-mode-placement* 'top-middle-placement
- "Config(Placement group): Second mode window placement")
-(defparameter *info-mode-placement* 'top-left-placement
- "Config(Placement group): Info mode window placement")
-(defparameter *query-mode-placement* 'top-left-placement
- "Config(Placement group): Query mode window placement")
-(defparameter *circulate-mode-placement* 'bottom-middle-placement
- "Config(Placement group): Circulate mode window placement")
-(defparameter *expose-mode-placement* 'top-left-child-placement
- "Config(Placement group): Expose mode window placement (Selection keys position)")
-(defparameter *notify-window-placement* 'bottom-right-placement
- "Config(Placement group): Notify window placement")
+(defconfig *banish-pointer-placement* 'bottom-right-placement
+ 'Placement "Pointer banishment placement")
+(defconfig *second-mode-placement* 'top-middle-placement
+ 'Placement "Second mode window placement")
+(defconfig *info-mode-placement* 'top-left-placement
+ 'Placement "Info mode window placement")
+(defconfig *query-mode-placement* 'top-left-placement
+ 'Placement "Query mode window placement")
+(defconfig *circulate-mode-placement* 'bottom-middle-placement
+ 'Placement "Circulate mode window placement")
+(defconfig *expose-mode-placement* 'top-left-child-placement
+ 'Placement "Expose mode window placement (Selection keys position)")
+(defconfig *notify-window-placement* 'bottom-right-placement
+ 'Placement "Notify window placement")
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Mon Mar 7 17:23:53 2011
@@ -31,6 +31,7 @@
(:export :it
:awhen
:aif
+ :defconfig :*config-var-table* :configvar-value :configvar-group :config-default-value
:find-in-hash
:nfuncall
:pfuncall
@@ -55,7 +56,6 @@
:ensure-function
:empty-string-p
:find-common-string
- :is-config-p :config-documentation :config-group
:setf/=
:create-symbol
:number->char
@@ -126,6 +126,26 @@
`(let ((it ,test)) (if it ,then ,else)))
+;;; Configuration variables
+(defstruct configvar value group doc)
+
+(defparameter *config-var-table* (make-hash-table :test #'equal))
+
+(defmacro defconfig (name value group doc)
+ `(progn
+ (setf (gethash ',name *config-var-table*)
+ (make-configvar :value ,value
+ :group (or ,group 'Miscellaneous)))
+ (defparameter ,name ,value ,doc)))
+
+(defun config-default-value (var)
+ (let ((config (gethash var *config-var-table*)))
+ (when config
+ (configvar-value config))))
+
+
+
+
(defun find-in-hash (val hashtable &optional (test #'equal))
"Return the key associated to val in the hashtable"
(maphash #'(lambda (k v)
@@ -372,35 +392,6 @@
-;;; Auto configuration tools
-;;; Syntaxe: (defparameter symbol value "Config(config group): documentation string")
-(let* ((start-string "Config(")
- (start-len (length start-string))
- (stop-string "):")
- (stop-len (length stop-string)))
- (defun is-config-p (symbol)
- (when (boundp symbol)
- (let ((doc (documentation symbol 'variable)))
- (and doc
- (= (or (search start-string doc :test #'string-equal) -1) 0)
- (search stop-string doc)
- t))))
-
- (defun config-documentation (symbol)
- (when (is-config-p symbol)
- (let ((doc (documentation symbol 'variable)))
- (string-trim " " (subseq doc (+ (search stop-string doc) stop-len))))))
-
- (defun config-group (symbol)
- (when (is-config-p symbol)
- (let* ((doc (documentation symbol 'variable))
- (group (string-trim " " (subseq doc (+ (search start-string doc) start-len)
- (search stop-string doc)))))
- (if (empty-string-p group) "Miscellaneous group" group)))))
-
-
-
-
;;; Tools
(defmacro setf/= (var val)
"Set var to val only when var not equal to val"
More information about the clfswm-cvs
mailing list