[clfswm-cvs] r351 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Sat Oct 9 20:02:05 UTC 2010
Author: pbrochard
Date: Sat Oct 9 16:02:05 2010
New Revision: 351
Log:
src/clfswm-util.lisp (display-hello-window): Add a timer to hide the hello window. Add Configuration variables.
Modified:
clfswm/ChangeLog
clfswm/src/clfswm-internal.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/config.lisp
clfswm/src/package.lisp
clfswm/src/tools.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Sat Oct 9 16:02:05 2010
@@ -1,3 +1,10 @@
+2010-10-09 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/tools.lisp (erase-timer): New function.
+
+ * src/clfswm-util.lisp (display-hello-window): Add a timer to hide
+ the hello window. Add Configuration variables.
+
2010-10-08 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-util.lisp (): Add an Hello window at startup.
Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp (original)
+++ clfswm/src/clfswm-internal.lisp Sat Oct 9 16:02:05 2010
@@ -148,8 +148,11 @@
(defun never-managed-window-p (window)
(dolist (type *never-managed-window-list*)
- (when (string-equal (funcall (first type) window) (second type))
- (return t))))
+ (destructuring-bind (test predicate result) type
+ (when (funcall test (funcall predicate window) result)
+ (return t)))))
+ ;;(when (string-equal (funcall (first type) window) (second type))
+ ;; (return t))))
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Sat Oct 9 16:02:05 2010
@@ -1446,47 +1446,57 @@
(let ((font nil)
(window nil)
(gc nil)
- (width 300) (height 50)
+ width height
(current-child nil))
+ (defun is-hello-window-p (win)
+ (xlib:window-equal win window))
+
(defun open-hello-window ()
- (with-placement (#'middle-middle-placement x y width height)
- (setf font (xlib:open-font *display* *sm-font-string*)
+ (setf width *hello-window-width*
+ height *hello-window-height*)
+ (with-placement (*hello-window-placement* x y width height)
+ (setf font (xlib:open-font *display* *hello-window-font-string*)
window (xlib:create-window :parent *root*
:x x
:y y
:width width
:height height
- :background (get-color *sm-background-color*)
+ :background (get-color *hello-window-background*)
:border-width 1
- :border (get-color *sm-border-color*)
+ :border (get-color *hello-window-border*)
:colormap (xlib:screen-default-colormap *screen*)
:event-mask '(:exposure :key-press))
gc (xlib:create-gcontext :drawable window
- :foreground (get-color *sm-foreground-color*)
- :background (get-color *sm-background-color*)
+ :foreground (get-color *hello-window-foreground*)
+ :background (get-color *hello-window-background*)
:font font
:line-style :solid))
- (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
- (when (frame-p *current-child*)
- (setf current-child *current-child*)
- (push window (frame-forced-unmanaged-window *current-child*)))
- (map-window window)
- (raise-window window)
- (let* ((text (format nil "Welcome to CLFSWM")))
- (xlib:draw-glyphs window gc
- (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2))
- (truncate (- (/ (+ height text-height) 2) text-height))
- text))
- (let* ((text (format nil "Press Alt+F1 for help")))
- (xlib:draw-glyphs window gc
- (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2))
- (truncate (+ (/ (+ height text-height) 2) text-height))
- text))
- (xlib:display-finish-output *display*))))
+ (when (frame-p *current-child*)
+ (setf current-child *current-child*)
+ (push (list #'equal #'is-hello-window-p t) *never-managed-window-list*))
+ (map-window window)
+ (refresh-hello-window)
+ (xlib:display-finish-output *display*)))
+
+ (defun refresh-hello-window ()
+ (add-timer 0.1 #'refresh-hello-window)
+ (raise-window window)
+ (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
+ (let* ((text (format nil "Welcome to CLFSWM")))
+ (xlib:draw-glyphs window gc
+ (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2))
+ (truncate (- (/ (+ height text-height) 2) text-height))
+ text))
+ (let* ((text (format nil "Press Alt+F1 for help")))
+ (xlib:draw-glyphs window gc
+ (truncate (/ (- width (* (xlib:max-char-width font) (length text))) 2))
+ (truncate (+ (/ (+ height text-height) 2) text-height))
+ text))))
(defun close-hello-window ()
- (setf (frame-forced-unmanaged-window current-child)
- (remove window (frame-forced-unmanaged-window current-child) :test #'xlib:window-equal))
+ (erase-timer #'refresh-hello-window)
+ (setf *never-managed-window-list*
+ (remove (list #'equal #'is-hello-window-p t) *never-managed-window-list* :test #'equal))
(when gc
(xlib:free-gcontext gc))
(when window
@@ -1498,8 +1508,6 @@
gc nil
font nil))
-
(defun display-hello-window ()
(open-hello-window)
- (with-timer (10)
- (close-hello-window))))
+ (add-timer *hello-window-delay* #'close-hello-window)))
Modified: clfswm/src/config.lisp
==============================================================================
--- clfswm/src/config.lisp (original)
+++ clfswm/src/config.lisp Sat Oct 9 16:02:05 2010
@@ -47,9 +47,9 @@
;;; CONFIG - Never managed window list
(defparameter *never-managed-window-list*
- '((xlib:get-wm-class "ROX-Pinboard")
- (xlib:get-wm-class "xvkbd")
- (xlib:wm-name "clfswm-terminal"))
+ '((string-equal xlib:get-wm-class "ROX-Pinboard")
+ (string-equal xlib:get-wm-class "xvkbd")
+ (string-equal xlib:wm-name "clfswm-terminal"))
"Config(): CLFSWM will never manage windows of this type.
A list of (predicate-function-on-window expected-string)")
@@ -308,3 +308,21 @@
(defparameter *menu-color-menu-key* (->color #xFF9AFF)
"Config(Menu group): Menu key color in menu")
+
+;;; CONFIG - Hello window string colors
+(defparameter *hello-window-font-string* *default-font-string*
+ "Config(Hello Window mode group): Hello window font string")
+(defparameter *hello-window-background* "black"
+ "Config(Hello Window mode group): Hello Window background color")
+(defparameter *hello-window-foreground* "green"
+ "Config(Hello Window mode group): Hello Window foreground color")
+(defparameter *hello-window-border* "red"
+ "Config(Hello Window mode group): Hello Window border color")
+(defparameter *hello-window-width* 300
+ "Config(Hello Window mode group): Hello Window width")
+(defparameter *hello-window-height* 50
+ "Config(Hello Window mode group): Hello Window height")
+(defparameter *hello-window-delay* 10
+ "Config(Hello Window mode group): Hello Window display delay")
+
+
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Sat Oct 9 16:02:05 2010
@@ -208,6 +208,8 @@
"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 *hello-window-placement* 'bottom-right-placement
+ "Config(Placement group): Hello window placement")
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Sat Oct 9 16:02:05 2010
@@ -42,6 +42,7 @@
:add-timer
:with-timer
:process-timers
+ :erase-timer
:timer-loop
:dbg
:dbgnl
@@ -192,11 +193,12 @@
(setf *timer-list* nil))
(defun add-timer (delay fun)
- (push (let ((time (+ (get-internal-real-time) (s->realtime delay))))
- (lambda ()
- (when (>= (get-internal-real-time) time)
- (funcall fun)
- t)))
+ (push (list (let ((time (+ (get-internal-real-time) (s->realtime delay))))
+ (lambda ()
+ (when (>= (get-internal-real-time) time)
+ (funcall fun)
+ t)))
+ fun)
*timer-list*))
(defmacro with-timer ((delay) &body body)
@@ -207,9 +209,13 @@
(defun process-timers ()
(dolist (timer *timer-list*)
- (when (funcall timer)
+ (when (funcall (first timer))
(setf *timer-list* (remove timer *timer-list* :test #'equal)))))
+(defun erase-timer (fun)
+ (dolist (timer *timer-list*)
+ (when (equal fun (second timer))
+ (setf *timer-list* (remove timer *timer-list* :test #'equal)))))
(defun timer-test-loop ()
(loop
@@ -217,6 +223,20 @@
(process-timers)
(sleep 0.5)))
+;;(defun plop ()
+;; (princ 'plop)
+;; (erase-timer #'toto))
+;;
+;;(defun toto ()
+;; (princ 'toto)
+;; (add-timer 5 #'toto))
+;;
+;;(add-timer 5 #'toto)
+;;(add-timer 30 #'plop)
+;;
+;;(timer-test-loop)
+
+
;;;,-----
;;;| Debuging tools
More information about the clfswm-cvs
mailing list