1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00

Add reasonable default to wallpaper-set

* lisp/image/wallpaper.el
(wallpaper-default-file-name-regexp): New variable.
(wallpaper--get-default-file): New function.
(wallpaper-set): Use above new function to set a default.
* test/lisp/image/wallpaper-tests.el: New file.
This commit is contained in:
Stefan Kangas 2022-09-25 16:16:51 +02:00
parent f761869a56
commit ad88e3e0b5
2 changed files with 72 additions and 8 deletions

View file

@ -1,4 +1,4 @@
;;; wallpaper.el --- Change desktop background from Emacs -*- lexical-binding: t; -*-
;;; wallpaper.el --- Change the desktop background -*- lexical-binding: t; -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
@ -277,6 +277,19 @@ See also `wallpaper-default-width'.")
(funcall fun)
(read-number (format "Wallpaper %s in pixels: " desc) default)))
(autoload 'ffap-file-at-point "ffap")
;; FIXME: This only says which files are supported by Emacs, not by
;; the external tool we use to set the wallpaper.
(defvar wallpaper-default-file-name-regexp (image-file-name-regexp))
(defun wallpaper--get-default-file ()
(catch 'found
(dolist (file (list buffer-file-name (ffap-file-at-point)))
(when (and file (string-match wallpaper-default-file-name-regexp file))
(throw 'found (abbreviate-file-name
(expand-file-name file)))))))
(declare-function w32-set-wallpaper "w32fns.c")
(declare-function haiku-set-wallpaper "term/haiku-win.el")
@ -291,11 +304,15 @@ options `wallpaper-command' and `wallpaper-command-args'.
On MS-Windows and Haiku systems, no external command is needed,
so the value of `wallpaper-commands' is ignored."
(interactive (list (read-file-name "Set desktop background to: "
default-directory nil t nil
(lambda (fn)
(or (file-directory-p fn)
(string-match (image-file-name-regexp) fn))))))
(interactive
(let ((default (wallpaper--get-default-file)))
(list (read-file-name (format-prompt "Set desktop background to" default)
default-directory default
t nil
(lambda (file-name)
(or (file-directory-p file-name)
(string-match wallpaper-default-file-name-regexp
file-name)))))))
(when (file-directory-p file)
(error "Can't set wallpaper to a directory: %s" file))
(unless (file-exists-p file)
@ -331,8 +348,9 @@ so the value of `wallpaper-commands' is ignored."
wallpaper-command-args)))))
(unless wallpaper-command
(error "Couldn't find a suitable command for setting the wallpaper"))
(wallpaper-debug "Using command %S %S" wallpaper-command
wallpaper-command-args)
(wallpaper-debug
"Using command %S %S" wallpaper-command
wallpaper-command-args)
(setf (process-sentinel process)
(lambda (process status)
(unwind-protect

View file

@ -0,0 +1,46 @@
;;; wallpaper-tests.el --- tests for wallpaper.el -*- lexical-binding: t -*-
;; Copyright (C) 2022 Free Software Foundation, Inc.
;; 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 <https://www.gnu.org/licenses/>.
;;; Code:
(require 'ert)
(require 'ert-x)
(require 'wallpaper)
(ert-deftest wallpaper--get-default-file/empty-gives-nil ()
(with-temp-buffer
(should-not (wallpaper--get-default-file))))
(ert-deftest wallpaper--get-default-file/visiting-file ()
(ert-with-temp-file _
:buffer buf
:suffix (format ".%s" (car image-file-name-extensions))
(with-current-buffer buf
(should (wallpaper--get-default-file)))))
(ert-deftest wallpaper--get-default-file/file-at-point ()
;; ffap needs the file to exist
(ert-with-temp-file fil
:buffer buf
:suffix (format ".%s" (car image-file-name-extensions))
(with-current-buffer buf
(insert fil)
(should (stringp (wallpaper--get-default-file))))))
;;; wallpaper-tests.el ends here