From fe54210b8abf0716afb1f09d299bcbd17a5f1c9b Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 1 Jun 2024 15:22:11 +0300 Subject: [PATCH] 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. (cherry picked from commit e42da81f54ec7d3ddcb70b54fa461c7dd6c3b101) --- lisp/image/image-dired-external.el | 205 ++++++++++++++++++++--------- 1 file changed, 145 insertions(+), 60 deletions(-) diff --git a/lisp/image/image-dired-external.el b/lisp/image/image-dired-external.el index cdeeba4c367..178eb539ec4 100644 --- a/lisp/image/image-dired-external.el +++ b/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)) -- 2.39.2