[STUMP] [PATCH] better popup blocker

[John Fremlin]

---
 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.6.3