1778 lines
74 KiB
EmacsLisp
1778 lines
74 KiB
EmacsLisp
;;; exwm-cm.el --- Compositing Manager for EXWM -*- lexical-binding: t -*-
|
||
|
||
;; Copyright (C) 2016 Free Software Foundation, Inc.
|
||
|
||
;; Author: Chris Feng <chris.w.feng@gmail.com>
|
||
|
||
;; 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 compositing 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
|