procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix setting the wallpaper with "swaybg" and "wbg"

Browse source 
* 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.
This commit is contained in:
Stefan Kangas 2022-10-07 22:07:09 +02:00
parent d6831d1b0a
commit 5e83c0117e
2 changed files with 166 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

100
lisp/image/wallpaper.el
View file

@ -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

95
test/lisp/image/wallpaper-tests.el
View file

@ -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)))))