master e0565e3896: Refactor system specific code in wallpaper.el

[Stefan Kangas]

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

    Refactor system specific code in wallpaper.el
    
    * lisp/image/wallpaper.el (wallpaper-set-function): New defvar
    containing system specific function for setting wallpaper.
    (wallpaper-default-set-function): Factor out function from...
    (wallpaper-set): ...here.  Use above new defvar.
    
    (wallpaper-default-file-name-regexp): Delete defvar.
    (wallpaper-image-file-extensions): New defvar.
    (wallpaper--image-file-regexp): New defun that returns a regexp to
    match for completion purposes.
    
    (wallpaper--use-default-set-function-p): New defun.
    (wallpaper--find-command, wallpaper--find-command-arguments):
    Do nothing on MS-Windows and Haiku.
---
 lisp/image/wallpaper.el | 142 +++++++++++++++++++++++++++---------------------
 1 file changed, 80 insertions(+), 62 deletions(-)

diff --git a/lisp/image/wallpaper.el b/lisp/image/wallpaper.el
index e5f2df73f4..886c7d691b 100644
--- a/lisp/image/wallpaper.el
+++ b/lisp/image/wallpaper.el
@@ -43,12 +43,27 @@
 ;; On macOS, the "osascript" command is used.  You might need to
 ;; disable the option "Change picture" in the "Desktop & Screensaver"
 ;; preferences for this to work (this was seen with macOS 10.13).
+;; You might also have to tweak some permissions.
 
 ;;; Code:
 
 (eval-when-compile (require 'subr-x))
 (require 'xdg)
 
+(defvar wallpaper-set-function
+  (cond ((fboundp 'w32-set-wallpaper)
+         #'w32-set-wallpaper)
+        ((and (fboundp 'haiku-set-wallpaper)
+              (featurep 'haiku))
+         'haiku-set-wallpaper)
+        (#'wallpaper-default-set-function))
+  "Function used by `wallpaper-set' to set the wallpaper.
+The function takes one argument, FILE, which is the file name of
+the image file to set the wallpaper to.")
+
+(defun wallpaper--use-default-set-function-p ()
+  (eq wallpaper-set-function #'wallpaper-default-set-function))
+
 
 ;;; Finding the wallpaper command
 
@@ -157,16 +172,18 @@ will be replaced as described in 
`wallpaper-command-args'.")
 
 (defun wallpaper--find-command ()
   "Return a valid command to set the wallpaper in this environment."
-  (catch 'found
-    (dolist (cmd wallpaper--default-commands)
-      (if (and (wallpaper--check-command (intern (car cmd)))
-               (executable-find (car cmd)))
-          (throw 'found (car cmd))))))
+  (when (wallpaper--use-default-set-function-p)
+    (catch 'found
+      (dolist (cmd wallpaper--default-commands)
+        (if (and (wallpaper--check-command (intern (car cmd)))
+                 (executable-find (car cmd)))
+            (throw 'found (car cmd)))))))
 
 (defvar wallpaper-command) ; silence byte-compiler
 (defun wallpaper--find-command-arguments ()
   "Return command line arguments matching `wallpaper-command'."
-  (cdr (assoc wallpaper-command wallpaper--default-commands)))
+  (when (wallpaper--use-default-set-function-p)
+    (cdr (assoc wallpaper-command wallpaper--default-commands))))
 
 
 ;;; Customizable variables
@@ -259,9 +276,6 @@ systems, where a native API is used instead."
            (concat "wallpaper-debug: " (car args))
            (cdr args))))
 
-
-;;; wallpaper-set
-
 (defvar wallpaper-default-width 1080
   "Default width used by `wallpaper-set'.
 This is only used when it can't be detected automatically.
@@ -279,19 +293,65 @@ See also `wallpaper-default-width'.")
 
 (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))
+(defvar wallpaper-image-file-extensions
+  '("bmp" "gif" "heif" "jpeg" "jpg" "png" "tif" "tiff" "webp")
+  "List of file extensions that `wallpaper-set' will consider for completion.")
+
+(defun wallpaper--image-file-regexp ()
+  (rx-to-string '(: "." (eval `(or ,@wallpaper-image-file-extensions)) eos) t))
 
 (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))
+      (when (and file (string-match (wallpaper--image-file-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")
+
+;;; wallpaper-set
+
+(defun wallpaper-default-set-function (file)
+  "Set the wallpaper to FILE using a command.
+This is the default function for `wallpaper-set-function'."
+  (unless wallpaper-command
+    (error "Couldn't find a command to set the wallpaper with"))
+  (let* ((fmt-spec `((?f . ,(expand-file-name file))
+                     (?F . ,(mapconcat #'url-hexify-string
+                                       (file-name-split file)
+                                       "/"))
+                     (?h . ,(wallpaper--get-height-or-width
+                             "height"
+                             #'display-pixel-height
+                             wallpaper-default-height))
+                     (?w . ,(wallpaper--get-height-or-width
+                             "width"
+                             #'display-pixel-width
+                             wallpaper-default-width))))
+         (bufname (format " *wallpaper-%s*" (random)))
+         (process
+          (and wallpaper-command
+               (apply #'start-process "set-wallpaper" bufname
+                      wallpaper-command
+                      (mapcar (lambda (arg) (format-spec arg fmt-spec))
+                              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)
+    (setf (process-sentinel process)
+          (lambda (process status)
+            (unwind-protect
+                (unless (and (eq (process-status process) 'exit)
+                             (zerop (process-exit-status process)))
+                  (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
 (defun wallpaper-set (file)
@@ -309,10 +369,10 @@ so the value of `wallpaper-commands' is ignored."
      (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)))))))
+                           (let ((re (wallpaper--image-file-regexp)))
+                             (lambda (file-name)
+                               (or (file-directory-p file-name)
+                                   (string-match re file-name))))))))
   (when (file-directory-p file)
     (error "Can't set wallpaper to a directory: %s" file))
   (unless (file-exists-p file)
@@ -320,49 +380,7 @@ so the value of `wallpaper-commands' is ignored."
   (unless (file-readable-p file)
     (error "File is not readable: %s" file))
   (wallpaper-debug "Using image %S:" file)
-  (cond ((eq system-type 'windows-nt)
-         (w32-set-wallpaper file))
-        ((featurep 'haiku)
-         (haiku-set-wallpaper file))
-        (t
-         (unless wallpaper-command
-           (error "Couldn't find a command to set the wallpaper with"))
-         (let* ((fmt-spec `((?f . ,(expand-file-name file))
-                            (?F . ,(mapconcat #'url-hexify-string
-                                              (file-name-split file)
-                                              "/"))
-                            (?h . ,(wallpaper--get-height-or-width
-                                    "height"
-                                    #'display-pixel-height
-                                    wallpaper-default-height))
-                            (?w . ,(wallpaper--get-height-or-width
-                                    "width"
-                                    #'display-pixel-width
-                                    wallpaper-default-width))))
-                (bufname (format " *wallpaper-%s*" (random)))
-                (process
-                 (and wallpaper-command
-                      (apply #'start-process "set-wallpaper" bufname
-                             wallpaper-command
-                             (mapcar (lambda (arg) (format-spec arg fmt-spec))
-                                     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)
-           (setf (process-sentinel process)
-                 (lambda (process status)
-                   (unwind-protect
-                       (unless (and (eq (process-status process) 'exit)
-                                    (zerop (process-exit-status process)))
-                         (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))))
+  (funcall wallpaper-set-function file))
 
 (provide 'wallpaper)