[elpa] externals/exwm ac16b9a468 2/3: Merge branch 'stebalien.github.com/feat/background' into externals/exwm

[ELPA Syncer]

branch: externals/exwm
commit ac16b9a4686333c6e67e6f2eba3203712ae785c1
Merge: e9cc0962cc 4e1bb33f37
Author: Adrián Medraño Calvo <adrian@medranocalvo.com>
Commit: Adrián Medraño Calvo <adrian@medranocalvo.com>

    Merge branch 'stebalien.github.com/feat/background' into externals/exwm
---
 exwm-background.el | 201 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 exwm-core.el       |   4 +-
 2 files changed, 203 insertions(+), 2 deletions(-)

diff --git a/exwm-background.el b/exwm-background.el
new file mode 100644
index 0000000000..e7a0360c97
--- /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
diff --git a/exwm-core.el b/exwm-core.el
index 995b590dc5..3215dcdd2c 100644
--- a/exwm-core.el
+++ b/exwm-core.el
@@ -155,9 +155,9 @@ Nil can be passed as placeholder."
                                          (if height xcb:ConfigWindow:Height 0))
                      :x x :y y :width width :height height)))
 
-(defun exwm--intern-atom (atom)
+(defun exwm--intern-atom (atom &optional conn)
   "Intern X11 ATOM."
-  (slot-value (xcb:+request-unchecked+reply exwm--connection
+  (slot-value (xcb:+request-unchecked+reply (or conn exwm--connection)
                   (make-instance 'xcb:InternAtom
                                  :only-if-exists 0
                                  :name-len (length atom)