[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/exwm c97cead 1/3: Implement compositing manager module
|
From: |
Chris Feng |
|
Subject: |
[elpa] externals/exwm c97cead 1/3: Implement compositing manager module |
|
Date: |
Sun, 14 Aug 2016 10:21:44 +0000 (UTC) |
branch: externals/exwm
commit c97ceadce5c699999b103463b212207f15280ba6
Author: Chris Feng <address@hidden>
Commit: Chris Feng <address@hidden>
Implement compositing manager module
* exwm-cm.el: New compositing manager module.
---
exwm-cm.el | 1778 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 1778 insertions(+)
diff --git a/exwm-cm.el b/exwm-cm.el
new file mode 100644
index 0000000..8e019bb
--- /dev/null
+++ b/exwm-cm.el
@@ -0,0 +1,1778 @@
+;;; exwm-cm.el --- Compositing Manager for EXWM -*- lexical-binding: t -*-
+
+;; Copyright (C) 2016 Free Software Foundation, Inc.
+
+;; Author: Chris Feng <address@hidden>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module provides a compositing manager (CM) for EXWM, mainly to
+;; enable transparency support.
+
+;; Usage:
+;; Add following lines to .emacs and modify accordingly:
+;;
+;; (require 'exwm-cm)
+;; ;; Make all Emacs frames opaque.
+;; (setq window-system-default-frame-alist '((x . ((alpha . 100)))))
+;; ;; Assign everything else a 80% opacity.
+;; (setq exwm-cm-opacity 80)
+;; (exwm-cm-enable)
+;;
+;; With the last line this CM would be started with EXWM. You can also
+;; start and stop this CM with `exwm-cm-start' and `exwm-cm-stop' at any
+;; time.
+
+;; Theory:
+;; Due to its unique way of managing X windows, EXWM can not work with
+;; any existing CMs. And this CM, designed specifically for EXWM,
+;; probably won't work well with other WMs, too. The theories behind
+;; all CMs are basically the same, some peculiarities of this CM are
+;; summarized as the following sections.
+
+;; + Data structures:
+;; This CM organizes all X windows concerned with compositing in a
+;; tree hierarchy. Below is a stripped-down version of such tree with
+;; each node representing an X window (except the root placeholder),
+;;
+;; (nil
+;; (root-xwin
+;; (unmanaged-xwin)
+;; (workspace-container
+;; (unmanaged-xwin)
+;; (xwin-container
+;; (xwin)
+;; (floating-frame-container
+;; (floating-frame)))
+;; (xwin-container
+;; (xwin))
+;; (workspace-frame-container
+;; (workspace-frame)))
+;; (minibuffer-frame-container
+;; (minibuffer-frame))))
+;;
+;; where
+;; - nodes with non-nil CDRs are containers,
+;; - siblings are arranged in stacking order (top to bottom),
+;; - and "managed" and "unmanaged" are in WM's sense.
+;;
+;; During a painting process, the tree is traversed starting from the
+;; root node, with each leaf visited and painted. The attributes of
+;; each X window (position, size, etc) are recorded as an instance of
+;; class `exwm-cm--attr'. Such instance is associated with the
+;; corresponding X window ID through a hash table. The instance also
+;; contains a slot pointing to a subtree of the aforementioned tree,
+;; with the root node being the parent of the X window. This makes it
+;; convenient to carry out operations such as insertion, deletion,
+;; restacking and reparenting.
+
+;; + Compositing strategies:
+;; - Only leaves are painted, since branches (containers) are always
+;; invisible.
+;; - The root X window is painted separately.
+;; - Siblings below a workspace frame container are not painted; they
+;; are considered hidden.
+;; - Only the top workspace in one (RandR) output is painted.
+;; - Workspace frames and floating frames are always clipped by its
+;; Emacs windows displaying `exwm-mode' buffers, therefore they
+;; don't block X windows.
+
+;; Reference:
+;; + xcompmgr (http://cgit.freedesktop.org/xorg/app/xcompmgr/)
+
+;;; Code:
+
+(require 'xcb-composite)
+(require 'xcb-damage)
+(require 'xcb-ewmh)
+(require 'xcb-icccm)
+(require 'xcb-renderutil)
+(require 'xcb-shape)
+
+(require 'exwm-core)
+(require 'exwm-workspace)
+(require 'exwm-manage)
+
+(defconst exwm-cm--OPAQUE (float #xFFFFFFFF)
+ "The opacity value of the _NET_WM_WINDOW_OPACITY property.")
+(defvar exwm-cm--_NET_WM_WINDOW_OPACITY nil "The _NET_WM_WINDOW_OPACITY atom.")
+(defvar exwm-cm-opacity nil
+ "The default value of opacity when it's not explicitly specified.
+
+The value should be a floating number between 0 (transparent) and 100
+(opaque). A value of nil also means opaque.")
+
+(defvar exwm-cm--hash nil
+ "The hash table associating X window IDs to their attributes.")
+
+(defvar exwm-cm--conn nil "The X connection used by the CM.")
+(defvar exwm-cm--buffer nil "The rendering buffer.")
+(defvar exwm-cm--depth nil "Default depth.")
+(defvar exwm-cm--clip-changed t "Whether clip has changed.")
+(defvar exwm-cm--damages nil "All damaged regions.")
+(defvar exwm-cm--expose-rectangles nil
+ "Used by Expose event handler to collect exposed regions.")
+
+(defvar exwm-cm--background nil "The background (render) picture.")
+(defvar exwm-cm--background-atom-names '("_XROOTPMAP_ID" "_XSETROOT_ID")
+ "Property names for background pixmap.")
+(defvar exwm-cm--background-atoms nil "Interned atoms of the property names.")
+
+(defun exwm-cm--get-opacity (xwin)
+ "Get the opacity of X window XWIN.
+
+The value is between 0 (fully transparent) to #xFFFFFFFF (opaque)."
+ (let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:icccm:-GetProperty-single
+ :window xwin
+ :property exwm-cm--_NET_WM_WINDOW_OPACITY
+ :type xcb:Atom:CARDINAL))))
+ ;; The X window might have already been destroyed.
+ (when reply
+ (slot-value reply 'value))))
+
+(defun exwm-cm-set-opacity (xwin opacity)
+ "Set the opacity of X window XWIN to OPACITY.
+
+The value is between 0 (fully transparent) to 100 (opaque).
+
+If called interactively, XWIN would be the selected X window."
+ (interactive
+ (list (exwm--buffer->id (window-buffer))
+ (read-number "Opacity (0 ~ 100): " 100)))
+ (when (and xwin
+ (<= 0 opacity 100))
+ (setq opacity (round (* exwm-cm--OPAQUE (/ opacity 100.0))))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:icccm:-ChangeProperty-single
+ :window xwin
+ :property exwm-cm--_NET_WM_WINDOW_OPACITY
+ :type xcb:Atom:CARDINAL
+ :data opacity))
+ (xcb:flush exwm-cm--conn)))
+
+(defclass exwm-cm--attr ()
+ (
+ ;; The entity associated with this X window; can be a frame, a buffer
+ ;; or nil.
+ (entity :initform nil)
+ ;; The subtree of which the root node is the parent of this X window.
+ (tree :initarg :tree)
+ ;; Geometry.
+ (x :initarg :x)
+ (y :initarg :y)
+ (width :initarg :width)
+ (height :initarg :height)
+ ;; X window attributes.
+ (visual :initarg :visual)
+ (class :initarg :class)
+ ;; The opacity of this X window; can be 0 ~ #xFFFE or nil.
+ (opacity :initform nil)
+ ;; Determine whether this X window should be treated as opaque or
+ ;; transparent; can be nil (opaque), 'argb or 'transparent (both
+ ;; should be treated as transparent).
+ (mode :initform nil)
+ ;; The (render) picture of this X window.
+ (picture :initform nil)
+ ;; The 1x1 (render) picture with only alpha channel.
+ (alpha-picture :initform nil)
+ ;; Whether this X window is ever damaged.
+ (damaged :initform nil)
+ ;; The damage object monitoring this X window.
+ (damage :initarg :damage)
+ ;; The bounding region of this X window (can be irregular).
+ (border-size :initform nil)
+ ;; The rectangular bounding region of this X window.
+ (extents :initform nil)
+ ;; The region require repainting (used for transparent X windows).
+ (border-clip :initform nil)
+ ;; Shape-related parameters.
+ (shaped :initform nil)
+ (shape-x :initarg :shape-x)
+ (shape-y :initarg :shape-y)
+ (shape-width :initarg :shape-width)
+ (shape-height :initarg :shape-height))
+ :documentation "Attributes of an X window.")
+
+(defsubst exwm-cm--xwin->attr (xwin)
+ "Get the attributes of X window XWIN."
+ (gethash xwin exwm-cm--hash))
+
+(defsubst exwm-cm--get-tree (xwin)
+ "Get the subtree of the parent of X window XWIN."
+ (slot-value (exwm-cm--xwin->attr xwin) 'tree))
+
+(defsubst exwm-cm--set-tree (xwin tree)
+ "Reparent X window XWIN to another tree TREE."
+ (setf (slot-value (exwm-cm--xwin->attr xwin) 'tree) tree))
+
+(defsubst exwm-cm--get-parent (xwin)
+ "Get the parent of X window XWIN."
+ (car (exwm-cm--get-tree xwin)))
+
+(defsubst exwm-cm--get-siblings (xwin)
+ "Get a list of subtrees of the siblings of X window XWIN"
+ (cdr (exwm-cm--get-tree xwin)))
+
+(defsubst exwm-cm--get-subtree (xwin)
+ "Get the subtree of which the X window XWIN is the root node."
+ (assq xwin (exwm-cm--get-siblings xwin)))
+
+(defun exwm-cm--create-attr (xwin tree x y width height)
+ "Create attributes for X window XWIN.
+
+TREE is the subtree and the parent of this X window is the tree's root.
+X and Y specify the position with regard to the root X window. WIDTH
+and HEIGHT specify the size of the X window."
+ (let (visual class map-state damage attr)
+ (cond
+ ((= xwin exwm--root)
+ ;; Redirect all subwindows to off-screen storage.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:composite:RedirectSubwindows
+ :window exwm--root
+ :update xcb:composite:Redirect:Manual))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:ChangeWindowAttributes
+ :window xwin
+ :value-mask xcb:CW:EventMask
+ :event-mask (logior xcb:EventMask:StructureNotify
+ xcb:EventMask:PropertyChange
+ xcb:EventMask:SubstructureNotify
+ xcb:EventMask:Exposure)))
+ (setq visual (slot-value (car (slot-value (xcb:get-setup exwm-cm--conn)
+ 'roots))
+ 'root-visual)
+ class xcb:WindowClass:InputOutput))
+ ((eq xwin exwm-manage--desktop)
+ ;; Ignore any desktop; paint the background ourselves.
+ (setq visual 0
+ class xcb:WindowClass:InputOnly
+ map-state xcb:MapState:Unmapped))
+ (t
+ ;; Redirect this window to off-screen storage, or the content
+ ;; would be mirrored to its parent.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:composite:RedirectWindow
+ :window xwin
+ :update xcb:composite:Redirect:Manual))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:ChangeWindowAttributes
+ :window xwin
+ :value-mask xcb:CW:EventMask
+ :event-mask (logior xcb:EventMask:StructureNotify
+ xcb:EventMask:PropertyChange)))
+ (let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetWindowAttributes
+ :window xwin))))
+ (if reply
+ (with-slots ((visual* visual)
+ (class* class)
+ (map-state* map-state))
+ reply
+ (setq visual visual*
+ class class*
+ map-state map-state*))
+ ;; The X window has been destroyed actually. It'll get
+ ;; removed by a DestroyNotify event.
+ (setq visual 0
+ class xcb:WindowClass:InputOnly
+ map-state xcb:MapState:Unmapped)))
+ (when (/= class xcb:WindowClass:InputOnly)
+ (setq damage (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:damage:Create
+ :damage damage
+ :drawable xwin
+ :level xcb:damage:ReportLevel:NonEmpty))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:shape:SelectInput
+ :destination-window xwin
+ :enable 1)))))
+ (setq attr (make-instance 'exwm-cm--attr
+ :tree tree
+ :x x
+ :y y
+ :width width
+ :height height
+ :visual visual
+ :class class
+ :damage damage
+ :shape-x x
+ :shape-y y
+ :shape-width width
+ :shape-height height))
+ (puthash xwin attr exwm-cm--hash)
+ (unless (or (= xwin exwm--root)
+ (= class xcb:WindowClass:InputOnly))
+ (exwm-cm--update-opacity xwin)
+ (when (= map-state xcb:MapState:Viewable)
+ (exwm-cm--map-xwin xwin t)))))
+
+(defun exwm-cm--update-geometry (xwin x y width height &optional above-sibling)
+ "Update the geometry of X window XWIN.
+
+X, Y, WIDTH and HEIGHT have the same meaning with the arguments used in
+`exwm-cm--create-attr'. If ABOVE-SIBLING is non-nil, restack XWIN with
+`exwm-cm--restack.'"
+ (with-slots ((x* x)
+ (y* y)
+ (width* width)
+ (height* height)
+ extents shaped shape-x shape-y shape-width shape-height)
+ (exwm-cm--xwin->attr xwin)
+ (let ((stack-changed (and above-sibling
+ (exwm-cm--restack xwin above-sibling)))
+ (position-changed (or (and x (/= x x*))
+ (and y (/= y y*))))
+ (size-changed (or (and width (/= width width*))
+ (and height (/= height height*))))
+ subtree dx dy damage new-extents)
+ (when position-changed
+ (setq subtree (exwm-cm--get-subtree xwin)
+ dx (- x x*)
+ dy (- y y*))
+ (dolist (node (cdr subtree))
+ (with-slots (x y) (exwm-cm--xwin->attr (car node))
+ (exwm--log "(CM) #x%X(*): @%+d%+d => @%+d%+d"
+ (car node) x y (+ x dx) (+ y dy))
+ (exwm-cm--update-geometry (car node) (+ x dx) (+ y dy) nil nil)))
+ (exwm--log "(CM) #x%X: @%+d%+d => @%+d%+d" xwin x* y* x y)
+ (setf x* x
+ y* y)
+ (cl-incf shape-x dx)
+ (cl-incf shape-y dy))
+ (when size-changed
+ (setf width* width
+ height* height)
+ (unless shaped
+ (setf shape-width width
+ shape-height height)))
+ (when (or stack-changed position-changed size-changed)
+ (setq damage (xcb:generate-id exwm-cm--conn)
+ new-extents (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region damage
+ :rectangles nil))
+ (when extents
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CopyRegion
+ :source extents
+ :destination damage)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region new-extents
+ :rectangles (list (make-instance 'xcb:RECTANGLE
+ :x x*
+ :y y*
+ :width width*
+ :height height*))))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:UnionRegion
+ :source1 damage
+ :source2 new-extents
+ :destination damage))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region new-extents))
+ (exwm-cm--add-damage damage)))))
+
+(defun exwm-cm--update-opacity (xwin)
+ "Update the opacity of X window XWIN."
+ (with-slots (visual opacity mode alpha-picture extents)
+ (exwm-cm--xwin->attr xwin)
+ (let (format forminfo)
+ ;; Get the opacity.
+ (setf opacity (exwm-cm--get-opacity xwin))
+ (if opacity
+ (setf opacity (round (* #xFFFF (/ opacity exwm-cm--OPAQUE))))
+ (when (numberp exwm-cm-opacity)
+ (setf opacity (round (* #xFFFF (/ exwm-cm-opacity 100.0))))))
+ (when (and opacity
+ (>= opacity #xFFFF))
+ (setf opacity nil))
+ ;; Determine the mode of the X window.
+ (setq format (xcb:renderutil:find-visual-format
+ (xcb:renderutil:query-formats exwm-cm--conn) visual))
+ (when format
+ (catch 'break
+ (dolist (f (slot-value (xcb:renderutil:query-formats exwm-cm--conn)
+ 'formats))
+ (when (eq format (slot-value f 'id))
+ (setq forminfo f)
+ (throw 'break nil)))))
+ (if (and forminfo
+ (eq xcb:render:PictType:Direct (slot-value forminfo 'type))
+ (/= 0 (slot-value (slot-value forminfo 'direct) 'alpha-mask)))
+ (setf mode 'argb)
+ (if opacity
+ (setf mode 'transparent)
+ (setf mode nil)))
+ ;; Clear resources.
+ (when alpha-picture
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FreePicture
+ :picture alpha-picture))
+ (setf alpha-picture nil))
+ (when extents
+ (let ((damage (xcb:generate-id exwm-cm--conn)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region damage
+ :rectangles nil))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CopyRegion
+ :source extents
+ :destination damage))
+ (exwm-cm--add-damage damage))))))
+
+(defsubst exwm-cm--push (newelt place)
+ "Similar to `push' but preserve the reference."
+ (let ((oldelt (car place)))
+ (setf (car place) newelt
+ (cdr place) (cons oldelt (cdr place)))))
+
+(defsubst exwm-cm--delq (elt list)
+ "Similar to `delq' but preserve the reference."
+ (if (eq elt (car list))
+ (setf (car list) (cadr list)
+ (cdr list) (cddr list))
+ (delq elt list)))
+
+(defsubst exwm-cm--assq-delete-all (key alist)
+ "Similar to `assq-delete-all' but preserve the reference."
+ (when (eq key (caar alist))
+ (setf (car alist) (cadr alist)
+ (cdr alist) (cddr alist)))
+ (assq-delete-all key alist))
+
+(defun exwm-cm--create-tree (&optional xwin)
+ "Create a tree with XWIN being the root node."
+ (let (tree0 x0 y0 children containers)
+ ;; Get the position of this branch.
+ (if xwin
+ (with-slots (tree x y) (exwm-cm--xwin->attr xwin)
+ (setq tree0 (assq xwin (cdr tree))
+ x0 x
+ y0 y))
+ (setq tree0 (list nil)
+ x0 0
+ y0 0))
+ ;; Get children nodes.
+ (if (null xwin)
+ (setq children (list exwm--root))
+ (setq children
+ (reverse (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:QueryTree
+ :window xwin))
+ 'children))))
+ ;; Get container nodes.
+ ;; Floating frame containers are determined dynamically.
+ (cond
+ ((null xwin)
+ (setq containers `((,exwm--root))))
+ ((= xwin exwm--root)
+ ;; Workspace containers and the minibuffer frame container.
+ (setq containers (mapcar (lambda (f)
+ (cons (frame-parameter f 'exwm-workspace) f))
+ exwm-workspace--list))
+ (when (exwm-workspace--minibuffer-own-frame-p)
+ (push (cons
+ (frame-parameter exwm-workspace--minibuffer 'exwm-container)
+ exwm-workspace--minibuffer)
+ containers)))
+ ;; No containers in the minibuffer container.
+ ((and (exwm-workspace--minibuffer-own-frame-p)
+ (= xwin
+ (frame-parameter exwm-workspace--minibuffer 'exwm-container))))
+ ((= exwm--root
+ (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:QueryTree
+ :window xwin))
+ 'parent))
+ ;; Managed X window containers and the workspace frame container.
+ (let (frame)
+ (catch 'break
+ (dolist (f exwm-workspace--list)
+ (when (= xwin (frame-parameter f 'exwm-workspace))
+ (setq frame f)
+ (throw 'break nil))))
+ (cl-assert frame)
+ (dolist (pair exwm--id-buffer-alist)
+ (with-current-buffer (cdr pair)
+ (when (eq frame exwm--frame)
+ (push (cons exwm--container (cdr pair)) containers))))
+ (push (cons (frame-parameter frame 'exwm-container) frame)
+ containers))))
+ ;; Create subnodes.
+ (dolist (xwin children)
+ ;; Create attributes.
+ (let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetGeometry
+ :drawable xwin))))
+ ;; It's possible the X window has been destroyed.
+ (if (null reply)
+ (setq xwin nil)
+ (when reply
+ (with-slots (x y width height) reply
+ (exwm-cm--create-attr xwin tree0
+ (+ x x0) (+ y y0) width height))
+ ;; Insert the node.
+ (setcdr (or (last (cdr tree0)) tree0) `((,xwin))))))
+ (cond
+ ((null xwin))
+ ((assq xwin containers)
+ ;; A branch. Repeat the process.
+ (exwm-cm--create-tree xwin)
+ (let ((entity (cdr (assq xwin containers)))
+ entity-xwin)
+ (when entity
+ (setq entity-xwin (if (framep entity)
+ (frame-parameter entity 'exwm-outer-id)
+ (buffer-local-value 'exwm--id entity)))
+ (setf (slot-value (exwm-cm--xwin->attr entity-xwin) 'entity) entity
+ (slot-value (exwm-cm--xwin->attr xwin) 'entity) entity)
+ (let ((tmp (exwm-cm--get-parent entity-xwin)))
+ (when (/= xwin tmp)
+ ;; Workspace frame container.
+ (setf (slot-value (exwm-cm--xwin->attr tmp) 'entity)
+ entity))))))
+ ((and (null containers)
+ (exwm--id->buffer xwin))
+ ;; A leaf but a floating frame container might follow.
+ (with-current-buffer (exwm--id->buffer xwin)
+ (when exwm--floating-frame
+ (push (cons (frame-parameter exwm--floating-frame 'exwm-container)
+ exwm--floating-frame)
+ containers))))))))
+
+(defun exwm-cm--restack (xwin above-sibling)
+ "Restack X window XWIN so as to it's exactly on top of ABOVE-SIBLING."
+ (let ((siblings (exwm-cm--get-siblings xwin))
+ node tmp)
+ (unless (= 1 (length siblings))
+ (setq node (assq xwin siblings))
+ (if (= above-sibling xcb:Window:None)
+ ;; Put at bottom.
+ (unless (eq node (cdr (last siblings)))
+ (exwm-cm--delq node siblings)
+ (setcdr (last siblings) (list node))
+ ;; Set the return value.
+ t)
+ ;; Insert before the sibling.
+ (setq tmp siblings)
+ (while (and tmp
+ (/= above-sibling (caar tmp)))
+ (setq tmp (cdr tmp)))
+ (cl-assert tmp)
+ ;; Check if it's already at the requested position.
+ (unless (eq tmp (cdr siblings))
+ (exwm-cm--delq node siblings)
+ (exwm-cm--push node tmp)
+ ;; Set the return value.
+ t)))))
+
+(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id))
+
+(defun exwm-cm--paint-tree (tree region &optional force-opaque frame-clip)
+ "Paint the tree TREE, with REGION specifying the clipping region.
+
+If FORCE-OPAQUE is non-nil, all X windows painted in this tree is
+assumed opaque. FRAME-CLIP specifies the region should be clipped when
+painting a frame."
+ (unless tree
+ (setq tree (exwm-cm--get-tree exwm--root)))
+ (let ((root (car tree))
+ xwin attr entity current output outputs queue rectangles)
+ ;; Paint subtrees.
+ (catch 'break
+ (dolist (subtree (cdr tree))
+ (setq xwin (car subtree)
+ attr (exwm-cm--xwin->attr xwin))
+ (cond
+ ;; Skip destroyed X windows.
+ ((null attr))
+ ;; Skip InputOnly X windows.
+ ((= xcb:WindowClass:InputOnly
+ (slot-value attr 'class)))
+ ((and (eq root exwm--root)
+ (frame-live-p (setq entity (slot-value attr 'entity)))
+ (if (eq entity exwm-workspace--minibuffer)
+ ;; Skip the minibuffer if the current workspace is
+ ;; already painted.
+ (unless (exwm-workspace--minibuffer-attached-p)
+ current)
+ ;; Skip lower workspaces on visited RandR output.
+ ;; If RandR is not enabled, it'll just paint the first.
+ (memq (setq output (frame-parameter entity
+ 'exwm-randr-output))
+ outputs))))
+ ((cdr subtree)
+ ;; Paint the subtree.
+ (setq entity (slot-value attr 'entity))
+ (let (fullscreen clip)
+ (cond
+ ((buffer-live-p entity)
+ (with-current-buffer entity
+ ;; Collect frame clip but exclude fullscreen and
+ ;; floating X windows.
+ (setq fullscreen (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN
+ exwm--ewmh-state))
+ (when (and (null fullscreen)
+ ;; In case it's hidden.
+ (null (exwm-layout--iconic-state-p))
+ ;; The buffer of a floating X windows is not
+ ;; displayed on a workspace frame.
+ (null exwm--floating-frame)
+ ;; Opaque regions are always clipped.
+ (slot-value (exwm-cm--xwin->attr xwin) 'mode))
+ ;; Prepare rectangles to clip the workspace frame.
+ (with-slots (x y width height) (exwm-cm--xwin->attr xwin)
+ (push (make-instance 'xcb:RECTANGLE
+ :x x
+ :y y
+ :width width
+ :height height)
+ rectangles)))))
+ ((and rectangles
+ (frame-live-p entity))
+ ;; Prepare region to clip the frame.
+ (setq clip (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region clip
+ :rectangles rectangles))))
+ (setq queue
+ (nconc (exwm-cm--paint-tree subtree region fullscreen clip)
+ queue))
+ (when fullscreen
+ ;; Fullscreen X windows are always opaque thus occludes
+ ;; anything in this workspace.
+ (throw 'break 'fullscreen))
+ (when clip
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region clip))))
+ (if (not (eq root exwm--root))
+ ;; Avoid painting any siblings below the workspace frame
+ ;; container.
+ (when (exwm-workspace--workspace-p (slot-value attr 'entity))
+ (throw 'break nil))
+ ;; Save some status.
+ (when (and (frame-live-p entity)
+ (not (eq entity exwm-workspace--minibuffer)))
+ (push output outputs)
+ (when (eq entity exwm-workspace--current)
+ (setq current t)))))
+ ((and force-opaque
+ (slot-value attr 'damaged))
+ (exwm-cm--paint-opaque xwin region t))
+ ((slot-value attr 'damaged)
+ ;; Paint damaged leaf.
+ (setq entity (slot-value attr 'entity))
+ (when (slot-value attr 'mode)
+ (push xwin queue))
+ (cond
+ ((buffer-live-p entity)
+ (with-current-buffer entity
+ (cl-assert (= xwin exwm--id))
+ (when (and exwm--floating-frame
+ ;; Opaque regions are always clipped.
+ (slot-value (exwm-cm--xwin->attr xwin) 'mode))
+ ;; Prepare rectangles to clip the floating frame.
+ (with-slots (x y width height) (exwm-cm--xwin->attr xwin)
+ (push (make-instance 'xcb:RECTANGLE
+ :x x
+ :y y
+ :width width
+ :height height)
+ rectangles)))))
+ ((and frame-clip
+ (frame-live-p entity))
+ ;; Apply frame clip.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:IntersectRegion
+ :source1 region
+ :source2 frame-clip
+ :destination frame-clip))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:SubtractRegion
+ :source1 region
+ :source2 frame-clip
+ :destination region))))
+ (exwm-cm--paint-opaque xwin region)
+ (when (and frame-clip
+ (frame-live-p entity))
+ ;; Restore frame clip.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:UnionRegion
+ :source1 region
+ :source2 frame-clip
+ :destination region)))))))
+ ;; Return the queue.
+ queue))
+
+(defun exwm-cm--paint-opaque (xwin region &optional force-opaque)
+ "Paint an X window XWIN clipped by region REGION if XWIN is opaque.
+
+Also update the attributes of XWIN and clip the region."
+ (with-slots (x y width height visual mode picture
+ border-size extents border-clip)
+ (exwm-cm--xwin->attr xwin)
+ ;; Prepare the X window picture.
+ (unless picture
+ (setf picture (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:CreatePicture
+ :pid picture
+ :drawable xwin
+ :format (xcb:renderutil:find-visual-format
+ (xcb:renderutil:query-formats exwm-cm--conn)
+ visual)
+ :value-mask 0)))
+ ;; Clear cached resources if clip changed.
+ (when exwm-cm--clip-changed
+ (when border-size
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-size))
+ (setf border-size nil))
+ (when extents
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region extents))
+ (setf extents nil))
+ (when border-clip
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-clip))
+ (setf border-clip nil)))
+ ;; Retrieve the border.
+ (unless border-size
+ (setf border-size (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegionFromWindow
+ :region border-size
+ :window xwin
+ :kind xcb:shape:SK:Bounding))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:TranslateRegion
+ :region border-size
+ :dx x
+ :dy y)))
+ ;; Retrieve the extents.
+ (unless extents
+ (setf extents (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region extents
+ :rectangles (list (make-instance 'xcb:RECTANGLE
+ :x x
+ :y y
+ :width width
+ :height height)))))
+ (cond
+ ((and mode
+ (null force-opaque))
+ ;; Calculate clipped border for the transparent X window.
+ (unless border-clip
+ (setf border-clip (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region border-clip
+ :rectangles nil))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CopyRegion
+ :source region
+ :destination border-clip))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:IntersectRegion
+ :source1 border-clip
+ :source2 border-size
+ :destination border-clip))))
+ (t
+ ;; Clip & render for the opaque X window.
+ ;; Set the clip region for the rendering buffer.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:SetPictureClipRegion
+ :picture exwm-cm--buffer
+ :region region
+ :x-origin 0
+ :y-origin 0))
+ ;; Clip the region with border.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:SubtractRegion
+ :source1 region
+ :source2 border-size
+ :destination region))
+ ;; Render the picture to the buffer.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:Composite
+ :op xcb:render:PictOp:Src
+ :src picture
+ :mask xcb:render:Picture:None
+ :dst exwm-cm--buffer
+ :src-x 0
+ :src-y 0
+ :mask-x 0
+ :mask-y 0
+ :dst-x x
+ :dst-y y
+ :width width
+ :height height))))))
+
+(defun exwm-cm--paint-transparent (xwin)
+ "Paint a transparent X window XWIN."
+ (with-slots (x y width height opacity picture alpha-picture border-clip)
+ (exwm-cm--xwin->attr xwin)
+ ;; Prepare the alpha picture for transparent X windows.
+ (when (and opacity (null alpha-picture))
+ (setf alpha-picture (xcb:generate-id exwm-cm--conn))
+ (let ((pixmap (xcb:generate-id exwm-cm--conn)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:CreatePixmap
+ :depth 8
+ :pid pixmap
+ :drawable exwm--root
+ :width 1
+ :height 1))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:CreatePicture
+ :pid alpha-picture
+ :drawable pixmap
+ :format (xcb:renderutil:find-standard
+ (xcb:renderutil:query-formats
+ exwm-cm--conn)
+ xcb:renderutil:PICT_STANDARD:A_8)
+ :value-mask xcb:render:CP:Repeat
+ :repeat 1))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FillRectangles
+ :op xcb:render:PictOp:Src
+ :dst alpha-picture
+ :color (make-instance 'xcb:render:COLOR
+ :red 0
+ :green 0
+ :blue 0
+ :alpha opacity)
+ :rects (list (make-instance 'xcb:RECTANGLE
+ :x 0
+ :y 0
+ :width 1
+ :height 1))))))
+ ;; Set the clip region for the rendering buffer.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:SetPictureClipRegion
+ :picture exwm-cm--buffer
+ :region border-clip
+ :x-origin 0
+ :y-origin 0))
+ ;; Render the picture to the buffer.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:Composite
+ :op xcb:render:PictOp:Over
+ :src picture
+ :mask (or alpha-picture xcb:render:Picture:None)
+ :dst exwm-cm--buffer
+ :src-x 0
+ :src-y 0
+ :mask-x 0
+ :mask-y 0
+ :dst-x x
+ :dst-y y
+ :width width
+ :height height))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-clip))
+ (setf border-clip nil)))
+
+(defun exwm-cm--paint (&optional region)
+ "Paint the whole tree within clipping region REGION.
+
+If REGION is omitted, `exwm-cm--damages' is assumed. If it's t, paint
+the whole screen."
+ ;; Prepare the clipping region.
+ (cond
+ ((null region)
+ (when exwm-cm--damages
+ (setq region exwm-cm--damages)))
+ ((eq region t)
+ (with-slots (width height) (exwm-cm--xwin->attr exwm--root)
+ (let ((rect (make-instance 'xcb:RECTANGLE
+ :x 0
+ :y 0
+ :width width
+ :height height)))
+ (setq region (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region region
+ :rectangles (list rect)))))))
+ (when region
+ ;; Prepare the rendering buffer.
+ (unless exwm-cm--buffer
+ (let ((pixmap (xcb:generate-id exwm-cm--conn))
+ (picture (xcb:generate-id exwm-cm--conn)))
+ (setq exwm-cm--buffer picture)
+ (with-slots (width height visual) (exwm-cm--xwin->attr exwm--root)
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:CreatePixmap
+ :depth exwm-cm--depth
+ :pid pixmap
+ :drawable exwm--root
+ :width width
+ :height height))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:CreatePicture
+ :pid picture
+ :drawable pixmap
+ :format (xcb:renderutil:find-visual-format
+ (xcb:renderutil:query-formats
+ exwm-cm--conn)
+ visual)
+ :value-mask 0)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:FreePixmap
+ :pixmap pixmap))))
+ (let (queue)
+ ;; Paint opaque X windows and update clipping region.
+ (setq queue (exwm-cm--paint-tree nil region))
+ ;; Paint the background.
+ (exwm-cm--paint-background region)
+ ;; Paint transparent X windows.
+ (while queue
+ (exwm-cm--paint-transparent (pop queue))))
+ ;; Submit changes.
+ (with-slots (width height picture) (exwm-cm--xwin->attr exwm--root)
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:SetPictureClipRegion
+ :picture exwm-cm--buffer
+ :region xcb:xfixes:Region:None
+ :x-origin 0
+ :y-origin 0))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:Composite
+ :op xcb:render:PictOp:Src
+ :src exwm-cm--buffer
+ :mask xcb:render:Picture:None
+ :dst picture
+ :src-x 0
+ :src-y 0
+ :mask-x 0
+ :mask-y 0
+ :dst-x 0
+ :dst-y 0
+ :width width
+ :height height)))
+ ;; Cleanup.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region region))
+ (when (eq region exwm-cm--damages)
+ (setq exwm-cm--damages nil))
+ (setq exwm-cm--clip-changed nil)
+ (xcb:flush exwm-cm--conn)))
+
+(defun exwm-cm--paint-background (region)
+ "Paint the background."
+ (unless exwm-cm--background
+ (setq exwm-cm--background (xcb:generate-id exwm-cm--conn))
+ (let (pixmap exist)
+ (catch 'break
+ (dolist (atom exwm-cm--background-atoms)
+ (with-slots (~lsb format value-len value)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetProperty
+ :delete 0
+ :window exwm--root
+ :property atom
+ :type xcb:Atom:PIXMAP
+ :long-offset 0
+ :long-length 4))
+ (when (and (= format 32)
+ (= 1 value-len))
+ (setq pixmap (if ~lsb
+ (xcb:-unpack-u4-lsb value 0)
+ (xcb:-unpack-u4 value 0)))
+ (setq exist t)
+ (throw 'break nil)))))
+ (unless pixmap
+ (setq pixmap (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:CreatePixmap
+ :depth exwm-cm--depth
+ :pid pixmap
+ :drawable exwm--root
+ :width 1
+ :height 1)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:CreatePicture
+ :pid exwm-cm--background
+ :drawable pixmap
+ :format (xcb:renderutil:find-visual-format
+ (xcb:renderutil:query-formats exwm-cm--conn)
+ (slot-value (exwm-cm--xwin->attr exwm--root)
+ 'visual))
+ :value-mask xcb:render:CP:Repeat
+ :repeat 1))
+ (unless exist
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FillRectangles
+ :op xcb:render:PictOp:Src
+ :dst exwm-cm--background
+ :color (make-instance 'xcb:render:COLOR
+ :red #x8080
+ :green #x8080
+ :blue #x8080
+ :alpha #xFFFF)
+ :rects (list (make-instance 'xcb:RECTANGLE
+ :x 0
+ :y 0
+ :width 1
+ :height 1)))))))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:SetPictureClipRegion
+ :picture exwm-cm--buffer
+ :region region
+ :x-origin 0
+ :y-origin 0))
+ (with-slots (width height) (exwm-cm--xwin->attr exwm--root)
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:Composite
+ :op xcb:render:PictOp:Src
+ :src exwm-cm--background
+ :mask xcb:render:Picture:None
+ :dst exwm-cm--buffer
+ :src-x 0
+ :src-y 0
+ :mask-x 0
+ :mask-y 0
+ :dst-x 0
+ :dst-y 0
+ :width width
+ :height height))))
+
+(defun exwm-cm--map-xwin (xwin &optional silent)
+ "Prepare to map X window XWIN."
+ (let ((attr (exwm-cm--xwin->attr xwin)))
+ (setf (slot-value attr 'damaged) nil)
+ ;; Add to damage.
+ (when (slot-value attr 'extents)
+ (let ((damage (xcb:generate-id exwm-cm--conn)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region damage
+ :rectangles nil))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CopyRegion
+ :source (slot-value attr 'extents)
+ :destination damage))
+ (exwm-cm--add-damage damage))
+ (unless silent
+ (exwm-cm--paint)))))
+
+(defun exwm-cm--on-MapNotify (data _synthetic)
+ "Handle MapNotify events."
+ (let ((obj (make-instance 'xcb:MapNotify))
+ attr)
+ (xcb:unmarshal obj data)
+ (with-slots (event window) obj
+ (exwm--log "(CM) MapNotify: Try to map #x%X" window)
+ (setq attr (exwm-cm--xwin->attr window))
+ (when (and attr
+ (/= (slot-value attr 'class) xcb:WindowClass:InputOnly)
+ (or (= event exwm--root)
+ ;; Filter out duplicated events.
+ (/= exwm--root (exwm-cm--get-parent window))))
+ (exwm--log "(CM) MapNotify: Map")
+ (exwm-cm--map-xwin window)))))
+
+(defun exwm-cm--on-UnmapNotify (data _synthetic)
+ "Handle UnmapNotify events."
+ (let ((obj (make-instance 'xcb:UnmapNotify))
+ attr)
+ (xcb:unmarshal obj data)
+ (with-slots (event window) obj
+ (exwm--log "(CM) UnmapNotify: Try to unmap #x%X" window)
+ (setq attr (exwm-cm--xwin->attr window))
+ (when (and attr
+ (or (= event exwm--root)
+ ;; Filter out duplicated events.
+ (/= exwm--root (exwm-cm--get-parent window))))
+ (exwm--log "(CM) UnmapNotify: Unmap")
+ (with-slots (picture damaged border-size extents border-clip) attr
+ (setf damaged nil)
+ (when picture
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FreePicture
+ :picture picture))
+ (setf picture nil))
+ (when border-size
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-size))
+ (setf border-size nil))
+ (when extents
+ (exwm-cm--add-damage extents)
+ (setf extents nil))
+ (when border-clip
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-clip))
+ (setf border-clip nil)))
+ (setq exwm-cm--clip-changed t)
+ (exwm-cm--paint)))))
+
+(defun exwm-cm--on-CreateNotify (data _synthetic)
+ "Handle CreateNotify events."
+ (let ((obj (make-instance 'xcb:CreateNotify))
+ tree0)
+ (xcb:unmarshal obj data)
+ (with-slots (window parent x y width height) obj
+ (exwm--log "(CM) CreateNotify: Create #x%X on #x%X @%sx%s%+d%+d"
+ window parent width height x y)
+ (cl-assert (= parent exwm--root))
+ (cl-assert (null (exwm-cm--xwin->attr window)))
+ (setq tree0 (exwm-cm--get-subtree parent))
+ (exwm-cm--create-attr window tree0 x y width height)
+ (if (cdr tree0)
+ (exwm-cm--push (list window) (cdr tree0))
+ (setcdr tree0 `((,window)))))))
+
+(defun exwm-cm--on-ConfigureNotify (data synthetic)
+ "Handle ConfigureNotify events."
+ ;; Ignore synthetic ConfigureNotify events sent by the WM.
+ (unless synthetic
+ (let ((obj (make-instance 'xcb:ConfigureNotify)))
+ (xcb:unmarshal obj data)
+ (with-slots (event window above-sibling x y width height) obj
+ (exwm--log
+ "(CM) ConfigureNotify: Try to configure #x%X @%sx%s%+d%+d, above #x%X"
+ window width height x y above-sibling)
+ (cond
+ ((= window exwm--root)
+ (exwm--log "(CM) ConfigureNotify: Configure the root X window")
+ (when exwm-cm--buffer
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FreePicture
+ :picture exwm-cm--buffer))
+ (setq exwm-cm--buffer nil))
+ (with-slots ((x* x)
+ (y* y)
+ (width* width)
+ (height* height))
+ (exwm-cm--xwin->attr exwm--root)
+ (setf x* x
+ y* y
+ width* width
+ height* height))
+ (exwm-cm--paint))
+ ((null (exwm-cm--xwin->attr window)))
+ ((or (= event exwm--root)
+ ;; Filter out duplicated events.
+ (/= exwm--root (exwm-cm--get-parent window)))
+ (exwm--log "(CM) ConfigureNotify: Configure")
+ (with-slots ((x0 x)
+ (y0 y))
+ (exwm-cm--xwin->attr (exwm-cm--get-parent window))
+ (exwm-cm--update-geometry window (+ x x0) (+ y y0) width height
+ above-sibling))
+ (setq exwm-cm--clip-changed t)
+ (exwm-cm--paint))
+ (t
+ (exwm--log "(CM) ConfigureNotify: Skip event from #x%X" event)))))))
+
+(defun exwm-cm--destroy (xwin)
+ "Prepare to destroy X window XWIN."
+ (with-slots (tree picture alpha-picture damage
+ border-size extents border-clip)
+ (exwm-cm--xwin->attr xwin)
+ (cl-assert (assq xwin (cdr tree)))
+ (if (= 1 (length (cdr tree)))
+ (setcdr tree nil)
+ (exwm-cm--assq-delete-all xwin (cdr tree)))
+ (remhash xwin exwm-cm--hash)
+ ;; Release resources.
+ (when picture
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FreePicture
+ :picture picture))
+ (setf picture nil))
+ (when alpha-picture
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FreePicture
+ :picture alpha-picture))
+ (setf alpha-picture nil))
+ (when damage
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:damage:Destroy
+ :damage damage))
+ (setf damage nil))
+ (when border-size
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-size))
+ (setf border-size nil))
+ (when extents
+ (exwm-cm--add-damage extents)
+ (setf extents nil))
+ (when border-clip
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region border-clip))
+ (setf border-clip nil))))
+
+(defun exwm-cm--on-DestroyNotify (data _synthetic)
+ "Handle DestroyNotify events."
+ (let ((obj (make-instance 'xcb:DestroyNotify))
+ xwin)
+ (xcb:unmarshal obj data)
+ (setq xwin (slot-value obj 'window))
+ (exwm--log "(CM) DestroyNotify: Try to destroy #x%X" xwin)
+ (when (exwm-cm--xwin->attr xwin)
+ (exwm--log "(CM) DestroyNotify: Destroy")
+ (exwm-cm--destroy xwin))))
+
+(defun exwm-cm--on-CirculateNotify (data _synthetic)
+ "Handle CirculateNotify events."
+ (let ((obj (make-instance 'xcb:CirculateNotify))
+ attr)
+ (xcb:unmarshal obj data)
+ (with-slots (event window place) obj
+ (setq attr (exwm-cm--xwin->attr window))
+ (exwm--log "(CM) CirculateNotify: Try to circulate #x%X to %s"
+ window place)
+ (when (and attr
+ (or (= event exwm--root)
+ ;; Filter out duplicated events.
+ (/= exwm--root (exwm-cm--get-parent window))))
+ (exwm--log "(CM) CirculateNotify: Circulate")
+ (exwm-cm--update-geometry window nil nil nil nil
+ (if (= place xcb:Circulate:LowerHighest)
+ xcb:Window:None
+ (caar (exwm-cm--get-siblings window))))
+ (setq exwm-cm--clip-changed t)
+ (exwm-cm--paint)))))
+
+(defun exwm-cm--on-Expose (data _synthetic)
+ "Handle Expose events."
+ (let ((obj (make-instance 'xcb:Expose)))
+ (xcb:unmarshal obj data)
+ (with-slots (window x y width height count) obj
+ (when (eq window exwm--root)
+ (push (make-instance 'xcb:RECTANGLE
+ :x x
+ :y y
+ :width width
+ :height height)
+ exwm-cm--expose-rectangles))
+ (when (= count 0)
+ (let ((region (xcb:generate-id exwm-cm--conn)))
+ (xcb:+request exwm-cm--conn
+ (xcb:xfixes:CreateRegion
+ :region region
+ :rectangles exwm-cm--expose-rectangles))
+ (exwm-cm--add-damage region))
+ (setq exwm-cm--expose-rectangles nil)
+ (exwm-cm--paint)))))
+
+(defun exwm-cm--on-PropertyNotify (data _synthetic)
+ "Handle PropertyNotify events."
+ (let ((obj (make-instance 'xcb:PropertyNotify)))
+ (xcb:unmarshal obj data)
+ (with-slots (window atom) obj
+ (cond
+ ((and (= window exwm--root)
+ (memq atom exwm-cm--background-atoms))
+ (exwm--log "(CM) PropertyNotify: Update background")
+ (when exwm-cm--background
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:FreePicture
+ :picture exwm-cm--background))
+ (setq exwm-cm--background nil)
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:ClearArea
+ :exposures 1
+ :window exwm--root
+ :x 0
+ :y 0
+ :width 0
+ :height 0))
+ (xcb:flush exwm-cm--conn)))
+ ((and (= atom exwm-cm--_NET_WM_WINDOW_OPACITY)
+ ;; Some applications also set this property on their parents.
+ (null (cdr (exwm-cm--get-subtree window))))
+ (when (exwm-cm--xwin->attr window)
+ (exwm--log "(CM) PropertyNotify: Update opacity for #x%X" window)
+ (exwm-cm--update-opacity window)
+ (exwm-cm--paint)))))))
+
+(defun exwm-cm--prepare-container (xwin)
+ "Make X window XWIN a container by deselecting unnecessary events."
+ (with-slots (damage) (exwm-cm--xwin->attr xwin)
+ (when damage
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:damage:Destroy
+ :damage damage)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:shape:SelectInput
+ :destination-window xwin
+ :enable 0))))
+
+(defun exwm-cm--on-ReparentNotify (data _synthetic)
+ "Handle ReparentNotify events."
+ (let ((obj (make-instance 'xcb:ReparentNotify))
+ tree tree0 grandparent great-grandparent entity)
+ (xcb:unmarshal obj data)
+ (with-slots (window parent x y) obj
+ (exwm--log "(CM) ReparentNotify: Try to reparent #x%X to #x%X @%+d%+d"
+ window parent x y)
+ (cond
+ ((null (exwm-cm--xwin->attr window))
+ (when (eq parent exwm--root)
+ (exwm--log "(CM) ReparentNotify: Create on the root X window")
+ (let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetGeometry
+ :drawable window))))
+ (when reply
+ (with-slots (width height) reply
+ (setq tree0 (exwm-cm--get-subtree exwm--root))
+ (exwm-cm--create-attr window tree0 x y width height)
+ (if (cdr tree0)
+ (exwm-cm--push (list window) (cdr tree0))
+ (setcdr tree0 `((,window)))))
+ (exwm-cm--paint)))))
+ ((= parent (exwm-cm--get-parent window)))
+ (t
+ (unless (exwm-cm--xwin->attr parent)
+ ;; Only allow workspace frame here.
+ (setq grandparent
+ (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:QueryTree
+ :window parent))
+ 'parent))
+ (cond
+ ((null (exwm-cm--xwin->attr grandparent))
+ (exwm--log "(CM) ReparentNotify: Destroy (too deep)"))
+ ((and (= exwm--root
+ (setq great-grandparent (exwm-cm--get-parent grandparent)))
+ (setq tree0 (exwm-cm--get-subtree grandparent))
+ (or (setq entity (exwm--id->buffer window))
+ (null (cdr tree0))))
+ ;; Reparent a workspace frame or an X window into its
+ ;; container.
+ (exwm--debug
+ (if entity
+ (exwm--log "(CM) ReparentNotify: \
+Create implicit X window container")
+ (exwm--log "(CM) ReparentNotify: \
+Create implicit workspace frame container")))
+ (unless entity
+ (setq entity 'workspace-frame))
+ (with-slots ((x0 x)
+ (y0 y))
+ (exwm-cm--xwin->attr grandparent)
+ (with-slots (x y width height)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetGeometry
+ :drawable parent))
+ (exwm-cm--create-attr parent tree0
+ (+ x x0) (+ y y0) width height)))
+ (if (null (cdr tree0))
+ (setcdr tree0 `((,parent)))
+ ;; The stacking order of the parent is unknown.
+ (let* ((siblings
+ (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:QueryTree
+ :window grandparent))
+ 'children)))
+ (cl-assert (memq parent siblings))
+ (if (= parent (car siblings))
+ ;; At the bottom.
+ (setcdr (last (cdr tree0)) `((,parent)))
+ ;; Insert it.
+ (exwm-cm--push (list parent)
+ ;; The stacking order is reversed.
+ (nthcdr (- (length siblings) 1
+ (cl-position parent siblings))
+ (cdr tree0)))))))
+ ((and (= exwm--root
+ (exwm-cm--get-parent great-grandparent))
+ (setq tree0 (exwm-cm--get-subtree grandparent))
+ (= 1 (length (cdr tree0)))
+ (exwm--id->buffer (caar (cdr tree0))))
+ ;; Reparent a floating frame into its container.
+ (exwm--log "(CM) ReparentNotify: Create floating frame container")
+ (setq entity 'floating-frame)
+ (with-slots ((x0 x)
+ (y0 y))
+ (exwm-cm--xwin->attr grandparent)
+ (with-slots (x y width height)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetGeometry
+ :drawable parent))
+ (exwm-cm--create-attr parent tree0
+ (+ x x0) (+ y y0) width height)))
+ (nconc (cdr tree0) `((,parent))))
+ (t
+ (exwm--log "(CM) ReparentNotify: Destroy")
+ (exwm-cm--destroy window))))
+ ;; Ensure there's a valid parent.
+ (when (exwm-cm--xwin->attr parent)
+ (exwm--log "(CM) ReparentNotify: Reparent")
+ (when (null (cdr (exwm-cm--get-subtree parent)))
+ ;; The parent is a new container.
+ (exwm-cm--prepare-container parent))
+ (setq tree (exwm-cm--get-subtree window))
+ (let ((tree (exwm-cm--get-tree window)))
+ (if (= 1 (length (cdr tree)))
+ (setcdr tree nil)
+ (exwm-cm--assq-delete-all window (cdr tree))))
+ (setq tree0 (exwm-cm--get-subtree parent))
+ (exwm-cm--set-tree window tree0)
+ ;; The size might have already changed (e.g. when reparenting
+ ;; a workspace frame).
+ (let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetGeometry
+ :drawable window))))
+ ;; The X window might have already been destroyed.
+ (when reply
+ (with-slots (width height) reply
+ (with-slots ((x0 x)
+ (y0 y))
+ (exwm-cm--xwin->attr parent)
+ (exwm-cm--update-geometry window (+ x x0) (+ y y0)
+ width height)))))
+ (when entity
+ ;; Decide frame entity.
+ (when (symbolp entity)
+ (catch 'break
+ (dolist (f (if (eq entity 'workspace-frame)
+ exwm-workspace--list
+ (frame-list)))
+ (when (eq window (frame-parameter f 'exwm-outer-id))
+ (setq entity f)
+ (throw 'break nil))))
+ (when (exwm-workspace--workspace-p entity)
+ ;; The grandparent is a new workspace container.
+ (exwm-cm--prepare-container grandparent)
+ (setf (slot-value (exwm-cm--xwin->attr grandparent) 'entity)
+ entity)))
+ (setf (slot-value (exwm-cm--xwin->attr parent) 'entity) entity)
+ (setf (slot-value (exwm-cm--xwin->attr window) 'entity) entity))
+ (if (cdr tree0)
+ (exwm-cm--push tree (cdr tree0))
+ (setcdr tree0 `(,tree)))
+ (exwm-cm--paint)))))))
+
+(defun exwm-cm--add-damage (damage)
+ "Add region DAMAGE to `exwm-cm--damages'."
+ (if (not exwm-cm--damages)
+ (setq exwm-cm--damages damage)
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:UnionRegion
+ :source1 exwm-cm--damages
+ :source2 damage
+ :destination exwm-cm--damages))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region damage))))
+
+(defun exwm-cm--on-DamageNotify (data _synthetic)
+ "Handle DamageNotify events."
+ (let ((obj (make-instance 'xcb:damage:Notify))
+ parts)
+ (xcb:unmarshal obj data)
+ (cl-assert (exwm-cm--xwin->attr (slot-value obj 'drawable)))
+ (with-slots (x y width height damaged damage)
+ (exwm-cm--xwin->attr (slot-value obj 'drawable))
+ (setq parts (xcb:generate-id exwm-cm--conn))
+ (cond
+ (damaged
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region parts
+ :rectangles nil))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:damage:Subtract
+ :damage damage
+ :repair xcb:xfixes:Region:None
+ :parts parts))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:TranslateRegion
+ :region parts
+ :dx x
+ :dy y)))
+ (t
+ (setf damaged t)
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region parts
+ :rectangles (list (make-instance 'xcb:RECTANGLE
+ :width width
+ :height height
+ :x x
+ :y y))))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:damage:Subtract
+ :damage damage
+ :repair xcb:xfixes:Region:None
+ :parts xcb:xfixes:Region:None))))
+ (exwm-cm--add-damage parts))
+ ;; Check if there are more damages immediately followed.
+ (unless (/= 0 (logand #x80 (slot-value obj 'level)))
+ (exwm-cm--paint))))
+
+(defun exwm-cm--on-ShapeNotify (data _synthetic)
+ "Handle ShapeNotify events."
+ (let ((obj (make-instance 'xcb:shape:Notify))
+ attr region1 region2)
+ (xcb:unmarshal obj data)
+ (with-slots (shape-kind affected-window shaped
+ extents-x extents-y extents-width extents-height)
+ obj
+ (exwm--log "(CM) ShapeNotify: #x%X" affected-window)
+ (when (and (or (eq shape-kind xcb:shape:SK:Clip)
+ (eq shape-kind xcb:shape:SK:Bounding))
+ (setq attr (exwm-cm--xwin->attr affected-window)))
+ (with-slots ((shaped* shaped)
+ x y width height
+ shape-x shape-y shape-width shape-height)
+ attr
+ (setq region1 (xcb:generate-id exwm-cm--conn)
+ region2 (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region region1
+ :rectangles `(,(make-instance 'xcb:RECTANGLE
+ :width shape-width
+ :height shape-height
+ :x shape-x
+ :y shape-y))))
+ (if shaped
+ (setf shaped* t
+ shape-x (+ x extents-x)
+ shape-y (+ y extents-y)
+ shape-width (+ width extents-width)
+ shape-height (+ height extents-height))
+ (setf shaped* nil
+ shape-x x
+ shape-y y
+ shape-width width
+ shape-height height))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:CreateRegion
+ :region region2
+ :rectangles `(,(make-instance 'xcb:RECTANGLE
+ :width shape-width
+ :height shape-height
+ :x shape-x
+ :y shape-y))))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:UnionRegion
+ :source1 region1
+ :source2 region2
+ :destination region1))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:xfixes:DestroyRegion
+ :region region2))
+ (setq exwm-cm--clip-changed t)
+ (exwm-cm--paint region1))))))
+
+(defun exwm-cm--init ()
+ "Initialize EXWM compositing manager."
+ ;; Create a new connection.
+ (setq exwm-cm--conn (xcb:connect))
+ (set-process-query-on-exit-flag (slot-value exwm-cm--conn 'process) nil)
+ ;; Initialize ICCCM/EWMH support.
+ (xcb:icccm:init exwm-cm--conn)
+ (xcb:ewmh:init exwm-cm--conn)
+ ;; Check for Render extension.
+ (let ((version (xcb:renderutil:query-version exwm-cm--conn)))
+ (unless (and version
+ (= 0 (slot-value version 'major-version))
+ (<= 2 (slot-value version 'minor-version)))
+ (error "[EXWM] The server does not support Render extension")))
+ ;; Check for Composite extension.
+ (when (or (= 0
+ (slot-value (xcb:get-extension-data exwm-cm--conn
+ 'xcb:composite)
+ 'present))
+ (with-slots (major-version minor-version)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:composite:QueryVersion
+ :client-major-version 0
+ :client-minor-version 1))
+ (or (/= major-version 0) (< minor-version 1))))
+ (error "[EXWM] The server does not support Composite extension"))
+ ;; Check for Damage extension.
+ (when (or (= 0 (slot-value (xcb:get-extension-data exwm-cm--conn 'xcb:damage)
+ 'present))
+ (with-slots (major-version minor-version)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:damage:QueryVersion
+ :client-major-version 1
+ :client-minor-version 1))
+ (or (/= major-version 1) (< minor-version 1))))
+ (error "[EXWM] The server does not support Damage extension"))
+ ;; Check for XFixes extension.
+ (when (or (= 0 (slot-value (xcb:get-extension-data exwm-cm--conn 'xcb:xfixes)
+ 'present))
+ (with-slots (major-version minor-version)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:xfixes:QueryVersion
+ :client-major-version 2
+ :client-minor-version 0))
+ (or (/= major-version 2) (/= minor-version 0))))
+ (error "[EXWM] The server does not support XFixes extension"))
+ ;; Check for Shape extension.
+ (when (or (= 0 (slot-value (xcb:get-extension-data exwm-cm--conn 'xcb:shape)
+ 'present))
+ (with-slots (major-version minor-version)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:shape:QueryVersion))
+ (or (/= major-version 1) (< minor-version 1))))
+ (error "[EXWM] The server does not support Shape extension"))
+ ;; Intern atoms.
+ (let ((atom-name "_NET_WM_WINDOW_OPACITY"))
+ (setq exwm-cm--_NET_WM_WINDOW_OPACITY
+ (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:InternAtom
+ :only-if-exists 0
+ :name-len (length atom-name)
+ :name atom-name))
+ 'atom)))
+ (setq exwm-cm--background-atoms
+ (mapcar (lambda (atom-name)
+ (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:InternAtom
+ :only-if-exists 0
+ :name-len (length atom-name)
+ :name atom-name))
+ 'atom))
+ exwm-cm--background-atom-names))
+ ;; Register CM.
+ (with-slots (owner)
+ (xcb:+request-unchecked+reply exwm-cm--conn
+ (make-instance 'xcb:GetSelectionOwner
+ :selection xcb:Atom:_NET_WM_CM_S0))
+ (when (/= owner xcb:Window:None)
+ (error "[EXWM] Other compositing manager detected")))
+ (let ((id (xcb:generate-id exwm-cm--conn)))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:CreateWindow
+ :depth 0
+ :wid id
+ :parent exwm--root
+ :x 0
+ :y 0
+ :width 1
+ :height 1
+ :border-width 0
+ :class xcb:WindowClass:InputOnly
+ :visual 0
+ :value-mask xcb:CW:OverrideRedirect
+ :override-redirect 1))
+ ;; Set _NET_WM_NAME.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:ewmh:set-_NET_WM_NAME
+ :window id
+ :data "EXWM-CM"))
+ ;; Get the selection ownership.
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:SetSelectionOwner
+ :owner id
+ :selection xcb:Atom:_NET_WM_CM_S0
+ :time xcb:Time:CurrentTime)))
+ ;; Attach event listeners.
+ (xcb:+event exwm-cm--conn 'xcb:MapNotify #'exwm-cm--on-MapNotify)
+ (xcb:+event exwm-cm--conn 'xcb:UnmapNotify #'exwm-cm--on-UnmapNotify)
+ (xcb:+event exwm-cm--conn 'xcb:CreateNotify #'exwm-cm--on-CreateNotify)
+ (xcb:+event exwm-cm--conn 'xcb:ConfigureNotify #'exwm-cm--on-ConfigureNotify)
+ (xcb:+event exwm-cm--conn 'xcb:DestroyNotify #'exwm-cm--on-DestroyNotify)
+ (xcb:+event exwm-cm--conn 'xcb:ReparentNotify #'exwm-cm--on-ReparentNotify)
+ (xcb:+event exwm-cm--conn 'xcb:CirculateNotify #'exwm-cm--on-CirculateNotify)
+ (xcb:+event exwm-cm--conn 'xcb:Expose #'exwm-cm--on-Expose)
+ (xcb:+event exwm-cm--conn 'xcb:PropertyNotify #'exwm-cm--on-PropertyNotify)
+ (xcb:+event exwm-cm--conn 'xcb:damage:Notify #'exwm-cm--on-DamageNotify)
+ (xcb:+event exwm-cm--conn 'xcb:shape:Notify #'exwm-cm--on-ShapeNotify)
+ ;; Scan the window tree.
+ (setq exwm-cm--hash (make-hash-table))
+ (exwm-cm--create-tree)
+ ;; Set up the root X window.
+ (setq exwm-cm--depth
+ (slot-value (car (slot-value (xcb:get-setup exwm-cm--conn) 'roots))
+ 'root-depth))
+ (with-slots (visual picture) (exwm-cm--xwin->attr exwm--root)
+ (setf picture (xcb:generate-id exwm-cm--conn))
+ (xcb:+request exwm-cm--conn
+ (make-instance 'xcb:render:CreatePicture
+ :pid picture
+ :drawable exwm--root
+ :format (xcb:renderutil:find-visual-format
+ (xcb:renderutil:query-formats exwm-cm--conn)
+ visual)
+ :value-mask xcb:render:CP:SubwindowMode
+ :subwindowmode xcb:SubwindowMode:IncludeInferiors)))
+ (xcb:flush exwm-cm--conn)
+ ;; Paint once.
+ (exwm-cm--paint t))
+
+(defun exwm-cm--exit ()
+ "Exit EXWM compositing manager."
+ (when exwm-cm--conn
+ (xcb:disconnect exwm-cm--conn)
+ (clrhash exwm-cm--hash)
+ (setq exwm-cm--hash nil
+ exwm-cm--conn nil
+ exwm-cm--buffer nil
+ exwm-cm--clip-changed t
+ exwm-cm--damages nil
+ exwm-cm--expose-rectangles nil
+ exwm-cm--background nil)))
+
+(defun exwm-cm-enable ()
+ "Enable compositing support for EXWM."
+ (add-hook 'exwm-init-hook #'exwm-cm--init t)
+ (add-hook 'exwm-exit-hook #'exwm-cm--exit t))
+
+(defun exwm-cm-start ()
+ "Start EXWM composting manager."
+ (interactive)
+ (unless exwm-cm--conn
+ (exwm-cm--init)))
+
+(defun exwm-cm-stop ()
+ "Stop EXWM compositing manager."
+ (interactive)
+ (exwm-cm--exit))
+
+(defun exwm-cm-toggle ()
+ "Toggle the running state of EXWM compositing manager."
+ (interactive)
+ (if exwm-cm--conn
+ (exwm-cm-stop)
+ (exwm-cm-start)))
+
+
+
+(provide 'exwm-cm)
+
+;;; exwm-cm.el ends here