bug#57781: missing wallpaper command

[Stefan Kangas <stefankangas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 529 bytes --]

Felix <felix.dick@web.de> writes:

> I'm switching back and forth from Xorg to wayland and I'm
> tinkering with different desktops/WMs anyways.
> I would be happy to help!
> I will try wallpaper.el with gnome tomorrow.
> If there are any things you want me
> to test, just let me know.

I believe the attached patch will fix setting the wallpaper using
swaybg/wbg.  It will prompt to kill any existing swaybg/wbg processes,
and start a new process that should survive exiting Emacs.

I would appreciate any help with testing it.

[-- Attachment #2: 0001-Fix-setting-the-wallpaper-with-swaybg-and-wbg.patch --]
[-- Type: text/x-diff, Size: 12251 bytes --]

From 26c0f54dd23ed1f76f7807ef6d59cc9a026b24ee Mon Sep 17 00:00:00 2001
From: Stefan Kangas <stefankangas@gmail.com>
Date: Tue, 4 Oct 2022 02:45:53 +0200
Subject: [PATCH] Fix setting the wallpaper with "swaybg" and "wbg"

* lisp/image/wallpaper.el (wallpaper-setter): Add 'init-action'
and 'detach' fields to structure.
(wallpaper--init-action-kill): New helper function.
(wallpaper--default-setters): Use above new fields for "swaybg" and
"wbg", to start/restart the corresponding processes as needed.
(wallpaper-default-set-function): Call 'init-action' function if
there is one.  If 'detach', use 'call-process' instead of
'start-process'.

* test/lisp/image/wallpaper-tests.el (wallpaper--find-setter)
(wallpaper--find-setter/call-predicate)
(wallpaper--find-setter/set-current-setter)
(wallpaper-set/runs-command, wallpaper-set/runs-command/detach)
(wallpaper-set/calls-init-action)
(wallpaper-set/calls-wallpaper-set-function): New tests.
---
 lisp/image/wallpaper.el            | 100 ++++++++++++++++++++---------
 test/lisp/image/wallpaper-tests.el |  95 +++++++++++++++++++++++++++
 2 files changed, 166 insertions(+), 29 deletions(-)

diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el
index e23b65d616..2912576561 100644
--- a/lisp/image/wallpaper.el
+++ b/lisp/image/wallpaper.el
@@ -26,7 +26,8 @@
 ;; desktop background.
 ;;
 ;; On GNU/Linux and other Unix-like systems, it uses an external
-;; command to set the desktop background.
+;; command to set the desktop background.  This should work seamlessly
+;; on both X and Wayland.
 ;;
 ;; Finding an external command to use is obviously a bit tricky to get
 ;; right, as there is no lack of platforms, window managers, desktop
@@ -94,9 +95,11 @@ wallpaper--use-default-set-function-p
                   (args (if (or (listp args-raw) (symbolp args-raw))
                             args-raw
                           (string-split args-raw)))
-                  (predicate (plist-get rest-plist :predicate))))
+                  (predicate (plist-get rest-plist :predicate))
+                  (init-action (plist-get rest-plist :init-action))
+                  (detach (plist-get rest-plist :detach))))
                (:copier wallpaper-setter-copy))
-  "Structure containing a command to set the wallpaper.
+  "Structure containing a method to set the wallpaper.
 
 NAME is a description of the setter (e.g. the name of the Desktop
 Environment).
@@ -106,15 +109,41 @@ wallpaper--use-default-set-function-p
 ARGS is the default list of command line arguments for COMMAND.
 
 PREDICATE is a function that will be called without any arguments
-and returns non-nil if this setter should be used."
+and returns non-nil if this setter should be used.
+
+INIT-ACTION is a function that will be called without any
+arguments before trying to set the wallpaper.
+
+DETACH, if non-nil, means that the wallpaper process should
+continue running even after exiting Emacs."
   name
   command
   args
-  (predicate #'always))
+  (predicate #'always)
+  init-action
+  detach)
 
 ;;;###autoload
 (put 'wallpaper-setter-create 'lisp-indent-function 1)
 
+(defun wallpaper--init-action-kill (process-name)
+  "Return kill function for `init-action' of a `wallpaper-setter' structure.
+The returned function kills any process named PROCESS-NAME owned
+by the current effective user id."
+  (lambda ()
+    (when-let ((procs
+                (seq-filter (lambda (p) (let-alist p
+                                     (and (= .euid (user-uid))
+                                          (equal .comm process-name))))
+                            (mapcar (lambda (pid)
+                                      (cons (cons 'pid pid)
+                                            (process-attributes pid)))
+                                    (list-system-processes)))))
+      (dolist (proc procs)
+        (let-alist proc
+          (when (y-or-n-p (format "Kill \"%s\" process with PID %d?" .comm .pid))
+            (signal-process .pid 'TERM)))))))
+
 (defmacro wallpaper--default-methods-create (&rest items)
   "Helper macro for defining `wallpaper--default-setters'."
   (cons 'list
@@ -198,12 +227,16 @@ wallpaper--default-setters
     "swaybg" "-o * -i %f -m fill"
     :predicate (lambda ()
                  (and (getenv "WAYLAND_DISPLAY")
-                      (getenv "SWAYSOCK"))))
+                      (getenv "SWAYSOCK")))
+    :init-action (wallpaper--init-action-kill "swaybg")
+    :detach t)
 
    ("wbg"
     "wbg" "%f"
     :predicate (lambda ()
-                 (getenv "WAYLAND_DISPLAY")))
+                 (getenv "WAYLAND_DISPLAY"))
+    :init-action (wallpaper--init-action-kill "wbg")
+    :detach t)
 
    ;; X general.
    ("GraphicsMagick"
@@ -257,7 +290,8 @@ wallpaper--current-setter
 
 (defun wallpaper--find-setter ()
   (when (wallpaper--use-default-set-function-p)
-    (or wallpaper--current-setter
+    (or (and (wallpaper-setter-p wallpaper--current-setter)
+             wallpaper--current-setter)
         (setq wallpaper--current-setter
               (catch 'found
                 (dolist (setter wallpaper--default-setters)
@@ -482,28 +516,36 @@ wallpaper-default-set-function
          (real-args (mapcar (lambda (arg) (wallpaper--format-arg arg file))
                             args))
          (bufname (format " *wallpaper-%s*" (random)))
-         (process
-          (and wallpaper-command
-               (apply #'start-process "set-wallpaper" bufname
-                      wallpaper-command real-args))))
-    (unless wallpaper-command
-      (error "Couldn't find a suitable command for setting the wallpaper"))
+         (setter (and (wallpaper-setter-p wallpaper--current-setter)
+                      (equal (wallpaper-setter-command wallpaper--current-setter)
+                             wallpaper-command)
+                      wallpaper--current-setter))
+         (init-action (and setter (wallpaper-setter-init-action setter)))
+         (detach (and setter (wallpaper-setter-detach setter)))
+         process)
+    (when init-action
+      (funcall init-action))
     (wallpaper-debug "Using command: \"%s %s\""
-            wallpaper-command (string-join real-args " "))
-    (setf (process-sentinel process)
-          (lambda (process status)
-            (unwind-protect
-                (if (and (eq (process-status process) 'exit)
-                         (zerop (process-exit-status process)))
-                    (message "Desktop wallpaper changed to %s"
-                             (abbreviate-file-name file))
-                  (message "command \"%s %s\": %S"
-                           (string-join (process-command process) " ")
-                           (string-replace "\n" "" status)
-                           (with-current-buffer (process-buffer process)
-                             (string-clean-whitespace (buffer-string)))))
-              (ignore-errors
-                (kill-buffer (process-buffer process))))))
+                     wallpaper-command (string-join real-args " "))
+    (if detach
+        (apply #'call-process wallpaper-command nil 0 nil real-args)
+      (setq process
+            (apply #'start-process "set-wallpaper" bufname
+                   wallpaper-command real-args))
+      (setf (process-sentinel process)
+            (lambda (process status)
+              (unwind-protect
+                  (if (and (eq (process-status process) 'exit)
+                           (zerop (process-exit-status process)))
+                      (message "Desktop wallpaper changed to %s"
+                               (abbreviate-file-name file))
+                    (message "command \"%s %s\": %S"
+                             (string-join (process-command process) " ")
+                             (string-replace "\n" "" status)
+                             (with-current-buffer (process-buffer process)
+                               (string-clean-whitespace (buffer-string)))))
+                (ignore-errors
+                  (kill-buffer (process-buffer process)))))))
     process))
 
 ;;;###autoload
diff --git a/test/lisp/image/wallpaper-tests.el b/test/lisp/image/wallpaper-tests.el
index 52011fe797..cb6818f8c1 100644
--- a/test/lisp/image/wallpaper-tests.el
+++ b/test/lisp/image/wallpaper-tests.el
@@ -23,6 +23,101 @@
 (require 'ert-x)
 (require 'wallpaper)
 
+(ert-deftest wallpaper--find-setter ()
+  (skip-unless (executable-find "touch"))
+  (let (wallpaper--current-setter
+        (wallpaper--default-setters
+         (wallpaper--default-methods-create
+          ("touch" "touch" "/tmp/touched"))))
+    (should (wallpaper--find-setter))))
+
+(ert-deftest wallpaper--find-setter/call-predicate ()
+  (skip-unless (executable-find "touch"))
+  (let* ( wallpaper--current-setter called
+          (wallpaper--default-setters
+           (wallpaper--default-methods-create
+            ("touch" "touch" "/tmp/touched"
+             :predicate (lambda () (setq called t))))))
+    (should-not called)
+    (wallpaper--find-setter)
+    (should called)))
+
+(ert-deftest wallpaper--find-setter/set-current-setter ()
+  (skip-unless (executable-find "touch"))
+  (let (wallpaper--current-setter
+        (wallpaper--default-setters
+         (wallpaper--default-methods-create
+          ("touch" "touch" "/tmp/touched"))))
+    (wallpaper--find-setter)
+    (should wallpaper--current-setter)))
+
+(ert-deftest wallpaper-set/runs-command ()
+  (skip-unless (executable-find "touch"))
+  (ert-with-temp-file fil-jpg
+    :suffix ".jpg"
+    (ert-with-temp-file fil
+      (let* ( wallpaper--current-setter
+              (wallpaper--default-setters
+               (wallpaper--default-methods-create
+                ("touch" "touch" fil)))
+              (wallpaper-command (wallpaper--find-command))
+              (wallpaper-command-args (wallpaper--find-command-args)))
+        (delete-file fil)
+        (let ((process (wallpaper-set fil-jpg)))
+          (while (process-live-p process)
+            (sit-for 0.001))
+          ;; Touch has recreated the file:
+          (should (file-exists-p fil)))))))
+
+(ert-deftest wallpaper-set/runs-command/detach ()
+  (skip-unless (executable-find "touch"))
+  (ert-with-temp-file fil-jpg
+    :suffix ".jpg"
+    (ert-with-temp-file fil
+      (let* ( wallpaper--current-setter
+              (wallpaper--default-setters
+               (wallpaper--default-methods-create
+                ("touch" "touch" fil
+                 :detach t)))
+              (wallpaper-command (wallpaper--find-command))
+              (wallpaper-command-args (wallpaper--find-command-args)))
+        (delete-file fil)
+        (wallpaper-set fil-jpg)
+        (while (not (file-exists-p fil))
+          (sit-for 0.001))
+        ;; Touch has recreated the file:
+        (should (file-exists-p fil))))))
+
+(ert-deftest wallpaper-set/calls-init-action ()
+  (skip-unless (executable-find "touch"))
+  (ert-with-temp-file fil-jpg
+    :suffix ".jpg"
+    (ert-with-temp-file fil
+      (let* ( wallpaper--current-setter called
+              (wallpaper--default-setters
+               (wallpaper--default-methods-create
+                ("touch" "touch" fil
+                 :init-action (lambda () (setq called t)))))
+              (wallpaper-command (wallpaper--find-command))
+              (wallpaper-command-args (wallpaper--find-command-args)))
+        (should (functionp (wallpaper-setter-init-action wallpaper--current-setter)))
+        (wallpaper-set fil-jpg)
+        (should called)))))
+
+(ert-deftest wallpaper-set/calls-wallpaper-set-function ()
+  (skip-unless (executable-find "touch"))
+  (ert-with-temp-file fil-jpg
+    :suffix ".jpg"
+    (let* ( wallpaper--current-setter called
+            (wallpaper--default-setters
+             (wallpaper--default-methods-create
+              ("touch" "touch" "foo")))
+            (wallpaper-set-function
+             (lambda (file) (setq called file))))
+      (wallpaper--find-setter)
+      (wallpaper-set fil-jpg)
+      (should (equal called fil-jpg)))))
+
 (ert-deftest wallpaper--find-command/return-string ()
   (should (or (not (wallpaper--find-command))
               (stringp (wallpaper--find-command)))))
-- 
2.30.2