diff options
Diffstat (limited to 'exwm-cm.el')
| -rw-r--r-- | exwm-cm.el | 1756 |
1 files changed, 9 insertions, 1747 deletions
diff --git a/exwm-cm.el b/exwm-cm.el index 060dce780bf3..77dd2774a11d 100644 --- a/exwm-cm.el +++ b/exwm-cm.el @@ -21,1765 +21,27 @@ ;;; 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/) +;; This module is obsolete since EXWM now supports third-porty compositors. ;;; 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)))) - -;;;###autoload -(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 clip - (xcb:+request exwm-cm--conn - (make-instance 'xcb:xfixes:DestroyRegion - :region clip))) - (when fullscreen - ;; Fullscreen X windows are always opaque thus occludes - ;; anything in this workspace. - (throw 'break 'fullscreen))) - (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:FreePixmap - :pixmap pixmap)) - (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:FreePixmap - :pixmap pixmap)) - (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)) +(make-obsolete-variable 'exwm-cm-opacity + "This variable should no longer be used." "26") -(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-set-opacity (&rest _args) + (declare (obsolete nil "26"))) (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)) + (declare (obsolete nil "26"))) -;;;###autoload (defun exwm-cm-start () - "Start EXWM compositing manager." - (interactive) - (unless exwm-cm--conn - (exwm-cm--init))) + (declare (obsolete nil "26"))) -;;;###autoload (defun exwm-cm-stop () - "Stop EXWM compositing manager." - (interactive) - (exwm-cm--exit)) + (declare (obsolete nil "26"))) -;;;###autoload (defun exwm-cm-toggle () - "Toggle the running state of EXWM compositing manager." - (interactive) - (if exwm-cm--conn - (exwm-cm-stop) - (exwm-cm-start))) + (declare (obsolete nil "26"))) |