master 5e83c0117e: Fix setting the wallpaper with "swaybg" and "wbg"

[Stefan Kangas]

branch: master
commit 5e83c0117e822536aea4bd5db8f97ab7e9224ec3
Author: Stefan Kangas <stefankangas@gmail.com>
Commit: Stefan Kangas <stefankangas@gmail.com>

    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'.  (Bug#57781)
    
    * 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 ab3df437d9..f083477ddf 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 @@ the image file to set the wallpaper to.")
                   (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 @@ COMMAND is the executable to run to set the wallpaper.
 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 @@ and returns non-nil if this setter should be used."
     "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 @@ order in which they appear.")
 
 (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)
@@ -486,28 +520,36 @@ This is the default function for 
`wallpaper-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)))))