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:
parent
f761869a56
commit
ad88e3e0b5
2 changed files with 72 additions and 8 deletions
|
|
@ -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
|
||||
|
|
|
|||
46
test/lisp/image/wallpaper-tests.el
Normal file
46
test/lisp/image/wallpaper-tests.el
Normal 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue