[clfswm-cvs] r298 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Wed Aug 25 19:44:19 UTC 2010
Author: pbrochard
Date: Wed Aug 25 15:44:18 2010
New Revision: 298
Log:
main-loop, generic-mode: Use an xlib:event-listen before processing event with xlib:process-event. This prevent a bug with CLX threaded implementation like sbcl.
Modified:
clfswm/ChangeLog
clfswm/src/clfswm-generic-mode.lisp
clfswm/src/clfswm-info.lisp
clfswm/src/clfswm-query.lisp
clfswm/src/clfswm-util.lisp
clfswm/src/clfswm.lisp
clfswm/src/package.lisp
clfswm/src/tools.lisp
clfswm/src/xlib-util.lisp
Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog (original)
+++ clfswm/ChangeLog Wed Aug 25 15:44:18 2010
@@ -1,3 +1,14 @@
+2010-08-25 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/clfswm-generic-mode.lisp (generic-mode): Use an
+ xlib:event-listen before processing event with
+ xlib:process-event. This prevent a bug with CLX threaded
+ implementation like sbcl.
+
+ * src/clfswm.lisp (main-loop): Use an xlib:event-listen before
+ processing event with xlib:process-event. This prevent a bug with
+ CLX threaded implementation like sbcl.
+
2010-08-17 Philippe Brochard <pbrochard at common-lisp.net>
* contrib/server/key.lisp (ushell-sh): Add ccl and ecl support.
Modified: clfswm/src/clfswm-generic-mode.lisp
==============================================================================
--- clfswm/src/clfswm-generic-mode.lisp (original)
+++ clfswm/src/clfswm-generic-mode.lisp Wed Aug 25 15:44:18 2010
@@ -36,14 +36,16 @@
(assoc-keyword-handle-event add-mode)))
(assoc-keyword-handle-event mode)
(nfuncall enter-function)
- (unwind-protect
- (catch exit-tag
+ (catch exit-tag
+ (unwind-protect
(loop
(call-hook loop-hook)
(nfuncall loop-function)
(xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*)
- (xlib:display-finish-output *display*)))
- (nfuncall leave-function)
- (unassoc-keyword-handle-event)
- (assoc-keyword-handle-event last-mode))))
+ (when (xlib:event-listen *display* *loop-timeout*)
+ (xlib:process-event *display* :handler #'handle-event))
+ (xlib:display-finish-output *display*))
+ (nfuncall leave-function)
+ (unassoc-keyword-handle-event)
+ (assoc-keyword-handle-event last-mode)))))
+
Modified: clfswm/src/clfswm-info.lisp
==============================================================================
--- clfswm/src/clfswm-info.lisp (original)
+++ clfswm/src/clfswm-info.lisp Wed Aug 25 15:44:18 2010
@@ -345,9 +345,9 @@
(xgrab-keyboard *root*))
(wait-no-key-or-button-press)
(generic-mode 'info-mode 'exit-info-loop
- :loop-function (lambda ()
- (raise-window (info-window info)))
- :original-mode '(main-mode))
+ :loop-function (lambda ()
+ (raise-window (info-window info)))
+ :original-mode '(main-mode))
(if pointer-grabbed-p
(xgrab-pointer *root* 66 67)
(xungrab-pointer))
@@ -356,6 +356,7 @@
(xlib:free-gcontext gc)
(xlib:destroy-window window)
(xlib:close-font font)
+ (xlib:display-finish-output *display*)
(display-all-frame-info)
(wait-no-key-or-button-press)
*info-selected-item*)))))))
Modified: clfswm/src/clfswm-query.lisp
==============================================================================
--- clfswm/src/clfswm-query.lisp (original)
+++ clfswm/src/clfswm-query.lisp Wed Aug 25 15:44:18 2010
@@ -78,6 +78,7 @@
(setf *query-return* return)
(throw 'exit-query-loop nil))
+
(defun leave-query-mode-valid ()
(leave-query-mode :Return))
@@ -130,6 +131,7 @@
(wait-no-key-or-button-press))))
+
(defun query-leave-function ()
(xlib:destroy-window *query-window*)
(xlib:close-font *query-font*)
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Wed Aug 25 15:44:18 2010
@@ -320,7 +320,8 @@
(unwind-protect
(loop until done do
(xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-identify :timeout *loop-timeout*))
+ (when (xlib:event-listen *display* *loop-timeout*)
+ (xlib:process-event *display* :handler #'handle-identify)))
(xlib:destroy-window window)
(xlib:close-font font)
(xgrab-pointer *root* 66 67)))))
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Wed Aug 25 15:44:18 2010
@@ -122,9 +122,10 @@
(defun main-loop ()
(loop
(with-xlib-protect
- (call-hook *loop-hook*)
+ (call-hook *loop-hook*)
(xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*))))
+ (when (xlib:event-listen *display* *loop-timeout*)
+ (xlib:process-event *display* :handler #'handle-event)))))
;;(dbg "Main loop finish" c)))))
@@ -238,15 +239,15 @@
(exit-clfswm)))
(when error-msg
(info-mode error-msg))
- (unwind-protect
- (catch 'exit-main-loop
- (main-loop))
- (ungrab-main-keys)
- (xlib:destroy-window *no-focus-window*)
- (xlib:free-pixmap *pixmap-buffer*)
- (xlib:close-display *display*)
- #+:event-debug
- (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))
+ (catch 'exit-main-loop
+ (unwind-protect
+ (main-loop)
+ (ungrab-main-keys)
+ (xlib:destroy-window *no-focus-window*)
+ (xlib:free-pixmap *pixmap-buffer*)
+ (xlib:close-display *display*)
+ #+:event-debug
+ (format t "~2&Unhandled events: ~A~%" *unhandled-events*))))
(defun main (&key (display (or (getenv "DISPLAY") ":0")) protocol
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Wed Aug 25 15:44:18 2010
@@ -27,7 +27,7 @@
(defpackage clfswm
(:use :common-lisp :my-html :tools :version)
- ;;(:shadow :defun)
+;; (:shadow :defun)
(:export :main
:reload-clfswm
:reset-clfswm
@@ -214,7 +214,7 @@
;; For debug - redefine defun
;;(shadow :defun)
-;;
+
;;(defmacro defun (name args &body body)
;; `(progn
;; (format t "defun: ~A ~A~%" ',name ',args)
@@ -228,3 +228,5 @@
;; (format t "Root tree=~A~%All windows=~A~%"
;; (xlib:query-tree *root*) (get-all-windows))
;; (force-output))))))
+
+
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Wed Aug 25 15:44:18 2010
@@ -40,6 +40,7 @@
:remove-hook
:dbg
:dbgnl
+ :dbgc
:with-all-internal-symbols
:export-all-functions :export-all-variables
:export-all-functions-and-variables
@@ -209,7 +210,11 @@
, at forms))
-
+(defun dbgc (obj &optional newline)
+ (princ obj)
+ (when newline
+ (terpri))
+ (force-output))
Modified: clfswm/src/xlib-util.lisp
==============================================================================
--- clfswm/src/xlib-util.lisp (original)
+++ clfswm/src/xlib-util.lisp Wed Aug 25 15:44:18 2010
@@ -69,7 +69,8 @@
(progn
, at body)
((or xlib:match-error xlib:window-error xlib:drawable-error) (c)
- (declare (ignore c)))))
+ (dbg c))))
+ ;;(declare (ignore c)))))
;;(dbg c ',body))))
@@ -117,7 +118,9 @@
(let ((keyword (handle-event->keyword symbol)))
(when (fboundp symbol)
#+:event-debug
- (format t "~&Associating: ~S with ~S~%" symbol keyword)
+ (progn
+ (format t "~&Associating: ~S with ~S~%" symbol keyword)
+ (force-output))
(setf (symbol-function keyword) (symbol-function symbol))))))
(defun unassoc-keyword-handle-event (&optional (mode ""))
@@ -127,7 +130,9 @@
(let ((keyword (handle-event->keyword symbol)))
(when (fboundp keyword)
#+:event-debug
- (format t "~&Unassociating: ~S ~S~%" symbol keyword)
+ (progn
+ (format t "~&Unassociating: ~S ~S~%" symbol keyword)
+ (force-output))
(fmakunbound keyword)))))
(defmacro define-handler (mode keyword args &body body)
@@ -431,7 +436,8 @@
&optional (pointer-mask '(:enter-window :pointer-motion
:button-press :button-release)) owner-p)
"Grab the pointer and set the pointer shape."
- (free-grab-pointer)
+ (when pointer-grabbed
+ (xungrab-pointer))
(setf pointer-grabbed t)
(let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
(black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)))
@@ -444,10 +450,10 @@
:foreground black
:background white))
(xlib:grab-pointer root pointer-mask
- :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil :cursor cursor))
+ :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil :cursor cursor))
(t
(xlib:grab-pointer root pointer-mask
- :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil)))))
+ :owner-p owner-p :sync-keyboard-p nil :sync-pointer-p nil)))))
(defun xungrab-pointer ()
"Remove the grab on the cursor and restore the cursor shape."
@@ -698,12 +704,14 @@
(xgrab-pointer *root* ,cursor ,mask)
(unless keyboard-grabbed
(xgrab-keyboard *root*))
- , at body
- (if pointer-grabbed
- (xgrab-pointer *root* ,old-cursor ,old-mask)
- (xungrab-pointer))
- (unless keyboard-grabbed
- (xungrab-keyboard))))
+ (unwind-protect
+ (progn
+ , at body)
+ (if pointer-grabbed
+ (xgrab-pointer *root* ,old-cursor ,old-mask)
+ (xungrab-pointer))
+ (unless keyboard-grabbed
+ (xungrab-keyboard)))))
@@ -727,7 +735,8 @@
(loop
(let ((key (loop for k across (xlib:query-keymap *display*)
for code from 0
- when (and (plusp k) (not (modifier-p code))) return t))
+ when (and (plusp k) (not (modifier-p code)))
+ return t))
(button (loop for b in (xlib:make-state-keys (nth-value 4 (xlib:query-pointer *root*)))
when (member b '(:button-1 :button-2 :button-3 :button-4 :button-5))
return t)))
More information about the clfswm-cvs
mailing list