From 26c0f54dd23ed1f76f7807ef6d59cc9a026b24ee Mon Sep 17 00:00:00 2001 From: Stefan Kangas 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