[STUMP] Patch to stop new windows stealing focus

[John Fremlin]

Sometimes an application pop up and steals my keystrokes. This patch
stops that but allows Open File dialogs to show up as appropriate.

It works for me but could do with some work before being merged -- maybe
changing the configuration syntax, and adding docs.

Are you interested in merging it? Comments please. Please keep me CC'd.

(The old *deny-map/raise-request* mechanism is still fully supported.)

Here is an example config:

(setf (request-arbitrators :raise)
      (list
       (lambda(window)
         (when (window-in-current-wmgroup-p window)
           :allow))
       (make-window-matcher-request-arbitrator :allow '(:class "Emacs"))
       (constantly :deny)))

(setf (request-arbitrators :fullscreen) ; going fullscreen also raises
      (list
       (constantly :deny)))

(setf (request-arbitrators :move) ; moving also raises
      (list
       (constantly :deny)))

(setf (request-arbitrators :map)
      (list
       (lambda(window)
         (when (window-in-current-wmgroup-p window)
           :allow))
       (make-window-matcher-request-arbitrator :allow '(:class "URxvt"))
       (constantly :deny)))

This allows emacsclient to work but generally blocks popups. 

(BTW it seems that my idea of wmgroup and the existing notion of gang
are similar but not identical.)



 events.lisp     |   55 ++++++++++++++++++++++++++++---------------------------
 primitives.lisp |   44 ++++++++++++++++++++++++++++++++++++--------
 window.lisp     |   21 +++++++++++++++------
 3 files changed, 79 insertions(+), 41 deletions(-)

diff --git a/events.lisp b/events.lisp
index fa8fe64..66da0ef 100644
--- a/events.lisp
+++ b/events.lisp
@@ -96,20 +96,20 @@
   (update-configuration window))
 
 (defun handle-window-move (win x y relative-to &optional (value-mask -1))
-  (when *honor-window-moves*
-    (dformat 3 "Window requested new position ~D,~D relative to ~S~%" x y 
relative-to)
+  (dformat 3 "Window requested new position ~D,~D relative to ~S~%" x y 
relative-to)
+  (when (and *honor-window-moves* (allow-request-p :move win))
     (labels ((has-x (mask) (= 1 (logand mask 1)))
-             (has-y (mask) (= 2 (logand mask 2))))
-      (when (or (eq relative-to :root) (has-x value-mask) (has-y value-mask))
-        (let* ((group (window-group win))
-               (pos  (if (eq relative-to :parent)
-                         (list
-                          (+ (xlib:drawable-x (window-parent win)) x)
-                          (+ (xlib:drawable-y (window-parent win)) y))
-                         (list x y)))
-               (frame (apply #'find-frame group pos)))
-          (when frame
-            (pull-window win frame)))))))
+            (has-y (mask) (= 2 (logand mask 2))))
+       (when (or (eq relative-to :root) (has-x value-mask) (has-y value-mask))
+         (let* ((group (window-group win))
+                (pos  (if (eq relative-to :parent)
+                          (list
+                           (+ (xlib:drawable-x (window-parent win)) x)
+                           (+ (xlib:drawable-y (window-parent win)) y))
+                          (list x y)))
+                (frame (apply #'find-frame group pos)))
+           (when frame
+             (pull-window win frame)))))))
 
 (define-stump-event-handler :configure-request (stack-mode #|parent|# window 
#|above-sibling|# x y width height border-width value-mask)
   ;; Grant the configure request but then maximize the window after the 
granting.
@@ -171,15 +171,15 @@
         (t
          (let ((window (process-mapped-window screen window)))
            ;; Give it focus
-           (if (deny-request-p window *deny-map-request*)
-               (unless *suppress-deny-messages*
-                 (if (eq (window-group window) (current-group))
-                     (echo-string (window-screen window) (format nil "'~a' 
denied map request" (window-name window)))
-                     (echo-string (window-screen window) (format nil "'~a' 
denied map request in group ~a" (window-name window) (group-name (window-group 
window))))))
+           (if (allow-request-p :map window)
                (frame-raise-window (window-group window) (window-frame window) 
window
                                    (if (eq (window-frame window)
                                            (tile-group-current-frame 
(window-group window)))
-                                       t nil)))))))))
+                                       t nil))
+              (unless *suppress-deny-messages*
+                 (if (eq (window-group window) (current-group))
+                     (echo-string (window-screen window) (format nil "'~a' 
denied map request" (window-name window)))
+                     (echo-string (window-screen window) (format nil "'~a' 
denied map request in group ~a" (window-name window) (group-name (window-group 
window)))))))))))))
 
 (define-stump-event-handler :unmap-notify (send-event-p event-window window 
#|configure-p|#)
   ;; There are two kinds of unmap notify events: the straight up
@@ -467,10 +467,11 @@ converted to an atom is removed."
 
 (defun activate-fullscreen (window)
   (dformat 2 "client requests to go fullscreen~%")
-  (add-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN)
-  (setf (window-fullscreen window) t)
-  (maximize-window window)
-  (focus-window window))
+  (when (allow-request-p :fullscreen window)
+    (add-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN)
+    (setf (window-fullscreen window) t)
+    (maximize-window window)
+    (focus-window window)))
 
 (defun deactivate-fullscreen (window)
   (setf (window-fullscreen window) nil)
@@ -496,14 +497,14 @@ converted to an atom is removed."
            (activate-fullscreen window))))))
 
 (defun maybe-raise-window (window)
-  (if (deny-request-p window *deny-raise-request*)
+  (if (allow-request-p :raise window)
+      (focus-all window)
       (unless (or *suppress-deny-messages*
                   ;; don't mention windows that are already visible
                   (eq (frame-window (window-frame window)) window))
         (if (eq (window-group window) (current-group))
             (echo-string (window-screen window) (format nil "'~a' denied raise 
request" (window-name window)))
-            (echo-string (window-screen window) (format nil "'~a' denied raise 
request in group ~a" (window-name window) (group-name (window-group window))))))
-      (focus-all window)))
+            (echo-string (window-screen window) (format nil "'~a' denied raise 
request in group ~a" (window-name window) (group-name (window-group 
window))))))))
 
 (define-stump-event-handler :client-message (window type #|format|# data)
   (dformat 2 "client message: ~s ~s~%" type data)
@@ -514,7 +515,7 @@ converted to an atom is removed."
             (group (and screen
                         (< n (length (screen-groups screen)))
                         (elt (sort-groups screen) n))))
-       (when group
+       (when group 
          (switch-to-group group))))
     (:_NET_WM_DESKTOP                   ;move window to desktop
      (let* ((our-window (find-window window))
diff --git a/primitives.lisp b/primitives.lisp
index 239f1dc..bc82972 100644
--- a/primitives.lisp
+++ b/primitives.lisp
@@ -848,14 +848,42 @@ raise/map denial messages will be seen.")
 (defvar *resize-hides-windows* nil
   "Set to T to hide windows during interactive resize")
 
-(defun deny-request-p (window deny-list)
-  (or (eq deny-list t)
-      (and
-       (listp deny-list)
-       (find-if (lambda (props)
-                  (apply 'window-matches-properties-p window props))
-                deny-list)
-       t)))
+(defvar *request-arbitrators* (make-hash-table))
+(defun request-arbitrators (request)
+  (gethash request *request-arbitrators*))
+(defun (setf request-arbitrators) (nv request)
+  (setf (gethash request *request-arbitrators*) nv))
+(defun add-request-arbitrator (request a)
+  (check-type a (or function symbol))
+  (push a (request-arbitrators request)))
+(defun make-window-matcher-request-arbitrator (action properties)
+  (lambda(window)
+    (when (apply 'window-matches-properties-p window properties)
+      action)))
+
+
+(defun allow-request-p (request window)
+  (flet ((deny-request-p (window deny-list)
+          (or (eq deny-list t)
+              (and
+               (listp deny-list)
+               (find-if (lambda (props)
+                          (apply 'window-matches-properties-p window props))
+                        deny-list)
+               t))))
+    (ecase
+        (loop for arbitrator in (request-arbitrators request) thereis 
+              (funcall arbitrator window))
+      (:allow t)
+      (:deny nil)
+      ((nil)
+       (let ((deny-list
+             (case request
+               (:map *deny-map-request*)
+               (:raise *deny-raise-request*))))
+        (if deny-list
+          (not (deny-request-p window deny-list))
+          t))))))
 
 (defun list-splice-replace (item list &rest replacements)
   "splice REPLACEMENTS into LIST where ITEM is, removing
diff --git a/window.lisp b/window.lisp
index fb9e6f1..b363f17 100644
--- a/window.lisp
+++ b/window.lisp
@@ -114,6 +114,15 @@ _NET_WM_STATE_DEMANDS_ATTENTION set"
 (defun window-transient-p (window)
   (find (window-type window) '(:transient :dialog)))
 
+(defun window-wmgroup (window)
+  (ignore-errors (xlib:wm-hints-window-group (xlib:wm-hints (window-xwin 
window)))))
+
+(defun window-in-current-wmgroup-p (window)
+  (let ((g (window-wmgroup window)))
+    (when g 
+      (equalp g 
+             (window-wmgroup (frame-window (window-frame window)))))))
+
 ;; FIXME: use WM_HINTS.group_leader
 (defun window-gang (window)
   "Return a list of other windows in WINDOW's gang."
@@ -1012,15 +1021,15 @@ needed."
     ;; It is effectively a new window in terms of the window list.
     (run-hook-with-args *new-window-hook* window)
     ;; give it focus
-    (if (deny-request-p window *deny-map-request*)
-        (unless *suppress-deny-messages*
-          (if (eq (window-group window) (current-group))
-              (echo-string (window-screen window) (format nil "'~a' denied map 
request" (window-name window)))
-              (echo-string (window-screen window) (format nil "'~a' denied map 
request in group ~a" (window-name window) (group-name (window-group window))))))
+    (if (allow-request-p :raise window)
         (frame-raise-window (window-group window) (window-frame window) window
                             (if (eq (window-frame window)
                                     (tile-group-current-frame (window-group 
window)))
-                                t nil)))))
+                                t nil))
+       (unless *suppress-deny-messages*
+          (if (eq (window-group window) (current-group))
+              (echo-string (window-screen window) (format nil "'~a' denied map 
request" (window-name window)))
+              (echo-string (window-screen window) (format nil "'~a' denied map 
request in group ~a" (window-name window) (group-name (window-group 
window)))))))))
 
 (defun withdraw-window (window)
   "Withdrawing a window means just putting it in a list til we get a destroy 
event."
-- 
1.5.4.3