[clfswm-cvs] r289 - in clfswm: . src
Philippe Brochard
pbrochard at common-lisp.net
Mon Aug 16 21:23:20 UTC 2010
Author: pbrochard
Date: Mon Aug 16 17:23:20 2010
New Revision: 289
Log:
src/*.lisp: Replace the case to handle event with a more (tricky) lispy method which bind a function to each keywords associated to graphics events. Remove event handler hooks as they're not needed anymore (To replace them: use closure and define-handler).
Modified:
clfswm/ChangeLog
clfswm/TODO
clfswm/clfswm.asd
clfswm/load.lisp
clfswm/src/bindings-second-mode.lisp
clfswm/src/bindings.lisp
clfswm/src/clfswm-circulate-mode.lisp
clfswm/src/clfswm-generic-mode.lisp
clfswm/src/clfswm-info.lisp
clfswm/src/clfswm-query.lisp
clfswm/src/clfswm-second-mode.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 Mon Aug 16 17:23:20 2010
@@ -1,3 +1,15 @@
+2010-08-16 Philippe Brochard <pbrochard at common-lisp.net>
+
+ * src/package.lisp: Remove event handler hooks as they're not
+ needed anymore (To replace them: use closure and define-handler).
+
+ * src/xlib-util.lisp (move-window, resize-window)
+ (wait-mouse-button-release): Use a generic mode.
+
+ * src/*.lisp: Replace the case to handle event with a more (tricky)
+ lispy method which bind a function to each keywords associated
+ to graphics events.
+
2010-07-23 Philippe Brochard <pbrochard at common-lisp.net>
* src/clfswm-util.lisp (delete-current-child): Invert bindings and
Modified: clfswm/TODO
==============================================================================
--- clfswm/TODO (original)
+++ clfswm/TODO Mon Aug 16 17:23:20 2010
@@ -7,16 +7,7 @@
===============
Should handle these soon.
-- Remote access to the clfswm REPL [Philippe]
- this can be done with net.lisp or via xprop (ie the Stumpwm way).
- Protocol:
- - start-server => create a new file /tmp/clfswm-server-port with right (rw-------)
- and place a key which change on each connection.
- - client must read this file and send the key before using the command line.
- - server change its key when the connection is done.
- - add a minimal cript in the protocol (for example a rotN) with N coded in the key.
-
-
+Nothing here :)
MAYBE
=====
@@ -37,6 +28,6 @@
* up
* down
-- Undo/redo (any idea to implement this is welcome)
+- Undo/redo
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Mon Aug 16 17:23:20 2010
@@ -31,10 +31,10 @@
:depends-on ("package" "config" "xlib-util" "keysyms"))
(:file "clfswm-autodoc"
:depends-on ("package" "clfswm-keys" "my-html" "tools" "config"))
- (:file "clfswm-generic-mode"
- :depends-on ("package" "tools" "xlib-util"))
(:file "clfswm-internal"
:depends-on ("xlib-util" "clfswm-keys" "netwm-util" "tools" "config"))
+ (:file "clfswm-generic-mode"
+ :depends-on ("package" "tools" "xlib-util" "clfswm-internal"))
(:file "clfswm-circulate-mode"
:depends-on ("xlib-util" "clfswm-keys" "clfswm-generic-mode"
"clfswm-internal" "netwm-util" "tools" "config"))
Modified: clfswm/load.lisp
==============================================================================
--- clfswm/load.lisp (original)
+++ clfswm/load.lisp Mon Aug 16 17:23:20 2010
@@ -49,6 +49,9 @@
(push *base-dir* asdf:*central-registry*)
+;;;; Uncomment the line above if you want to follow the
+;;;; handle event mecanism.
+;;(pushnew :event-debug *features*)
(asdf:oos 'asdf:load-op :clfswm)
@@ -61,8 +64,8 @@
;;(produce-all-docs)
-;;; For debuging: start Xnest or Zephyr and
-;;; add the lines above in a dot-clfswmrc-debug file
+;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest
+;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file
;;; mod-2 is the numlock key on some keyboards.
;;(setf *default-modifiers* '(:mod-2))
;;
Modified: clfswm/src/bindings-second-mode.lisp
==============================================================================
--- clfswm/src/bindings-second-mode.lisp (original)
+++ clfswm/src/bindings-second-mode.lisp Mon Aug 16 17:23:20 2010
@@ -154,21 +154,6 @@
(add-hook *binding-hook* 'set-default-second-keys)
-;; For a French azery keyboard:
-;;(undefine-second-multi-keys (#\1 :mod-1) (#\2 :mod-1) (#\3 :mod-1)
-;; (#\4 :mod-1) (#\5 :mod-1) (#\6 :mod-1)
-;; (#\7 :mod-1) (#\8 :mod-1) (#\9 :mod-1) (#\0 :mod-1))
-;;(define-second-key ("ampersand" :mod-1) 'bind-or-jump 1)
-;;(define-second-key ("eacute" :mod-1) 'bind-or-jump 2)
-;;(define-second-key ("quotedbl" :mod-1) 'bind-or-jump 3)
-;;(define-second-key ("quoteright" :mod-1) 'bind-or-jump 4)
-;;(define-second-key ("parenleft" :mod-1) 'bind-or-jump 5)
-;;(define-second-key ("minus" :mod-1) 'bind-or-jump 6)
-;;(define-second-key ("egrave" :mod-1) 'bind-or-jump 7)
-;;(define-second-key ("underscore" :mod-1) 'bind-or-jump 8)
-;;(define-second-key ("ccedilla" :mod-1) 'bind-or-jump 9)
-;;(define-second-key ("agrave" :mod-1) 'bind-or-jump 10)
-
;;; Mouse action
Modified: clfswm/src/bindings.lisp
==============================================================================
--- clfswm/src/bindings.lisp (original)
+++ clfswm/src/bindings.lisp Mon Aug 16 17:23:20 2010
@@ -83,22 +83,6 @@
(add-hook *binding-hook* 'set-default-main-keys)
-;; For an azery keyboard:
-;;(undefine-main-multi-keys (#\1 :mod-1) (#\2 :mod-1) (#\3 :mod-1)
-;; (#\4 :mod-1) (#\5 :mod-1) (#\6 :mod-1)
-;; (#\7 :mod-1) (#\8 :mod-1) (#\9 :mod-1) (#\0 :mod-1))
-;;(define-main-key ("ampersand" :mod-1) 'bind-or-jump 1)
-;;(define-main-key ("eacute" :mod-1) 'bind-or-jump 2)
-;;(define-main-key ("quotedbl" :mod-1) 'bind-or-jump 3)
-;;(define-main-key ("quoteright" :mod-1) 'bind-or-jump 4)
-;;(define-main-key ("parenleft" :mod-1) 'bind-or-jump 5)
-;;(define-main-key ("minus" :mod-1) 'bind-or-jump 6)
-;;(define-main-key ("egrave" :mod-1) 'bind-or-jump 7)
-;;(define-main-key ("underscore" :mod-1) 'bind-or-jump 8)
-;;(define-main-key ("ccedilla" :mod-1) 'bind-or-jump 9)
-;;(define-main-key ("agrave" :mod-1) 'bind-or-jump 10)
-
-
Modified: clfswm/src/clfswm-circulate-mode.lisp
==============================================================================
--- clfswm/src/clfswm-circulate-mode.lisp (original)
+++ clfswm/src/clfswm-circulate-mode.lisp Mon Aug 16 17:23:20 2010
@@ -190,8 +190,7 @@
(when leave
(leave-circulate-mode))))
-(defun circulate-handle-key-press (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
+(define-handler circulate-mode :key-press (code state)
(unless (funcall-key-from-code *circulate-keys* code state)
(setf *circulate-hit* 0
*circulate-orig* nil
@@ -199,8 +198,7 @@
(funcall-key-from-code *main-keys* code state)))
-(defun circulate-handle-key-release (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
+(define-handler circulate-mode :key-release (code state)
(funcall-key-from-code *circulate-keys-release* code state))
@@ -237,11 +235,10 @@
(unless grab-keyboard-p
(ungrab-main-keys)
(xgrab-keyboard *root*))
- (generic-mode 'exit-circulate-loop
+ (generic-mode 'circulate-mode 'exit-circulate-loop
:loop-function #'circulate-loop-function
:leave-function #'circulate-leave-function
- :key-press-hook #'circulate-handle-key-press
- :key-release-hook #'circulate-handle-key-release)
+ :original-mode '(main-mode))
(circulate-leave-function)
(unless grab-keyboard-p
(xungrab-keyboard)
@@ -280,133 +277,3 @@
(setf *circulate-orig* (frame-child *circulate-parent*)))
(circulate-mode :brother-direction -1))
-
-;;;; New circulate mode - work in progress
-;;(let ((modifier nil)
-;; (reverse-modifiers nil))
-;; (defun define-circulate-modifier (keysym)
-;; (setf modifier (multiple-value-list (xlib:keysym->keycodes *display* (keysym-name->keysym keysym)))))
-;; (defun define-circulate-reverse-modifier (keysym-list)
-;; (setf reverse-modifiers keysym-list))
-;; (defun select-next-* (orig direction set-fun)
-;; (let ((done nil)
-;; (hit 0))
-;; (labels ((is-reverse-modifier (code state)
-;; (member (keysym->keysym-name (keycode->keysym code (state->modifiers state)))
-;; reverse-modifiers :test #'string=))
-;; (reorder ()
-;; (let ((elem (nth (mod (incf hit direction) (length orig)) orig)))
-;; (funcall set-fun (nconc (list elem) (remove elem orig)))))
-;; (handle-key-press (&rest event-slots &key code state &allow-other-keys)
-;; (declare (ignore event-slots))
-;; ;;(dbg 'press root code state)
-;; ;;(dbg (first reverse-modifiers) (state->modifiers state))
-;; (if (is-reverse-modifier code state)
-;; (setf direction -1)
-;; (reorder)))
-;; (handle-key-release (&rest event-slots &key code state &allow-other-keys)
-;; (declare (ignore event-slots))
-;; ;;(dbg 'release root code state)
-;; (when (is-reverse-modifier code state)
-;; (setf direction 1))
-;; (when (member code modifier)
-;; (setf done t)))
-;; (handle-select-next-child-event (&rest event-slots &key display event-key &allow-other-keys)
-;; (declare (ignore display))
-;; (with-xlib-protect
-;; (case event-key
-;; (:key-press (apply #'handle-key-press event-slots))
-;; (:key-release (apply #'handle-key-release event-slots))))
-;; t))
-;; (ungrab-main-keys)
-;; (xgrab-keyboard *root*)
-;; (reorder)
-;; (loop until done do
-;; (with-xlib-protect
-;; (xlib:display-finish-output *display*)
-;; (xlib:process-event *display* :handler #'handle-select-next-child-event)))
-;; (xungrab-keyboard)
-;; (grab-main-keys)))))
-;;
-;;(defun set-select-next-child (new)
-;; (setf (frame-child *current-child*) new)
-;; (show-all-children))
-;;
-;;(defun select-next-child ()
-;; "Select the next child"
-;; (select-next-* (frame-child *current-child*) 1 #'set-select-next-child))
-;;
-;;(defun select-previous-child ()
-;; "Select the previous child"
-;; (select-next-* (frame-child *current-child*) -1 #'set-select-next-child))
-;;
-;;(let ((parent nil))
-;; (defun set-select-next-brother (new)
-;; (let ((frame-is-root? (and (equal *current-root* *current-child*)
-;; (not (equal *current-root* *root-frame*)))))
-;; (if frame-is-root?
-;; (hide-all *current-root*)
-;; (select-current-frame nil))
-;; (setf (frame-child parent) new
-;; *current-child* (frame-selected-child parent))
-;; (when frame-is-root?
-;; (setf *current-root* *current-child*))
-;; (show-all-children *current-root*)))
-;;
-;; (defun select-next-brother ()
-;; "Select the next brother frame"
-;; (setf parent (find-parent-frame *current-child*))
-;; (when (frame-p parent)
-;; (select-next-* (frame-child parent) 1 #'set-select-next-brother)))
-;;
-;; (defun select-previous-brother ()
-;; "Select the previous brother frame"
-;; (setf parent (find-parent-frame *current-child*))
-;; (when (frame-p parent)
-;; (select-next-* (frame-child parent) -1 #'set-select-next-brother))))
-
-
-;;;;; This is only transitional
-;;(defun select-next/previous-child (fun-rotate)
-;; "Select the next/previous child"
-;; (when (frame-p *current-child*)
-;; (unselect-all-frames)
-;; (with-slots (child) *current-child*
-;; (setf child (funcall fun-rotate child)))
-;; (show-all-children)))
-;;
-;;
-;;(defun select-next-child ()
-;; "Select the next child"
-;; (select-next/previous-child #'rotate-list))
-;;
-;;(defun select-previous-child ()
-;; "Select the previous child"
-;; (select-next/previous-child #'anti-rotate-list))
-;;
-;;
-;;(defun select-next/previous-brother (fun-rotate)
-;; "Select the next/previous brother frame"
-;; (let ((frame-is-root? (and (equal *current-root* *current-child*)
-;; (not (equal *current-root* *root-frame*)))))
-;; (if frame-is-root?
-;; (hide-all *current-root*)
-;; (select-current-frame nil))
-;; (let ((parent (find-parent-frame *current-child*)))
-;; (when (frame-p parent)
-;; (with-slots (child) parent
-;; (setf child (funcall fun-rotate child))
-;; (setf *current-child* (frame-selected-child parent)))))
-;; (when frame-is-root?
-;; (setf *current-root* *current-child*))
-;; (show-all-children *current-root*)))
-;;
-;;
-;;(defun select-next-brother ()
-;; "Select the next brother frame"
-;; (select-next/previous-brother #'anti-rotate-list))
-;;
-;;(defun select-previous-brother ()
-;; "Select the previous brother frame"
-;; (select-next/previous-brother #'rotate-list))
-;;;;; end transitional part
Modified: clfswm/src/clfswm-generic-mode.lisp
==============================================================================
--- clfswm/src/clfswm-generic-mode.lisp (original)
+++ clfswm/src/clfswm-generic-mode.lisp Mon Aug 16 17:23:20 2010
@@ -26,46 +26,15 @@
(in-package :clfswm)
-(defun generic-mode (exit-tag &key enter-function loop-function leave-function
- (loop-hook *loop-hook*)
- (button-press-hook *button-press-hook*)
- (button-release-hook *button-release-hook*)
- (motion-notify-hook *motion-notify-hook*)
- (key-press-hook *key-press-hook*)
- (key-release-hook *key-release-hook*)
- (configure-request-hook *configure-request-hook*)
- (configure-notify-hook *configure-notify-hook*)
- (map-request-hook *map-request-hook*)
- (unmap-notify-hook *unmap-notify-hook*)
- (destroy-notify-hook *destroy-notify-hook*)
- (mapping-notify-hook *mapping-notify-hook*)
- (property-notify-hook *property-notify-hook*)
- (create-notify-hook *create-notify-hook*)
- (enter-notify-hook *enter-notify-hook*)
- (exposure-hook *exposure-hook*))
+(defun generic-mode (mode exit-tag &key enter-function loop-function leave-function
+ (loop-hook *loop-hook*) original-mode)
"Enter in a generic mode"
- (labels ((handler-function (&rest event-slots &key display event-key &allow-other-keys)
- (declare (ignore display))
- ;; (dbg event-key)
- (with-xlib-protect
- (case event-key
- (:button-press (call-hook button-press-hook event-slots))
- (:button-release (call-hook button-release-hook event-slots))
- (:motion-notify (call-hook motion-notify-hook event-slots))
- (:key-press (call-hook key-press-hook event-slots))
- (:key-release (call-hook key-release-hook event-slots))
- (:configure-request (call-hook configure-request-hook event-slots))
- (:configure-notify (call-hook configure-notify-hook event-slots))
- (:map-request (call-hook map-request-hook event-slots))
- (:unmap-notify (call-hook unmap-notify-hook event-slots))
- (:destroy-notify (call-hook destroy-notify-hook event-slots))
- (:mapping-notify (call-hook mapping-notify-hook event-slots))
- (:property-notify (call-hook property-notify-hook event-slots))
- (:create-notify (call-hook create-notify-hook event-slots))
- (:enter-notify (call-hook enter-notify-hook event-slots))
- (:exposure (call-hook exposure-hook event-slots))))
- ;;(dbg "Ignore handle event" c event-slots)))
- t))
+ (let ((last-mode *current-event-mode*))
+ (unassoc-keyword-handle-event)
+ (when original-mode
+ (dolist (add-mode (ensure-list original-mode))
+ (assoc-keyword-handle-event add-mode)))
+ (assoc-keyword-handle-event mode)
(nfuncall enter-function)
(unwind-protect
(catch exit-tag
@@ -73,6 +42,8 @@
(call-hook loop-hook)
(nfuncall loop-function)
(xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handler-function :timeout *loop-timeout*)
+ (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*)
(xlib:display-finish-output *display*)))
- (nfuncall leave-function))))
+ (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 Mon Aug 16 17:23:20 2010
@@ -274,83 +274,80 @@
(add-hook *binding-hook* 'set-default-info-mouse)
-;;;,-----
-;;;| Main mode
-;;;`-----
-(defun info-mode (info-list &key (width nil) (height nil))
- "Open the info mode. Info-list is a list of info: One string per line
+(let (info)
+ (define-handler info-mode :key-press (code state)
+ (funcall-key-from-code *info-keys* code state info))
+
+ (define-handler info-mode :motion-notify (window root-x root-y)
+ (unless (compress-motion-notify)
+ (funcall-button-from-code *info-mouse* 'motion (modifiers->state *default-modifiers*)
+ window root-x root-y *fun-press* (list info))))
+
+ (define-handler info-mode :button-press (window root-x root-y code state)
+ (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info)))
+
+ (define-handler info-mode :button-release (window root-x root-y code state)
+ (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info)))
+
+
+
+ (defun info-mode (info-list &key (width nil) (height nil))
+ "Open the info mode. Info-list is a list of info: One string per line
Or for colored output: a list (line_string color)
Or ((1_word color) (2_word color) 3_word (4_word color)...)"
- (when info-list
- (setf *info-selected-item* 0)
- (labels ((compute-size (line)
- (typecase line
- (cons (typecase (first line)
- (cons (let ((val 0))
- (dolist (l line val)
- (incf val (typecase l
- (cons (length (first l)))
- (t (length l)))))))
- (t (length (first line)))))
- (t (length line)))))
- (let* ((font (xlib:open-font *display* *info-font-string*))
- (ilw (xlib:max-char-width font))
- (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1))
- (width (or width
- (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw)
- (xlib:screen-width *screen*))))
- (height (or height
- (min (round (+ (* (length info-list) ilh) (/ ilh 2)))
- (xlib:screen-height *screen*)))))
- (with-placement (*info-mode-placement* x y width height)
- (let* ((pointer-grabbed-p (xgrab-pointer-p))
- (keyboard-grabbed-p (xgrab-keyboard-p))
- (window (xlib:create-window :parent *root*
- :x x :y y
- :width width
- :height height
+ (when info-list
+ (setf *info-selected-item* 0)
+ (labels ((compute-size (line)
+ (typecase line
+ (cons (typecase (first line)
+ (cons (let ((val 0))
+ (dolist (l line val)
+ (incf val (typecase l
+ (cons (length (first l)))
+ (t (length l)))))))
+ (t (length (first line)))))
+ (t (length line)))))
+ (let* ((font (xlib:open-font *display* *info-font-string*))
+ (ilw (xlib:max-char-width font))
+ (ilh (+ (xlib:max-char-ascent font) (xlib:max-char-descent font) 1))
+ (width (or width
+ (min (* (+ (loop for l in info-list maximize (compute-size l)) 2) ilw)
+ (xlib:screen-width *screen*))))
+ (height (or height
+ (min (round (+ (* (length info-list) ilh) (/ ilh 2)))
+ (xlib:screen-height *screen*)))))
+ (with-placement (*info-mode-placement* x y width height)
+ (let* ((pointer-grabbed-p (xgrab-pointer-p))
+ (keyboard-grabbed-p (xgrab-keyboard-p))
+ (window (xlib:create-window :parent *root*
+ :x x :y y
+ :width width
+ :height height
+ :background (get-color *info-background*)
+ :colormap (xlib:screen-default-colormap *screen*)
+ :border-width 1
+ :border (get-color *info-border*)
+ :event-mask '(:exposure)))
+ (gc (xlib:create-gcontext :drawable window
+ :foreground (get-color *info-foreground*)
:background (get-color *info-background*)
- :colormap (xlib:screen-default-colormap *screen*)
- :border-width 1
- :border (get-color *info-border*)
- :event-mask '(:exposure)))
- (gc (xlib:create-gcontext :drawable window
- :foreground (get-color *info-foreground*)
- :background (get-color *info-background*)
- :font font
- :line-style :solid))
- (info (make-info :window window :gc gc :x 0 :y 0 :list info-list
- :font font :ilw ilw :ilh ilh
- :max-x (* (loop for l in info-list maximize (compute-size l)) ilw)
- :max-y (* (length info-list) ilh))))
- (labels ((handle-key (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
- (funcall-key-from-code *info-keys* code state info))
- (handle-motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
- (unless (compress-motion-notify)
- (funcall-button-from-code *info-mouse* 'motion (modifiers->state *default-modifiers*)
- window root-x root-y *fun-press* (list info))))
- (handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys)
- (declare (ignore event-slots))
- (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-press* (list info)))
- (handle-button-release (&rest event-slots &key window root-x root-y code state &allow-other-keys)
- (declare (ignore event-slots))
- (funcall-button-from-code *info-mouse* code state window root-x root-y *fun-release* (list info))))
+ :font font
+ :line-style :solid)))
+ (setf info (make-info :window window :gc gc :x 0 :y 0 :list info-list
+ :font font :ilw ilw :ilh ilh
+ :max-x (* (loop for l in info-list maximize (compute-size l)) ilw)
+ :max-y (* (length info-list) ilh)))
(map-window window)
(draw-info-window info)
(xgrab-pointer *root* 68 69)
(unless keyboard-grabbed-p
(xgrab-keyboard *root*))
(wait-no-key-or-button-press)
- (generic-mode 'exit-info-loop
- :loop-function (lambda ()
- (raise-window (info-window info)))
- :button-press-hook #'handle-button-press
- :button-release-hook #'handle-button-release
- :motion-notify-hook #'handle-motion-notify
- :key-press-hook #'handle-key)
+ (generic-mode 'info-mode 'exit-info-loop
+ :loop-function (lambda ()
+ (raise-window (info-window info)))
+ :original-mode '(main-mode))
(if pointer-grabbed-p
(xgrab-pointer *root* 66 67)
(xungrab-pointer))
Modified: clfswm/src/clfswm-query.lisp
==============================================================================
--- clfswm/src/clfswm-query.lisp (original)
+++ clfswm/src/clfswm-query.lisp Mon Aug 16 17:23:20 2010
@@ -263,16 +263,13 @@
-
-(defun query-handle-key (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
+(define-handler query-mode :key-press (code state)
(unless (funcall-key-from-code *query-keys* code state)
(add-in-query-string code state))
(query-print-string))
-
(defun query-string (message &optional (default ""))
"Query a string from the keyboard. Display msg as prompt"
(let ((grab-keyboard-p (xgrab-keyboard-p))
@@ -284,11 +281,11 @@
(unless grab-keyboard-p
(ungrab-main-keys)
(xgrab-keyboard *root*))
- (generic-mode 'exit-query-loop
+ (generic-mode 'query-mode 'exit-query-loop
:enter-function #'query-enter-function
:loop-function #'query-loop-function
:leave-function #'query-leave-function
- :key-press-hook #'query-handle-key)
+ :original-mode '(main-mode))
(unless grab-keyboard-p
(xungrab-keyboard)
(grab-main-keys))
Modified: clfswm/src/clfswm-second-mode.lisp
==============================================================================
--- clfswm/src/clfswm-second-mode.lisp (original)
+++ clfswm/src/clfswm-second-mode.lisp Mon Aug 16 17:23:20 2010
@@ -47,153 +47,54 @@
-;;; Second mode hooks
-(defun sm-handle-key-press (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
+;;; Second mode handlers
+(define-handler second-mode :key-press (code state)
(funcall-key-from-code *second-keys* code state)
(draw-second-mode-window))
-(defun sm-handle-enter-notify (&rest event-slots &key root-x root-y &allow-other-keys)
- (declare (ignore event-slots root-x root-y))
- ;; (focus-frame-under-mouse root-x root-y)
+(define-handler second-mode :enter-notify ()
(draw-second-mode-window))
-(defun sm-handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler second-mode :motion-notify (window root-x root-y)
(unless (compress-motion-notify)
(funcall-button-from-code *second-mouse* 'motion
(modifiers->state *default-modifiers*)
window root-x root-y *fun-press*)))
-(defun sm-handle-button-press (&rest event-slots &key window root-x root-y code state &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler second-mode :button-press (window root-x root-y code state)
(funcall-button-from-code *second-mouse* code state window root-x root-y *fun-press*)
(draw-second-mode-window))
-(defun sm-handle-button-release (&rest event-slots &key window root-x root-y code state &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler second-mode :button-release (window root-x root-y code state)
(funcall-button-from-code *second-mouse* code state window root-x root-y *fun-release*)
(draw-second-mode-window))
-(defun sm-handle-configure-request (&rest event-slots)
- (apply #'handle-configure-request event-slots)
+(define-handler second-mode :configure-request ()
+ (apply #'handle-event-fun-main-mode-configure-request event-slots)
(draw-second-mode-window))
-(defun sm-handle-configure-notify (&rest event-slots)
- (apply #'handle-configure-notify event-slots)
+(define-handler second-mode :configure-notify ()
(draw-second-mode-window))
-(defun sm-handle-destroy-notify (&rest event-slots)
- (apply #'handle-destroy-notify event-slots)
- (draw-second-mode-window))
-
-(defun sm-handle-map-request (&rest event-slots)
- (apply #'handle-map-request event-slots)
- (draw-second-mode-window))
-
-(defun sm-handle-unmap-notify (&rest event-slots)
- (apply #'handle-unmap-notify event-slots)
- (draw-second-mode-window))
-
-(defun sm-handle-exposure (&rest event-slots)
- (apply #'handle-exposure event-slots)
- (draw-second-mode-window))
-
-
-
-;;(defun sm-handle-property-notify (&rest event-slots &key window &allow-other-keys)
-;; ;;(dbg (xlib:wm-name window))
-;; (draw-second-mode-window))
-
-
-;;; CONFIG: Second mode hooks
-(setf *sm-button-press-hook* 'sm-handle-button-press
- *sm-button-release-hook* 'sm-handle-button-release
- *sm-motion-notify-hook* 'sm-handle-motion-notify
- *sm-key-press-hook* 'sm-handle-key-press
- *sm-configure-request-hook* 'sm-handle-configure-request
- *sm-configure-notify-hook* 'sm-handle-configure-notify
- *sm-destroy-notify-hook* 'sm-handle-destroy-notify
- *sm-enter-notify-hook* 'sm-handle-enter-notify
- *sm-exposure-hook* 'sm-handle-exposure
- *sm-map-request-hook* 'sm-handle-map-request
- *sm-unmap-notify-hook* 'sm-handle-unmap-notify)
+(define-handler second-mode :destroy-notify ()
+ (apply #'handle-event-fun-main-mode-destroy-notify event-slots)
+ (draw-second-mode-window))
+(define-handler second-mode :map-request ()
+ (apply #'handle-event-fun-main-mode-map-request event-slots)
+ (draw-second-mode-window))
+(define-handler second-mode :unmap-notify ()
+ (apply #'handle-event-fun-main-mode-unmap-notify event-slots)
+ (draw-second-mode-window))
+(define-handler second-mode :exposure ()
+ (apply #'handle-event-fun-main-mode-exposure event-slots)
+ (draw-second-mode-window))
-;;(defun sm-handle-event (&rest event-slots &key display event-key &allow-other-keys)
-;; (declare (ignore display))
-;; ;; (dbg event-key)
-;; (with-xlib-protect
-;; (case event-key
-;; (:button-press (call-hook *sm-button-press-hook* event-slots))
-;; (:button-release (call-hook *sm-button-release-hook* event-slots))
-;; (:motion-notify (call-hook *sm-motion-notify-hook* event-slots))
-;; (:key-press (call-hook *sm-key-press-hook* event-slots))
-;; (:configure-request (call-hook *sm-configure-request-hook* event-slots))
-;; (:configure-notify (call-hook *sm-configure-notify-hook* event-slots))
-;; (:map-request (call-hook *sm-map-request-hook* event-slots))
-;; (:unmap-notify (call-hook *sm-unmap-notify-hook* event-slots))
-;; (:destroy-notify (call-hook *sm-destroy-notify-hook* event-slots))
-;; (:mapping-notify (call-hook *sm-mapping-notify-hook* event-slots))
-;; (:property-notify (call-hook *sm-property-notify-hook* event-slots))
-;; (:create-notify (call-hook *sm-create-notify-hook* event-slots))
-;; (:enter-notify (call-hook *sm-enter-notify-hook* event-slots))
-;; (:exposure (call-hook *sm-exposure-hook* event-slots))))
-;; ;;(dbg "Ignore handle event" c event-slots)))
-;; t)
-
-
-
-;;(defun second-key-mode ()
-;; "Switch to editing mode"
-;; ;;(dbg "Second key ignore" c)))))
-;; (setf *in-second-mode* t
-;; *sm-window* (xlib:create-window :parent *root*
-;; :x (truncate (/ (- (xlib:screen-width *screen*) *sm-width*) 2))
-;; :y 0
-;; :width *sm-width* :height *sm-height*
-;; :background (get-color *sm-background-color*)
-;; :border-width 1
-;; :border (get-color *sm-border-color*)
-;; :colormap (xlib:screen-default-colormap *screen*)
-;; :event-mask '(:exposure))
-;; *sm-font* (xlib:open-font *display* *sm-font-string*)
-;; *sm-gc* (xlib:create-gcontext :drawable *sm-window*
-;; :foreground (get-color *sm-foreground-color*)
-;; :background (get-color *sm-background-color*)
-;; :font *sm-font*
-;; :line-style :solid))
-;; (xlib:map-window *sm-window*)
-;; (draw-second-mode-window)
-;; (no-focus)
-;; (ungrab-main-keys)
-;; (xgrab-keyboard *root*)
-;; (xgrab-pointer *root* 66 67)
-;; (unwind-protect
-;; (catch 'exit-second-loop
-;; (loop
-;; (raise-window *sm-window*)
-;; (xlib:display-finish-output *display*)
-;; (xlib:process-event *display* :handler #'sm-handle-event)
-;; (xlib:display-finish-output *display*)))
-;; (xlib:free-gcontext *sm-gc*)
-;; (xlib:close-font *sm-font*)
-;; (xlib:destroy-window *sm-window*)
-;; (xungrab-keyboard)
-;; (xungrab-pointer)
-;; (grab-main-keys)
-;; (show-all-children)
-;; (display-all-frame-info))
-;; (wait-no-key-or-button-press)
-;; (when *second-mode-program*
-;; (do-shell *second-mode-program*)
-;; (setf *second-mode-program* nil))
-;; (setf *in-second-mode* nil))
(defun sm-enter-function ()
@@ -238,29 +139,13 @@
(setf *second-mode-program* nil))
(setf *in-second-mode* nil))
-
(defun second-key-mode ()
"Switch to editing mode"
- (generic-mode 'exit-second-loop
+ (generic-mode 'second-mode
+ 'exit-second-loop
:enter-function #'sm-enter-function
:loop-function #'sm-loop-function
- :leave-function #'sm-leave-function
- :button-press-hook *sm-button-press-hook*
- :button-release-hook *sm-button-release-hook*
- :key-press-hook *sm-key-press-hook*
- :key-release-hook *sm-key-release-hook*
- :motion-notify-hook *sm-motion-notify-hook*
- :configure-request-hook *sm-configure-request-hook*
- :configure-notify-hook *sm-configure-notify-hook*
- :map-request-hook *sm-map-request-hook*
- :unmap-notify-hook *sm-unmap-notify-hook*
- :destroy-notify-hook *sm-destroy-notify-hook*
- :mapping-notify-hook *sm-mapping-notify-hook*
- :property-notify-hook *sm-property-notify-hook*
- :create-notify-hook *sm-create-notify-hook*
- :enter-notify-hook *sm-enter-notify-hook*
- :exposure-hook *sm-exposure-hook*))
-
+ :leave-function #'sm-leave-function))
(defun leave-second-mode ()
"Leave second mode"
Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp (original)
+++ clfswm/src/clfswm-util.lisp Mon Aug 16 17:23:20 2010
@@ -680,13 +680,6 @@
;;;;;,-----
;;;;;| Various definitions
;;;;;`-----
-;;(defun stop-all-pending-actions ()
-;; "Stop all pending actions (actions like open in new workspace/frame)"
-;; (setf *open-next-window-in-new-workspace* nil
-;; *open-next-window-in-new-frame* nil
-;; *arrow-action* nil
-;; *pager-arrow-action* nil))
-;;
(defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html"))
"Show current keys and buttons bindings"
Modified: clfswm/src/clfswm.lisp
==============================================================================
--- clfswm/src/clfswm.lisp (original)
+++ clfswm/src/clfswm.lisp Mon Aug 16 17:23:20 2010
@@ -26,38 +26,24 @@
(in-package :clfswm)
-
-
-
-;;; Main mode hooks
-(defun handle-key-press (&rest event-slots &key root code state &allow-other-keys)
- (declare (ignore event-slots root))
+(define-handler main-mode :key-press (code state)
(funcall-key-from-code *main-keys* code state))
-
-(defun handle-button-press (&rest event-slots &key code state window root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :button-press (code state window root-x root-y)
(unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-press*)
(replay-button-event)))
-
-
-(defun handle-button-release (&rest event-slots &key code state window root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :button-release (code state window root-x root-y)
(unless (funcall-button-from-code *main-mouse* code state window root-x root-y *fun-release*)
(replay-button-event)))
-(defun handle-motion-notify (&rest event-slots &key window root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :motion-notify (window root-x root-y)
(unless (compress-motion-notify)
(funcall-button-from-code *main-mouse* 'motion
(modifiers->state *default-modifiers*)
window root-x root-y *fun-press*)))
-
-(defun handle-configure-request (&rest event-slots &key stack-mode #|parent|# window #|above-sibling|#
- x y width height border-width value-mask &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :configure-request (stack-mode window x y width height border-width value-mask)
(labels ((has-x (mask) (= 1 (logand mask 1)))
(has-y (mask) (= 2 (logand mask 2)))
(has-w (mask) (= 4 (logand mask 4)))
@@ -86,17 +72,7 @@
(case stack-mode
(:above (raise-window window))))))))
-
-
-
-(defun handle-configure-notify (&rest event-slots)
- (declare (ignore event-slots)))
-
-
-
-
-(defun handle-map-request (&rest event-slots &key window send-event-p &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :map-request (window send-event-p)
(unless send-event-p
(unhide-window window)
(process-new-window window)
@@ -104,29 +80,21 @@
(unless (null-size-window-p window)
(show-all-children))))
-
-
-(defun handle-unmap-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :unmap-notify (send-event-p event-window window)
(unless (and (not send-event-p)
(not (xlib:window-equal window event-window)))
(when (find-child window *root-frame*)
(delete-child-in-all-frames window)
(show-all-children))))
-
-(defun handle-destroy-notify (&rest event-slots &key send-event-p event-window window &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :destroy-notify (send-event-p event-window window)
(unless (or send-event-p
(xlib:window-equal window event-window))
(when (find-child window *root-frame*)
(delete-child-in-all-frames window)
(show-all-children))))
-
-
-(defun handle-enter-notify (&rest event-slots &key window root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :enter-notify (window root-x root-y)
(unless (and (> root-x (- (xlib:screen-width *screen*) 3))
(> root-y (- (xlib:screen-height *screen*) 3)))
(case (if (frame-p *current-child*)
@@ -146,62 +114,11 @@
(focus-all-children child parent)
(show-all-children)))))))
-
-
-
-(defun handle-exposure (&rest event-slots &key window &allow-other-keys)
- (declare (ignore event-slots))
+(define-handler main-mode :exposure (window)
(awhen (find-frame-window window *current-root*)
(display-frame-info it)))
-(defun handle-create-notify (&rest event-slots)
- (declare (ignore event-slots)))
-
-
-
-
-
-;;; CONFIG: Main mode hooks
-(setf *key-press-hook* 'handle-key-press
- *configure-request-hook* 'handle-configure-request
- *configure-notify-hook* 'handle-configure-notify
- *destroy-notify-hook* 'handle-destroy-notify
- *enter-notify-hook* 'handle-enter-notify
- *exposure-hook* 'handle-exposure
- *map-request-hook* 'handle-map-request
- *unmap-notify-hook* 'handle-unmap-notify
- *create-notify-hook* 'handle-create-notify
- *button-press-hook* 'handle-button-press
- *button-release-hook* 'handle-button-release
- *motion-notify-hook* 'handle-motion-notify)
-
-
-
-
-(defun handle-event (&rest event-slots &key display event-key &allow-other-keys)
- (declare (ignore display))
- ;;(dbg event-key)
- (with-xlib-protect
- (case event-key
- (:button-press (call-hook *button-press-hook* event-slots))
- (:button-release (call-hook *button-release-hook* event-slots))
- (:motion-notify (call-hook *motion-notify-hook* event-slots))
- (:key-press (call-hook *key-press-hook* event-slots))
- (:configure-request (call-hook *configure-request-hook* event-slots))
- (:configure-notify (call-hook *configure-notify-hook* event-slots))
- (:map-request (call-hook *map-request-hook* event-slots))
- (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
- (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
- (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
- (:property-notify (call-hook *property-notify-hook* event-slots))
- (:create-notify (call-hook *create-notify-hook* event-slots))
- (:enter-notify (call-hook *enter-notify-hook* event-slots))
- (:exposure (call-hook *exposure-hook* event-slots))))
- t)
-
-
-
(defun main-loop ()
(loop
(with-xlib-protect
@@ -226,6 +143,7 @@
(defun init-display ()
+ (assoc-keyword-handle-event 'main-mode)
(setf *screen* (first (xlib:display-roots *display*))
*root* (xlib:screen-root *screen*)
*no-focus-window* (xlib:create-window :parent *root* :x 0 :y 0 :width 1 :height 1)
@@ -326,7 +244,9 @@
(ungrab-main-keys)
(xlib:destroy-window *no-focus-window*)
(xlib:free-pixmap *pixmap-buffer*)
- (xlib:close-display *display*)))
+ (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 Mon Aug 16 17:23:20 2010
@@ -173,70 +173,6 @@
(defparameter *menu* (make-menu :name 'main :doc "Main menu"))
-;;; Main mode hooks (set in clfswm.lisp)
-(defparameter *button-press-hook* nil
- "Config(Hook group):")
-(defparameter *button-release-hook* nil
- "Config(Hook group):")
-(defparameter *motion-notify-hook* nil
- "Config(Hook group):")
-(defparameter *key-press-hook* nil
- "Config(Hook group):")
-(defparameter *key-release-hook* nil
- "Config(Hook group):")
-(defparameter *configure-request-hook* nil
- "Config(Hook group):")
-(defparameter *configure-notify-hook* nil
- "Config(Hook group):")
-(defparameter *create-notify-hook* nil
- "Config(Hook group):")
-(defparameter *destroy-notify-hook* nil
- "Config(Hook group):")
-(defparameter *enter-notify-hook* nil
- "Config(Hook group):")
-(defparameter *exposure-hook* nil
- "Config(Hook group):")
-(defparameter *map-request-hook* nil
- "Config(Hook group):")
-(defparameter *mapping-notify-hook* nil
- "Config(Hook group):")
-(defparameter *property-notify-hook* nil
- "Config(Hook group):")
-(defparameter *unmap-notify-hook* nil
- "Config(Hook group):")
-
-
-;;; Second mode hooks (set in clfswm-second-mode.lisp)
-(defparameter *sm-button-press-hook* nil
- "Config(Hook group):")
-(defparameter *sm-button-release-hook* nil
- "Config(Hook group):")
-(defparameter *sm-motion-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-key-press-hook* nil
- "Config(Hook group):")
-(defparameter *sm-key-release-hook* nil
- "Config(Hook group):")
-(defparameter *sm-configure-request-hook* nil
- "Config(Hook group):")
-(defparameter *sm-configure-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-map-request-hook* nil
- "Config(Hook group):")
-(defparameter *sm-unmap-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-destroy-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-mapping-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-property-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-create-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-enter-notify-hook* nil
- "Config(Hook group):")
-(defparameter *sm-exposure-hook* nil
- "Config(Hook group):")
(defparameter *binding-hook* nil
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Mon Aug 16 17:23:20 2010
@@ -34,6 +34,7 @@
:nfuncall
:pfuncall
:symbol-search
+ :symb
:call-hook
:add-hook
:remove-hook
@@ -127,6 +128,16 @@
"Search the string 'search' in the symbol name of 'symbol'"
(search search (symbol-name symbol) :test #'string-equal))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun mkstr (&rest args)
+ (with-output-to-string (s)
+ (dolist (a args)
+ (princ a s))))
+
+ (defun symb (&rest args)
+ (values (intern (apply #'mkstr args)))))
+
+
;;;,-----
;;;| Minimal hook
;;;`-----
Modified: clfswm/src/xlib-util.lisp
==============================================================================
--- clfswm/src/xlib-util.lisp (original)
+++ clfswm/src/xlib-util.lisp Mon Aug 16 17:23:20 2010
@@ -70,7 +70,84 @@
, at body)
((or xlib:match-error xlib:window-error xlib:drawable-error) (c)
(declare (ignore c)))))
- ;;(dbg c ',body))))
+;;(dbg c ',body))))
+
+
+
+
+;;;
+;;; Events management functions.
+;;;
+(defparameter *unhandled-events* nil)
+(defparameter *current-event-mode* nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun keyword->handle-event (mode keyword)
+ (symb 'handle-event-fun "-" mode "-" keyword)))
+
+(defun handle-event->keyword (symbol)
+ (let* ((name (string-downcase (symbol-name symbol)))
+ (pos (search "handle-event-fun-" name)))
+ (when (and pos (zerop pos))
+ (let ((pos-mod (search "mode" name)))
+ (when pos-mod
+ (values (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword)
+ (subseq name (length "handle-event-fun-") (1- pos-mod))))))))
+
+
+(defmacro with-handle-event-symbol ((mode) &body body)
+ "Bind symbol to all handle event functions available in mode"
+ `(let ((pattern (format nil "handle-event-fun-~A" ,mode)))
+ (with-all-internal-symbols (symbol :clfswm)
+ (let ((pos (symbol-search pattern symbol)))
+ (when (and pos (zerop pos))
+ , at body)))))
+
+
+(defun find-handle-event-function (&optional (mode ""))
+ "Print all handle event functions available in mode"
+ (with-handle-event-symbol (mode)
+ (print symbol)))
+
+(defun assoc-keyword-handle-event (mode)
+ "Associate all keywords in mode to their corresponding handle event functions.
+For example: main-mode :key-press is bound to handle-event-fun-main-mode-key-press"
+ (setf *current-event-mode* mode)
+ (with-handle-event-symbol (mode)
+ (let ((keyword (handle-event->keyword symbol)))
+ (when (fboundp symbol)
+ #+:event-debug
+ (format t "~&Associating: ~S with ~S~%" symbol keyword)
+ (setf (symbol-function keyword) (symbol-function symbol))))))
+
+(defun unassoc-keyword-handle-event (&optional (mode ""))
+ "Unbound all keywords from their corresponding handle event functions."
+ (setf *current-event-mode* nil)
+ (with-handle-event-symbol (mode)
+ (let ((keyword (handle-event->keyword symbol)))
+ (when (fboundp keyword)
+ #+:event-debug
+ (format t "~&Unassociating: ~S ~S~%" symbol keyword)
+ (fmakunbound keyword)))))
+
+(defmacro define-handler (mode keyword args &body body)
+ "Like a defun but with a name expanded as handle-event-fun-'mode'-'keyword'
+For example (define-handler main-mode :key-press (args) ...)
+Expand in handle-event-fun-main-mode-key-press"
+ `(defun ,(keyword->handle-event mode keyword) (&rest event-slots &key #+:event-debug event-key , at args &allow-other-keys)
+ (declare (ignorable event-slots))
+ #+:event-debug (print (list *current-event-mode* event-key))
+ , at body))
+
+
+(defun handle-event (&rest event-slots &key event-key &allow-other-keys)
+ (with-xlib-protect
+ (if (fboundp event-key)
+ (apply event-key event-slots)
+ #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)))
+ t)
+
+
@@ -241,21 +318,6 @@
;;
;;(defsetf net-wm-state (window &key (mode :replace)) (states)
;; `(set-atoms-property ,window ,states :_NET_WM_STATE :mode ,mode))
-;;
-;;
-;;
-;;(defun hide-window (window)
-;; (when window
-;; (with-xlib-protect
-;; (let ((net-wm-state (net-wm-state window)))
-;; (dbg net-wm-state)
-;; (pushnew :_net_wm_state_hidden net-wm-state)
-;; (setf (net-wm-state window) net-wm-state)
-;; (dbg (net-wm-state window)))
-;; (setf (window-state window) +iconic-state+
-;; (xlib:window-event-mask window) (remove :structure-notify *window-events*))
-;; (xlib:unmap-window window)
-;; (setf (xlib:window-event-mask window) *window-events*))))
(defun hide-window (window)
@@ -429,32 +491,6 @@
(defun ungrab-all-keys (window)
(xlib:ungrab-key window :any :modifiers :any))
-;;(defun grab-all-keys (window)
-;; (ungrab-all-keys window)
-;; (dolist (modifiers '(:control :mod-1 :shift))
-;; (xlib:grab-key window :any
-;; :modifiers (list modifiers)
-;; :owner-p nil
-;; :sync-pointer-p nil
-;; :sync-keyboard-p t)))
-
-;;(defun grab-all-keys (window)
-;; (ungrab-all-keys window)
-;; (xlib:grab-key window :any
-;; :modifiers :any
-;; :owner-p nil
-;; :sync-pointer-p nil
-;; :sync-keyboard-p t))
-
-
-
-
-;;(defun stop-keyboard-event ()
-;; (xlib:allow-events *display* :sync-keyboard))
-;;
-;;(defun replay-keyboard-event ()
-;; (xlib:allow-events *display* :replay-keyboard))
-
(defun stop-button-event ()
(xlib:allow-events *display* :sync-pointer))
@@ -468,114 +504,88 @@
+
+
;;; Mouse action on window
-(defun move-window (window orig-x orig-y &optional additional-fn additional-arg)
- (raise-window window)
- (let ((done nil)
- (dx (- (xlib:drawable-x window) orig-x))
- (dy (- (xlib:drawable-y window) orig-y))
- (pointer-grabbed-p (xgrab-pointer-p)))
- (labels ((motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
- (unless (compress-motion-notify)
- (setf (xlib:drawable-x window) (+ root-x dx)
- (xlib:drawable-y window) (+ root-y dy))
- (when additional-fn
- (apply additional-fn additional-arg))))
- (handle-event (&rest event-slots &key event-key &allow-other-keys)
- (case event-key
- (:motion-notify (apply #'motion-notify event-slots))
- (:button-release (setf done t))
- (:configure-request (call-hook *configure-request-hook* event-slots))
- (:configure-notify (call-hook *configure-notify-hook* event-slots))
- (:map-request (call-hook *map-request-hook* event-slots))
- (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
- (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
- (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
- (:property-notify (call-hook *property-notify-hook* event-slots))
- (:create-notify (call-hook *create-notify-hook* event-slots)))
- t))
+(let (add-fn add-arg dx dy window)
+ (define-handler move-window-mode :motion-notify (root-x root-y)
+ (unless (compress-motion-notify)
+ (setf (xlib:drawable-x window) (+ root-x dx)
+ (xlib:drawable-y window) (+ root-y dy))
+ (when add-fn
+ (apply add-fn add-arg))))
+
+ (define-handler move-window-mode :button-release ()
+ (throw 'exit-move-window-mode nil))
+
+ (defun move-window (orig-window orig-x orig-y &optional additional-fn additional-arg)
+ (setf window orig-window
+ add-fn additional-fn
+ add-arg additional-arg
+ dx (- (xlib:drawable-x window) orig-x)
+ dy (- (xlib:drawable-y window) orig-y))
+ (raise-window window)
+ (let ((pointer-grabbed-p (xgrab-pointer-p)))
(unless pointer-grabbed-p
(xgrab-pointer *root* nil nil))
(when additional-fn
(apply additional-fn additional-arg))
- (loop until done
- do (with-xlib-protect
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*)))
+ (generic-mode 'move-window-mode 'exit-move-window-mode
+ :original-mode '(main-mode))
(unless pointer-grabbed-p
(xungrab-pointer)))))
-(defun resize-window (window orig-x orig-y &optional additional-fn additional-arg)
- (raise-window window)
- (let* ((done nil)
- (orig-width (xlib:drawable-width window))
- (orig-height (xlib:drawable-height window))
- (pointer-grabbed-p (xgrab-pointer-p))
- (hints (xlib:wm-normal-hints window))
- (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0))
- (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0))
- (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) most-positive-fixnum))
- (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) most-positive-fixnum)))
- (labels ((motion-notify (&rest event-slots &key root-x root-y &allow-other-keys)
- (declare (ignore event-slots))
- (unless (compress-motion-notify)
- (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x orig-x)) 10 min-width) max-width)
- (xlib:drawable-height window) (min (max (+ orig-height (- root-y orig-y)) 10 min-height) max-height))
- (when additional-fn
- (apply additional-fn additional-arg))))
- (handle-event (&rest event-slots &key event-key &allow-other-keys)
- (case event-key
- (:motion-notify (apply #'motion-notify event-slots))
- (:button-release (setf done t))
- (:configure-request (call-hook *configure-request-hook* event-slots))
- (:configure-notify (call-hook *configure-notify-hook* event-slots))
- (:map-request (call-hook *map-request-hook* event-slots))
- (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
- (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
- (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
- (:property-notify (call-hook *property-notify-hook* event-slots))
- (:create-notify (call-hook *create-notify-hook* event-slots)))
- t))
+(let (add-fn add-arg window
+ o-x o-y
+ orig-width orig-height
+ min-width max-width
+ min-height max-height)
+ (define-handler resize-window-mode :motion-notify (root-x root-y)
+ (unless (compress-motion-notify)
+ (setf (xlib:drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width)
+ (xlib:drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height))
+ (when add-fn
+ (apply add-fn add-arg))))
+
+ (define-handler resize-window-mode :button-release ()
+ (throw 'exit-resize-window-mode nil))
+
+ (defun resize-window (orig-window orig-x orig-y &optional additional-fn additional-arg)
+ (let* ((pointer-grabbed-p (xgrab-pointer-p))
+ (hints (xlib:wm-normal-hints orig-window)))
+ (setf window orig-window
+ add-fn additional-fn
+ add-arg additional-arg
+ o-x orig-x
+ o-y orig-y
+ orig-width (xlib:drawable-width window)
+ orig-height (xlib:drawable-height window)
+ min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0)
+ min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0)
+ max-width (or (and hints (xlib:wm-size-hints-max-width hints)) most-positive-fixnum)
+ max-height (or (and hints (xlib:wm-size-hints-max-height hints)) most-positive-fixnum))
+ (raise-window window)
(unless pointer-grabbed-p
(xgrab-pointer *root* nil nil))
(when additional-fn
(apply additional-fn additional-arg))
- (loop until done
- do (with-xlib-protect
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*)))
+ (generic-mode 'resize-window-mode 'exit-resize-window-mode
+ :original-mode '(main-mode))
(unless pointer-grabbed-p
(xungrab-pointer)))))
-
-
+(define-handler wait-mouse-button-release-mode :button-release ()
+ (throw 'exit-wait-mouse-button-release-mode nil))
(defun wait-mouse-button-release (&optional cursor-char cursor-mask-char)
- (let ((done nil)
- (pointer-grabbed-p (xgrab-pointer-p)))
- (labels ((handle-event (&rest event-slots &key event-key &allow-other-keys)
- (case event-key
- (:button-release (setf done t))
- (:configure-request (call-hook *configure-request-hook* event-slots))
- (:configure-notify (call-hook *configure-notify-hook* event-slots))
- (:map-request (call-hook *map-request-hook* event-slots))
- (:unmap-notify (call-hook *unmap-notify-hook* event-slots))
- (:destroy-notify (call-hook *destroy-notify-hook* event-slots))
- (:mapping-notify (call-hook *mapping-notify-hook* event-slots))
- (:property-notify (call-hook *property-notify-hook* event-slots))
- (:create-notify (call-hook *create-notify-hook* event-slots)))
- t))
- (unless pointer-grabbed-p
- (xgrab-pointer *root* cursor-char cursor-mask-char))
- (loop until done
- do (with-xlib-protect
- (xlib:display-finish-output *display*)
- (xlib:process-event *display* :handler #'handle-event :timeout *loop-timeout*)))
- (unless pointer-grabbed-p
- (xungrab-pointer)))))
+ (let ((pointer-grabbed-p (xgrab-pointer-p)))
+ (unless pointer-grabbed-p
+ (xgrab-pointer *root* cursor-char cursor-mask-char))
+ (generic-mode 'wait-mouse-button-release 'exit-wait-mouse-button-release-mode)
+ (unless pointer-grabbed-p
+ (xungrab-pointer))))
More information about the clfswm-cvs
mailing list