Update of /project/eclipse/cvsroot/eclipse
In directory common-lisp.net:/tmp/cvs-serv9206
Modified Files:
input.lisp gestures.lisp virtual-screen.lisp misc.lisp
Log Message:
Fix incorect handling of the states _net_wm_state_{above, below}.
They are permanent as the other states (see inpout.lisp).
It implies that the (setf window-priority) should take those state in account when modifying the stack order (see misc.lisp)
This have as last implication, that we should work with an external list of window for the window circulation keystrokes. Indeed, if one window has the _net_wm_state_above state then it will always be on top of the others. What means, that will stay stuck on this window during circulation. (see minor signature modification of circulate-window in virtual-screen.lisp, and small hack in gestures.lisp)
Date: Thu Nov 13 06:12:28 2003
Author: ihatchondo
Index: eclipse/input.lisp
diff -u eclipse/input.lisp:1.20 eclipse/input.lisp:1.21
--- eclipse/input.lisp:1.20 Sun Oct 12 17:59:17 2003
+++ eclipse/input.lisp Thu Nov 13 06:12:27 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: input.lisp,v 1.20 2003/10/12 21:59:17 ihatchondo Exp $
+;;; $Id: input.lisp,v 1.21 2003/11/13 11:12:27 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
@@ -361,10 +361,15 @@
(maximize-window application 3))
(when (and master (or-eql :_net_wm_state_shaded p1 p2))
(shade master))
- (when (or-eql :_net_wm_state_above p1 p2)
- (put-on-top application))
- (when (or-eql :_net_wm_state_below p1 p2)
- (put-on-bottom application)))))
+ (flet ((set-stack-state (s)
+ (setf (netwm:net-wm-state window)
+ (if (= 0 mode) (remove s p) (pushnew s p)))))
+ (when (or-eql :_net_wm_state_above p1 p2)
+ (set-stack-state :_net_wm_state_above)
+ (put-on-top application))
+ (when (or-eql :_net_wm_state_below p1 p2)
+ (set-stack-state :_net_wm_state_below)
+ (put-on-bottom application))))))
(:_NET_WM_DESKTOP
(let* ((cur-desk (window-desktop-num window))
(new-desk (aref data 0))
Index: eclipse/gestures.lisp
diff -u eclipse/gestures.lisp:1.9 eclipse/gestures.lisp:1.10
--- eclipse/gestures.lisp:1.9 Mon Oct 6 13:57:26 2003
+++ eclipse/gestures.lisp Thu Nov 13 06:12:28 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: gestures.lisp,v 1.9 2003/10/06 17:57:26 ihatchondo Exp $
+;;; $Id: gestures.lisp,v 1.10 2003/11/13 11:12:28 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -329,6 +329,7 @@
(defvar *depth* nil)
(defvar *current-widget-info* nil)
+(defvar *windows* nil)
(defun initialize-circulate-window (root-window dpy)
"Initialize gestures internal hooks before circulating windows."
@@ -341,7 +342,9 @@
(xlib:grab-keyboard root-window)
(unless *current-widget-info*
(setf *current-widget-info* (create-message-box nil :parent root-window)))
- (setf *depth* 0))
+ (let ((i (current-vscreen root-window)))
+ (setf *windows* (reverse (get-screen-content i :iconify-p *cycle-icons-p*))
+ *depth* 0)))
(defun circulate-window-modifier-callback (event)
(when (typep event 'key-release)
@@ -351,30 +354,43 @@
for code = (unless (eq mod :and) (kb:keyname->keycodes *display* mod))
when code
do (remhash (cons (if (listp code) (car code) code) #x8000) map))
- (let ((widget (lookup-widget (input-focus *display*))))
+ (let ((widget (lookup-widget (car *windows*))))
(when widget (setf (application-wants-iconic-p widget) nil)))
(xlib:unmap-window (widget-window *current-widget-info*))
- (setf *depth* nil)))
+ (setf *depth* nil *windows* nil)))
-(defun circulate-window-up-and-down (event dir)
- "Make window circulating according to the `dir' argument (or :above :below)."
+(defun circulate-window-up-and-down (event direction)
+ "Circulate windows according to the `direction' argument (or :above :below)."
(when (typep event 'key-press)
(with-slots ((root-win root)) event
(unless *depth*
(initialize-circulate-window root-win (xlib:drawable-display root-win)))
- (if (eq dir :above) (incf *depth*) (decf *depth*))
- (let ((widget (circulate-window
- (lookup-widget root-win)
- :direction dir
- :nth *depth*
- :icon-p *cycle-icons-p*)))
- (when (and *verbose-window-cycling* widget)
- (with-slots (window)
- (if (decoration-p widget) (get-child widget :application) widget)
- (setf (message-pixmap *current-widget-info*)
- (clx-ext::wm-hints-icon-pixmap window))
- (setf (button-item-to-draw *current-widget-info*) (wm-name window)))
- (with-slots (window) *current-widget-info*
- (xlib:map-window window)
- (setf (xlib:window-priority window) :above)
- (repaint *current-widget-info* nil nil)))))))
+ (unless *windows* (return-from circulate-window-up-and-down nil))
+ (circulate-window
+ (lookup-widget root-win)
+ :direction direction
+ :nth (if (eq direction :above) (incf *depth*) (decf *depth*))
+ :windows *windows*
+ :icon-p *cycle-icons-p*))
+ (let* ((length (length *windows*))
+ (depth-aux (mod *depth* length)))
+ (cond
+ ((<= length 1) nil)
+ ((and (eq direction :above) (= depth-aux 0))
+ (setf (cdr (last *windows*)) (list (pop *windows*))))
+ ((and (eq direction :below) (= depth-aux (1- length)))
+ (let ((penultimate-cons (last *windows* 2)))
+ (push (cadr penultimate-cons) *windows*)
+ (setf (cdr penultimate-cons) nil)))
+ (t
+ (when (eq direction :below) (incf depth-aux))
+ (rotatef (nth 0 *windows*) (nth depth-aux *windows*)))))
+ (when (and *verbose-window-cycling* (car *windows*))
+ (with-slots (window) (lookup-widget (car *windows*))
+ (setf (message-pixmap *current-widget-info*)
+ (clx-ext::wm-hints-icon-pixmap window))
+ (setf (button-item-to-draw *current-widget-info*) (wm-name window)))
+ (with-slots (window) *current-widget-info*
+ (xlib:map-window window)
+ (setf (xlib:window-priority window) :above)
+ (repaint *current-widget-info* nil nil)))))
Index: eclipse/virtual-screen.lisp
diff -u eclipse/virtual-screen.lisp:1.10 eclipse/virtual-screen.lisp:1.11
--- eclipse/virtual-screen.lisp:1.10 Thu Oct 9 07:39:41 2003
+++ eclipse/virtual-screen.lisp Thu Nov 13 06:12:28 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: virtual-screen.lisp,v 1.10 2003/10/09 11:39:41 ihatchondo Exp $
+;;; $Id: virtual-screen.lisp,v 1.11 2003/11/13 11:12:28 ihatchondo Exp $
;;;
;;; Copyright (C) 2002 Iban HATCHONDO
;;; contact : hatchond(a)yahoo.fr
@@ -129,14 +129,16 @@
(unless given-p
(xlib:set-input-focus *display* :pointer-root :pointer-root))))
-(defmethod circulate-window ((root root) &key direction (nth 0) icon-p)
- (let* ((wins (reverse (get-screen-content (current-desk) :iconify-p icon-p)))
- (length (length wins)))
- (or wins (return-from circulate-window nil))
+(defmethod circulate-window
+ ((root root) &key direction (nth 0) icon-p windows (desk (current-desk)))
+ (unless windows
+ (setf windows (reverse (get-screen-content desk :iconify-p icon-p))))
+ (or windows (return-from circulate-window nil))
+ (let ((length (length windows)))
(setf nth (mod nth length))
(let ((above-p (eq direction :above))
- (focus-dest (nth nth wins))
- (first (lookup-widget (car wins))))
+ (focus-dest (nth nth windows))
+ (first (lookup-widget (car windows))))
;; Grab the pointer to avoid enter notify events race concurrence
;; between the window hierarchy change and the warp-pointer call.
(with-pointer-grabbed ((widget-window root) nil)
@@ -151,15 +153,15 @@
(setf (window-priority window sibling) priority)))
(cond ((= length 1) (set-window-priority focus-dest nil :above))
((= nth 0)
- (let ((sibling (if above-p (last wins) (cdr wins))))
- (set-window-priority (car wins) (car sibling) :below)
- (setf focus-dest (second wins))))
+ (let ((sibling (if above-p (last windows) (cdr windows))))
+ (set-window-priority (car windows) (car sibling) :below)
+ (setf focus-dest (second windows))))
((or (and (= nth (1- length)) (not above-p))
(and (= nth 1) above-p))
(set-window-priority focus-dest nil :above))
(t (unless above-p
- (setf focus-dest (nth (incf nth) wins)))
- (set-window-priority (car wins) focus-dest :below)
+ (setf focus-dest (nth (incf nth) windows)))
+ (set-window-priority (car windows) focus-dest :below)
(set-window-priority focus-dest nil :above))))
(with-slots (master) (setf focus-dest (lookup-widget focus-dest))
(when (and icon-p (application-iconic-p focus-dest))
@@ -168,6 +170,6 @@
(when master (setf focus-dest master)))
(when *warp-pointer-when-cycle*
(xlib:warp-pointer (widget-window focus-dest) 8 5)))
- (when (and (eq *focus-type* :on-click) *focus-when-window-cycle*)
+ (when *focus-when-window-cycle*
(focus-widget focus-dest 0))
focus-dest)))
Index: eclipse/misc.lisp
diff -u eclipse/misc.lisp:1.12 eclipse/misc.lisp:1.13
--- eclipse/misc.lisp:1.12 Mon Oct 6 13:57:26 2003
+++ eclipse/misc.lisp Thu Nov 13 06:12:28 2003
@@ -1,5 +1,5 @@
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
-;;; $Id: misc.lisp,v 1.12 2003/10/06 17:57:26 ihatchondo Exp $
+;;; $Id: misc.lisp,v 1.13 2003/11/13 11:12:28 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
@@ -32,6 +32,10 @@
;;;; Helpers macros.
+(defmacro with-gensym (symbols &body body)
+ `(let ,(loop for s in symbols collect `(,s (gensym)))
+ ,@body))
+
(defmacro screen-width ()
`(xlib:screen-width (xlib:display-default-screen *display*)))
@@ -142,13 +146,62 @@
:format 32
:data (cons (atom-name->id atom) data)))
+(defun screen-windows-layers (window &aux (i (window-desktop-num window)))
+ "Returns, as multiple value, three window lists that corresponds to the
+ three layers (:_net_wm_state_below none :_net_wm_state_above) of the
+ virtual screen that the given `window' argument belongs to. The given
+ window will be filtered."
+ (loop with n = (if (eql i +any-desktop+) (current-desk) i)
+ for w in (get-screen-content n)
+ for nwm-state = (netwm:net-wm-state w)
+ unless (xlib:window-equal w window)
+ if (member :_net_wm_state_above nwm-state) collect w into aboves
+ else if (member :_net_wm_state_below nwm-state) collect w into belows
+ else collect w into no-stack-state
+ finally (return (values belows no-stack-state aboves))))
+
(defsetf window-priority (window &optional sibling) (priority)
- "Set the window priority such as (setf xlib:window-priority) but
- also invoke update-client-list-stacking to reflect the priority
- change in all the root properties that are involved in."
- `(progn
- (setf (xlib:window-priority ,window ,sibling) ,priority)
- (update-client-list-stacking *root*)))
+ "Set the window priority such as if done by (setf xlib:window-priority) and
+ guaranty that stacking order constraints described in the extended window
+ manager protocol will be respected. Then invokes update-client-list-stacking
+ to reflect the new order in all the root properties that are involved in."
+ (with-gensym (above-p wnwm-state snwm-state win sib b m a %priority)
+ `(flet ((lookup-app-w (widget)
+ (when (decoration-p widget)
+ (get-child widget :application :window t)))
+ (first (windows &optional above-p)
+ (car (if above-p (last windows) windows))))
+ (let* ((,%priority ,priority)
+ (,win (or (lookup-app-w (lookup-widget ,window)) ,window))
+ (,sib (or (lookup-app-w (lookup-widget ,sibling)) ,sibling))
+ (,above-p (eq ,priority :above))
+ (,wnwm-state (netwm:net-wm-state ,win))
+ (,snwm-state (and ,sib (netwm:net-wm-state ,sib))))
+ (if (not (application-p (lookup-widget ,win)))
+ (setf (xlib:window-priority ,window ,sibling) ,priority)
+ (multiple-value-bind (,b ,m ,a) (screen-windows-layers ,win)
+ (cond ((member :_net_wm_state_below ,wnwm-state)
+ (unless (member ,sib ,b)
+ (setf ,sib (first (or ,b ,m ,a) (and ,b ,above-p)))
+ (unless ,b (setf ,%priority :below))))
+ ((member :_net_wm_state_above ,wnwm-state)
+ (unless (member ,sib ,a)
+ (unless (member :_net_wm_state_fullscreen ,snwm-state)
+ (setf ,sib (first ,a ,above-p))
+ (unless ,a (setf ,%priority :above)))))
+ ((member :_net_wm_state_fullscreen ,wnwm-state)
+ (when (member ,sib ,b)
+ (setf ,sib (first (or ,m ,a)))
+ (setf ,%priority :below)))
+ ((not (member ,sib ,m))
+ (setf ,sib (first (or ,m ,b ,a) (if ,m ,above-p ,b)))
+ (unless ,m (setf ,%priority (if ,b :above :below)))))
+ (when (and ,sib (application-master (lookup-widget ,sib)))
+ (with-slots (master) (lookup-widget ,sib)
+ (setf ,sib (widget-window master))))
+ (when (or ,b ,m ,a)
+ (setf (xlib:window-priority ,window ,sib) ,%priority)
+ (update-client-list-stacking *root*))))))))
(defun grab-root-pointer (&key cursor owner-p confine-to)
(xlib:grab-pointer
@@ -217,8 +270,7 @@
(car (member name (application-list) :test #'equal :key #'application-name)))
(defun application-class (app)
- (multiple-value-bind (name type)
- (xlib:get-wm-class (widget-window app))
+ (multiple-value-bind (name type) (xlib:get-wm-class (widget-window app))
(cons name type)))
(defun application-class-name (app)
