;;; exwm-background.el --- X Background Module for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2022-2023 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 (and exwm-background--connection
(slot-value exwm-background--connection 'connected))
(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
