From c389dc88d4f97b76b873d6ceeff625a79cc4a343 Mon Sep 17 00:00:00 2001 From: Philippe Brochard Date: Wed, 6 Jun 2012 23:05:26 +0200 Subject: [PATCH] src/xlib-util.lisp (handle-event): Add an additional hook event system to handle events in contrib code. --- ChangeLog | 5 ++++ contrib/toolbar.lisp | 39 +++++++++++++++++--------- src/clfswm.lisp | 1 + src/tools.lisp | 12 ++++---- src/xlib-util.lisp | 79 +++++++++++++++++++++++++++++++++++----------------- 5 files changed, 92 insertions(+), 44 deletions(-) diff --git a/ChangeLog b/ChangeLog index af5e2df..f9a2014 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2012-06-06 Philippe Brochard + + * src/xlib-util.lisp (handle-event): Add an additional hook event + system to handle events in contrib code. + 2012-06-03 Philippe Brochard * src/clfswm-placement.lisp: Add an optional border size in all diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp index c2d6280..7f78336 100644 --- a/contrib/toolbar.lisp +++ b/contrib/toolbar.lisp @@ -108,22 +108,34 @@ (:vert (vert-text))))) + +(defun refresh-toolbar (toolbar) + (add-timer (toolbar-refresh-delay toolbar) + (lambda () + (refresh-toolbar toolbar)) + :refresh-toolbar) + (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)) + (dolist (module (toolbar-modules toolbar)) + (let ((fun (toolbar-symbol-fun (first module)))) + (when (fboundp fun) + (funcall fun toolbar module)))) + (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))) + + +(create-event-hook :exposure) + +(defun define-toolbar-hooks (toolbar) + (define-event-hook :exposure (window) + (when (and (xlib:window-p window) (xlib:window-equal (toolbar-window toolbar) window)) + (refresh-toolbar toolbar)))) + + + + (let ((windows-list nil)) (defun is-toolbar-window-p (win) (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal))) - (defun refresh-toolbar (toolbar) - (add-timer (toolbar-refresh-delay toolbar) - (lambda () - (refresh-toolbar toolbar)) - :refresh-toolbar) - (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)) - (dolist (module (toolbar-modules toolbar)) - (let ((fun (toolbar-symbol-fun (first module)))) - (when (fboundp fun) - (funcall fun toolbar module)))) - (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))) - (defun close-toolbar (toolbar) (erase-timer :refresh-toolbar-window) (setf *never-managed-window-list* @@ -175,7 +187,8 @@ (map-window (toolbar-window toolbar)) (raise-window (toolbar-window toolbar)) (refresh-toolbar toolbar) - (xlib:display-finish-output *display*)))))))) + (xlib:display-finish-output *display*) + (define-toolbar-hooks toolbar)))))))) (defun open-all-toolbars () "Open all toolbars" diff --git a/src/clfswm.lisp b/src/clfswm.lisp index 51a44ed..241cec1 100644 --- a/src/clfswm.lisp +++ b/src/clfswm.lisp @@ -292,6 +292,7 @@ (xlib:free-pixmap *pixmap-buffer*) (destroy-all-frames-window) (call-hook *close-hook*) + (clear-event-hooks) (xlib:close-display *display*) #+:event-debug (format t "~2&Unhandled events: ~A~%" *unhandled-events*)))) diff --git a/src/tools.lisp b/src/tools.lisp index 63678d0..40af0b9 100644 --- a/src/tools.lisp +++ b/src/tools.lisp @@ -228,7 +228,9 @@ Return the result of the last hook" (typecase hook (cons (dolist (h hook) (rec h))) - (t (setf result (apply hook args))))))) + (function (setf result (apply hook args))) + (symbol (when (fboundp hook) + (setf result (apply hook args)))))))) (rec hook) result))) @@ -236,14 +238,14 @@ Return the result of the last hook" (defmacro add-new-hook (hook &rest value) "Add a hook. Duplicate it if needed" `(setf ,hook (append (typecase ,hook - (list ,hook) - (t (list ,hook))) - (list ,@value)))) + (list ,hook) + (t (list ,hook))) + (list ,@value)))) (defmacro add-hook (hook &rest value) "Add a hook only if not duplicated" (let ((i (gensym))) - `(dolist (,i (list ,@value) ,hook) + `(dolist (,i (list ,@value)) (unless (member ,i (typecase ,hook (list ,hook) (t (list ,hook)))) diff --git a/src/xlib-util.lisp b/src/xlib-util.lisp index 7e42730..6c4fcff 100644 --- a/src/xlib-util.lisp +++ b/src/xlib-util.lisp @@ -170,36 +170,63 @@ Expand in handle-event-fun-main-mode-key-press" ,@body)) +(defun event-hook-name (event-keyword) + (create-symbol '*event- event-keyword '-hook*)) -;;; Workaround for pixmap error taken from STUMPWM - thanks: -;; XXX: In both the clisp and sbcl clx libraries, sometimes what -;; should be a window will be a pixmap instead. In this case, we -;; need to manually translate it to a window to avoid breakage -;; in stumpwm. So far the only slot that seems to be affected is -;; the :window slot for configure-request and reparent-notify -;; events. It appears as though the hash table of XIDs and clx -;; structures gets out of sync with X or perhaps X assigns a -;; duplicate ID for a pixmap and a window. -(defun make-xlib-window (xobject) - "For some reason the clx xid cache screws up returns pixmaps when -they should be windows. So use this function to make a window out of them." - #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*) - #+(or sbcl ecl openmcl) (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*) - #-(or sbcl clisp ecl openmcl) - (error 'not-implemented)) +(let ((event-hook-list nil)) + (defmacro create-event-hook (event-keyword) + (let ((symb (event-hook-name event-keyword))) + (pushnew symb event-hook-list) + `(defvar ,symb nil))) + + (defmacro add-event-hook (name &rest value) + (let ((symb (event-hook-name name))) + `(add-hook ,symb ,@value))) + + (defun clear-event-hooks () + (dolist (symb event-hook-list) + (makunbound symb)))) + + +(defmacro define-event-hook (event-keyword args &body body) + `(add-event-hook ,event-keyword + (lambda (&rest event-slots &key #+:event-debug event-key ,@args &allow-other-keys) + (declare (ignorable event-slots)) + #+:event-debug (print (list ,event-keyword event-key)) + ,@body))) (defun handle-event (&rest event-slots &key event-key &allow-other-keys) - (with-xlib-protect () - (let ((win (getf event-slots :window))) - (when (and win (not (xlib:window-p win))) - (dbg "Pixmap Workaround! Should be a window: " win) - (setf (getf event-slots :window) (make-xlib-window win)))) - (if (fboundp event-key) - (apply event-key event-slots) - #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)) - (xlib:display-finish-output *display*)) - t) + (labels ((make-xlib-window (xobject) + "For some reason the clx xid cache screws up returns pixmaps when +they should be windows. So use this function to make a window out of them." + ;; Workaround for pixmap error taken from STUMPWM - thanks: + ;; XXX: In both the clisp and sbcl clx libraries, sometimes what + ;; should be a window will be a pixmap instead. In this case, we + ;; need to manually translate it to a window to avoid breakage + ;; in stumpwm. So far the only slot that seems to be affected is + ;; the :window slot for configure-request and reparent-notify + ;; events. It appears as though the hash table of XIDs and clx + ;; structures gets out of sync with X or perhaps X assigns a + ;; duplicate ID for a pixmap and a window. + #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*) + #+(or sbcl ecl openmcl) (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*) + #-(or sbcl clisp ecl openmcl) + (error 'not-implemented))) + (with-xlib-protect () + (catch 'exit-handle-event + (let ((win (getf event-slots :window))) + (when (and win (not (xlib:window-p win))) + (dbg "Pixmap Workaround! Should be a window: " win) + (setf (getf event-slots :window) (make-xlib-window win)))) + (let ((hook-symbol (event-hook-name event-key))) + (when (boundp hook-symbol) + (call-hook (symbol-value hook-symbol) event-slots))) + (if (fboundp event-key) + (apply event-key event-slots) + #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))) + (xlib:display-finish-output *display*)) + t)) -- 2.11.4.GIT