diff options
Diffstat (limited to 'exwm-background.el')
| -rw-r--r-- | exwm-background.el | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/exwm-background.el b/exwm-background.el new file mode 100644 index 000000000000..e7a0360c97c0 --- /dev/null +++ b/exwm-background.el @@ -0,0 +1,201 @@ +;;; exwm-background.el --- X Background Module for EXWM -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Steven Allen <steven@stebalien.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 adds X background color setting support to EXWM. + +;; To use this module, load and enable it as follows: +;; (require 'exwm-background) +;; (exwm-background-enable) +;; +;; By default, this will apply the theme's background color. However, that +;; color can be customized via the `exwm-background-color' setting. + +;;; Code: + +(require 'exwm-core) + +(defcustom exwm-background-color nil + "Background color for Xorg." + :type '(choice + (color :tag "Background Color") + (const :tag "Default" nil)) + :group 'exwm + :initialize #'custom-initialize-default + :set (lambda (symbol value) + (set-default-toplevel-value symbol value) + (exwm-background--update))) + +(defconst exwm-background--properties '("_XROOTPMAP_ID" "_XSETROOT_ID" "ESETROOT_PMAP_ID") + "The background properties to set. +We can't need to set these so that compositing window managers can correctly display the background +color.") + +(defvar exwm-background--connection nil + "The X connection used for setting the background. +We use a separate connection as other background-setting tools may kill this connection when they +replace it.") + +(defvar exwm-background--pixmap nil + "Cached background pixmap.") + +(defvar exwm-background--atoms nil + "Cached background atoms.") + +(defun exwm-background--update (&rest _) + "Update the EXWM background." + + ;; Always reconnect as any tool that sets the background may have disconnected us (to force X to + ;; free resources). + (exwm-background--connect) + + (let ((gc (xcb:generate-id exwm-background--connection)) + (color (exwm--color->pixel (or exwm-background-color + (face-background 'default))))) + ;; Fill the pixmap. + (xcb:+request exwm-background--connection + (make-instance 'xcb:CreateGC + :cid gc :drawable exwm-background--pixmap + :value-mask (logior xcb:GC:Foreground + xcb:GC:GraphicsExposures) + :foreground color + :graphics-exposures 0)) + + (xcb:+request exwm-background--connection + (make-instance 'xcb:PolyFillRectangle + :gc gc :drawable exwm-background--pixmap + :rectangles + (list + (make-instance + 'xcb:RECTANGLE + :x 0 :y 0 :width 1 :height 1)))) + (xcb:+request exwm-background--connection (make-instance 'xcb:FreeGC :gc gc))) + + ;; Reapply it to force an update (also clobber anyone else who may have set it). + (xcb:+request exwm-background--connection + (make-instance 'xcb:ChangeWindowAttributes + :window exwm--root + :value-mask xcb:CW:BackPixmap + :background-pixmap exwm-background--pixmap)) + + (let (old) + ;; Collect old pixmaps so we can kill other background clients (all the background setting tools + ;; seem to do this). + (dolist (atom exwm-background--atoms) + (when-let* ((reply (xcb:+request-unchecked+reply exwm-background--connection + (make-instance 'xcb:GetProperty + :delete 0 + :window exwm--root + :property atom + :type xcb:Atom:PIXMAP + :long-offset 0 + :long-length 1))) + (value (vconcat (slot-value reply 'value))) + ((length= value 4)) + (pixmap (funcall (if xcb:lsb #'xcb:-unpack-u4-lsb #'xcb:-unpack-u4) + value 0)) + ((not (or (= pixmap exwm-background--pixmap) + (member pixmap old))))) + (push pixmap old))) + + ;; Change the background. + (dolist (atom exwm-background--atoms) + (xcb:+request exwm-background--connection + (make-instance 'xcb:ChangeProperty + :window exwm--root + :property atom + :type xcb:Atom:PIXMAP + :format 32 + :mode xcb:PropMode:Replace + :data-len 1 + :data + (funcall (if xcb:lsb + #'xcb:-pack-u4-lsb + #'xcb:-pack-u4) + exwm-background--pixmap)))) + + ;; Kill the old background clients. + (dolist (pixmap old) + (xcb:+request exwm-background--connection + (make-instance 'xcb:KillClient :resource pixmap)))) + + (xcb:flush exwm-background--connection)) + +(defun exwm-background--connected-p () + (and exwm-background--connection + (process-live-p (slot-value exwm-background--connection 'process)))) + +(defun exwm-background--connect () + (unless (exwm-background--connected-p) + (setq exwm-background--connection (xcb:connect)) + ;;prevent query message on exit + (set-process-query-on-exit-flag (slot-value exwm-background--connection 'process) nil) + + ;; Intern the background property atoms. + (setq exwm-background--atoms + (mapcar + (lambda (prop) (exwm--intern-atom prop exwm-background--connection)) + exwm-background--properties)) + + ;; Create the pixmap. + (setq exwm-background--pixmap (xcb:generate-id exwm-background--connection)) + (xcb:+request exwm-background--connection + (make-instance 'xcb:CreatePixmap + :depth + (slot-value + (xcb:+request-unchecked+reply exwm-background--connection + (make-instance 'xcb:GetGeometry :drawable exwm--root)) + 'depth) + :pid exwm-background--pixmap + :drawable exwm--root + :width 1 :height 1)))) + +(defun exwm-background--init () + "Initialize background module." + (exwm--log) + + (add-hook 'enable-theme-functions 'exwm-background--update) + (add-hook 'disable-theme-functions 'exwm-background--update) + + (exwm-background--update)) + +(defun exwm-background--exit () + "Uninitialize the background module." + (exwm--log) + + (remove-hook 'enable-theme-functions 'exwm-background--update) + (remove-hook 'disable-theme-functions 'exwm-background--update) + (when exwm-background--connection + (xcb:disconnect exwm-background--connection)) + (setq exwm-background--pixmap nil + exwm-background--connection nil + exwm-background--atoms nil)) + +(defun exwm-background-enable () + "Enable background support for EXWM." + (exwm--log) + (add-hook 'exwm-init-hook #'exwm-background--init) + (add-hook 'exwm-exit-hook #'exwm-background--exit)) + +(provide 'exwm-background) + +;;; exwm-background.el ends here |