Improve thumbnail generation on MS-Windows

* lisp/image/image-dired-external.el (image-dired-create-thumb-2):
Optimize PNG thumbnails.
(image-dired-pngnq-thumb, image-dired-pngcrush-thumb)
(image-dired-optipng-thumb): On MS-Windows, invoke the PNG
optimization programs synchronously.
(image-dired-cmd-create-thumbnail-program)
(image-dired-cmd-create-thumbnail-options)
(image-dired-cmd-pngcrush-program)
(image-dired-cmd-optipng-program)
(image-dired-cmd-create-standard-thumbnail-options)
(image-dired-cmd-rotate-original-program)
(image-dired-temp-rotate-image-file)
(image-dired-cmd-write-exif-data-program)
(image-dired-cmd-write-exif-data-options): Doc fixes.
(image-dired-thumb-queue-run): Don't allow more than 30 concurrent
thumbnail-creation jobs on MS-Windows.

lisp/image/image-dired-external.el

@@ -50,8 +50,10 @@
 
 (defcustom image-dired-cmd-create-thumbnail-program
   (if (executable-find "gm") "gm" "convert")
-  "Executable used to create thumbnail.
-Used together with `image-dired-cmd-create-thumbnail-options'."
+  "File name of the executable used to create thumbnails.
+Used together with `image-dired-cmd-create-thumbnail-options'.
+On MS-Windows, if such an executable is not available, Emacs
+will use `w32image-create-thumbnail' to create thumbnails."
   :type 'file
   :version "29.1")
 
@@ -61,7 +63,8 @@ Used together with `image-dired-cmd-create-thumbnail-options'."
                 "-strip" "jpeg:%t")))
     (if (executable-find "gm") (cons "convert" opts) opts))
   "Options of command used to create thumbnail image.
-Used with `image-dired-cmd-create-thumbnail-program'.
+Used with `image-dired-cmd-create-thumbnail-program', if that is
+available.
 Available format specifiers are:
     %s, %w and %h, which are replaced by `image-dired-thumb-size'
     %f which is replaced by the file name of the original image and
@@ -77,7 +80,7 @@ Available format specifiers are:
   (or (executable-find "pngquant")
       (executable-find "pngnq-s9")
       (executable-find "pngnq"))
-  "The file name of the `pngquant' or `pngnq' program.
+  "The executable file name of the `pngquant' or `pngnq' program.
 It quantizes colors of PNG images down to 256 colors or fewer
 using the NeuQuant algorithm."
   :version "29.1"
@@ -94,7 +97,7 @@ Value can use the same format specifiers as in
   :version "29.1")
 
 (defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
-  "The file name of the `pngcrush' program.
+  "The executable file name of the `pngcrush' program.
 It optimizes the compression of PNG images.  It also adds PNG textual chunks
 with the information required by the Thumbnail Managing Standard."
   :type '(choice (const :tag "Not Set" nil) file))
@@ -118,13 +121,13 @@ temporary file name (typically generated by pnqnq)."
   :type '(repeat (string :tag "Argument")))
 
 (defcustom image-dired-cmd-optipng-program (executable-find "optipng")
-  "The file name of the `optipng' program."
+  "The executable file name of the `optipng' program."
   :version "26.1"
   :type '(choice (const :tag "Not Set" nil) file))
 
 (defcustom image-dired-cmd-optipng-options '("-o5" "%t")
   "Arguments passed to `image-dired-cmd-optipng-program'.
-The value can use format specifiers described in
+The value can use the same %-format specifiers as in
 `image-dired-cmd-create-thumbnail-options'."
   :version "26.1"
   :type '(repeat (string :tag "Argument"))
@@ -140,14 +143,19 @@ The value can use format specifiers described in
                "-thumbnail" "%wx%h>" "png:%t")))
     (if (executable-find "gm") (cons "convert" opts) opts))
   "Options for creating thumbnails according to the Thumbnail Managing Standard.
+Used with `image-dired-cmd-create-thumbnail-program', if that is available.
 The value can use the same %-format specifiers as in
 `image-dired-cmd-create-thumbnail-options', with \"%m\" for file
-modification time."
+modification time.
+On MS-Windows, if the `convert' command is not available, and
+`w32image-create-thumbnail' is used instead, the textual chunks
+specified by the \"-set\" options will not be injected, and instead
+they are added by `pngcrush' if that is available."
   :type '(repeat (string :tag "Argument"))
   :version "29.1")
 
 (defcustom image-dired-cmd-rotate-original-program "jpegtran"
-  "Executable program used to rotate original image.
+  "Executable file of a program used to rotate original image.
 Used together with `image-dired-cmd-rotate-original-options'."
   :type 'file)
 
@@ -166,16 +174,16 @@ and %t which is replaced by `image-dired-temp-image-file'."
 (defcustom image-dired-temp-rotate-image-file
   (expand-file-name ".image-dired_rotate_temp"
                     (locate-user-emacs-file "image-dired/"))
-  "Temporary file for rotate operations."
+  "Temporary file for image rotation operations."
   :type 'file)
 
 (defcustom image-dired-cmd-write-exif-data-program "exiftool"
-  "Program used to write EXIF data to image.
+  "Executable file of a program used to write EXIF data to images.
 Used together with `image-dired-cmd-write-exif-data-options'."
   :type 'file)
 
 (defcustom image-dired-cmd-write-exif-data-options '("-%t=%v" "%f")
-  "Arguments of command used to write EXIF data.
+  "Arguments of the command used to write EXIF data.
 Used with `image-dired-cmd-write-exif-data-program'.
 The value can use the following format specifiers are:
 %f which is replaced by the image file name,
@@ -250,19 +258,21 @@ Each item has the form (ORIGINAL-FILE TARGET-FILE).")
 Increase at your own risk.  If you want to experiment with this,
 consider setting `image-dired-debug' to a non-nil value to see
 the time spent on generating thumbnails.  Run `clear-image-cache'
-and remove the cached thumbnail files between each trial run.")
+and remove the cached thumbnail files between each trial run.
+This is unused on MS-Windows when `w32image-create-thumbnail' is
+used instead of ImageMagick or GraphicsMagick commands.
+In addition, even if those commands are available, the actual number
+of concurrent jobs will be limited by 30 from above, since Emacs
+on MS-Windows cannot have too many concurrent sub-processes.")
 
 (defun image-dired-pngnq-thumb (spec)
   "Quantize thumbnail described by format SPEC with command `pngnq'."
-  (let ((process
-         (apply #'start-process "image-dired-pngnq" nil
-                image-dired-cmd-pngnq-program
-                (mapcar (lambda (arg) (format-spec arg spec))
-                        image-dired-cmd-pngnq-options))))
-    (setf (process-sentinel process)
+  (let* ((snt
           (lambda (process status)
-            (if (and (eq (process-status process) 'exit)
-                     (zerop (process-exit-status process)))
+            (if (or (and (processp process) ; async case
+                         (eq (process-status process) 'exit)
+                         (zerop (process-exit-status process)))
+                    (zerop status))     ; sync case
                 ;; Pass off to pngcrush, or just rename the
                 ;; THUMB-nq8.png file back to THUMB.png
                 (if (and image-dired-cmd-pngcrush-program
@@ -271,9 +281,28 @@ and remove the cached thumbnail files between each trial run.")
                   (let ((nq8 (cdr (assq ?q spec)))
                         (thumb (cdr (assq ?t spec))))
                     (rename-file nq8 thumb t)))
-              (message "command %S %s" (process-command process)
-                       (string-replace "\n" "" status)))))
-    process))
+              (if (processp process)
+                  (message "command %S %s" (process-command process)
+                           (string-replace "\n" "" status))))))
+         (proc
+          (let ((args (mapcar (lambda (arg) (format-spec arg spec))
+                              image-dired-cmd-pngnq-options)))
+            (if (eq system-type 'windows-nt)
+                ;; Cannot safely use 'start-process' here, since awe
+                ;; could be called to produce thumbnails for many
+                ;; images, and we have a hard limitation of 32
+                ;; simultaneous sub-processes on MS-Windows.
+                (apply #'call-process
+                       image-dired-cmd-pngnq-program nil nil nil args)
+              (apply #'start-process
+                     "image-dired-pngnq" nil
+                     image-dired-cmd-pngnq-program args)))))
+    (if (processp proc)
+        (setf (process-sentinel proc) snt)
+      (unless (zerop proc)
+        (message "command %S failed" image-dired-cmd-pngnq-program))
+      (funcall snt image-dired-cmd-pngnq-program proc))
+    proc))
 
 (defun image-dired-pngcrush-thumb (spec)
   "Optimize thumbnail described by format SPEC with command `pngcrush'."
@@ -284,36 +313,65 @@ and remove the cached thumbnail files between each trial run.")
     (let ((temp (cdr (assq ?q spec)))
           (thumb (cdr (assq ?t spec))))
       (copy-file thumb temp)))
-  (let ((process
-         (apply #'start-process "image-dired-pngcrush" nil
-                image-dired-cmd-pngcrush-program
-                (mapcar (lambda (arg) (format-spec arg spec))
-                        image-dired-cmd-pngcrush-options))))
-    (setf (process-sentinel process)
-          (lambda (process status)
-            (unless (and (eq (process-status process) 'exit)
-                         (zerop (process-exit-status process)))
-              (message "command %S %s" (process-command process)
-                       (string-replace "\n" "" status)))
-            (when (memq (process-status process) '(exit signal))
-              (let ((temp (cdr (assq ?q spec))))
-                (delete-file temp)))))
-    process))
+  (let* ((args (mapcar
+                (lambda (arg)
+                  (format-spec arg spec))
+                image-dired-cmd-pngcrush-options))
+         (snt (lambda (process status)
+                (unless (or (and (processp process)
+                                 (eq (process-status process) 'exit)
+                                 (zerop (process-exit-status process)))
+                            (zerop status))
+                  (if (processp process)
+                      (message "command %S %s" (process-command process)
+                               (string-replace "\n" "" status))
+                    (message "command %S failed with status %s"
+                             process status))
+                (when (or (not (processp process))
+                          (memq (process-status process) '(exit signal)))
+                  (let ((temp (cdr (assq ?q spec))))
+                    (delete-file temp))))))
+         (proc
+          (if (eq system-type 'windows-nt)
+              ;; See above for the reasons we don't use 'start-process'
+              ;; on MS-Windows.
+              (apply #'call-process
+                     image-dired-cmd-pngcrush-program nil nil nil args)
+            (apply #'start-process "image-dired-pngcrush" nil
+                   image-dired-cmd-pngcrush-program args))))
+    (if (processp proc)
+        (setf (process-sentinel proc) snt)
+      (funcall snt image-dired-cmd-pngcrush-program proc))
+    proc))
 
 (defun image-dired-optipng-thumb (spec)
   "Optimize thumbnail described by format SPEC with command `optipng'."
-  (let ((process
-         (apply #'start-process "image-dired-optipng" nil
-                image-dired-cmd-optipng-program
-                (mapcar (lambda (arg) (format-spec arg spec))
-                        image-dired-cmd-optipng-options))))
-    (setf (process-sentinel process)
-          (lambda (process status)
-            (unless (and (eq (process-status process) 'exit)
-                         (zerop (process-exit-status process)))
-              (message "command %S %s" (process-command process)
-                       (string-replace "\n" "" status)))))
-    process))
+  (let* ((args (mapcar
+                (lambda (arg)
+                  (format-spec arg spec))
+                image-dired-cmd-optipng-options))
+         (snt (lambda (process status)
+                (unless (or (and (processp process)
+                                 (eq (process-status process) 'exit)
+                                 (zerop (process-exit-status process)))
+                            (zerop status))
+                  (if (processp process)
+                      (message "command %S %s" (process-command process)
+                               (string-replace "\n" "" status))
+                    (message "command %S failed with status %s"
+                             process status)))))
+         (proc
+          (if (eq system-type 'windows-nt)
+              ;; See above for the reasons we don't use 'start-process'
+              ;; on MS-Windows.
+              (apply #'call-process
+                     image-dired-cmd-optipng-program nil nil nil args)
+            (apply #'start-process "image-dired-optipng" nil
+                   image-dired-cmd-optipng-program args))))
+    (if (processp proc)
+        (setf (process-sentinel proc) snt)
+      (funcall snt image-dired-cmd-optipng-program proc))
+    proc))
 
 (defun image-dired-create-thumb-1 (original-file thumbnail-file)
   "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
@@ -400,8 +458,30 @@ file is created by Emacs itself."
         (message "Failed to create a thumbnail for %s"
                  (abbreviate-file-name original-file))
       (clear-image-cache thumbnail-file)
-      ;; FIXME: Add PNG optimization like image-dired-create-thumb-1 does.
-      )
+      ;; PNG thumbnail has been created since we are following the XDG
+      ;; thumbnail spec, so try to optimize.
+      (when (memq image-dired-thumbnail-storage
+                  image-dired--thumbnail-standard-sizes)
+        (let* ((modif-time (format-time-string
+                            "%s" (file-attribute-modification-time
+                                  (file-attributes original-file))))
+               (thumbnail-nq8-file (replace-regexp-in-string
+                                    ".png\\'" "-nq8.png" thumbnail-file))
+               (spec `((?s . ,size) (?w . ,size) (?h . ,size)
+                       (?m . ,modif-time)
+                       (?f . ,original-file)
+                       (?q . ,thumbnail-nq8-file)
+                       (?t . ,thumbnail-file))))
+          (cond
+           ((and image-dired-cmd-pngnq-program
+                 (executable-find image-dired-cmd-pngnq-program))
+            (image-dired-pngnq-thumb spec))
+           ((and image-dired-cmd-pngcrush-program
+                 (executable-find image-dired-cmd-pngcrush-program))
+            (image-dired-pngcrush-thumb spec))
+           ((and image-dired-cmd-optipng-program
+                 (executable-find image-dired-cmd-optipng-program))
+            (image-dired-optipng-thumb spec))))))
     ;; Trigger next in queue once a thumbnail has been created.
     (image-dired-thumb-queue-run)))
 
@@ -414,13 +494,18 @@ Number of simultaneous jobs is limited by `image-dired-queue-active-limit'."
                 'w32image-create-thumbnail)
                'function))
       ;; We have a usable gm/convert command; queue thethumbnail jobs.
-      (while (and image-dired-queue
-                  (< image-dired-queue-active-jobs
-                     image-dired-queue-active-limit))
-        (cl-incf image-dired-queue-active-jobs)
-        (apply #'image-dired-create-thumb-1 (pop image-dired-queue)))
-    ;; We are on MS-Windows and need to generate thumbnails by our
-    ;; lonesome selves.
+      (let ((max-jobs
+             (if (eq system-type 'windows-nt)
+                 ;; Can't have more than 32 concurrent sub-processes on
+                 ;; MS-Windows.
+                 (min 30 image-dired-queue-active-limit)
+               image-dired-queue-active-limit)))
+        (while (and image-dired-queue
+                    (< image-dired-queue-active-jobs max-jobs))
+          (cl-incf image-dired-queue-active-jobs)
+          (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
+    ;; We are on MS-Windows with ImageMagick/GraphicsMagick, and need to
+    ;; generate thumbnails by our lonesome selves.
     (if image-dired-queue
         (let* ((job (pop image-dired-queue))
                (orig-file (car job))