From 0504f39259f0afb0bfeb73b294f523d20b20091c Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Fri, 19 Aug 2022 20:41:11 +0200 Subject: [PATCH] Split image-dired.el into several files (part 1/2) Use a git trick to split a file while preserving line history (for "git blame", "git log --follow", etc.): 1) Make exact copies of the original file, in the same commit as moving it. [this commit] 2) Next, trim down the extra copies to contain only the relevant parts. * lisp/image-dired.el: Move from here... * lisp/image/image-dired-dired.el: * lisp/image/image-dired-external.el: * lisp/image/image-dired-tags.el: * lisp/image/image-dired-util.el: * lisp/image/image-dired.el: ...to here. * test/lisp/image-dired-tests.el: Move from here... * test/lisp/image/image-dired-tests.el: ...to here. --- .../image-dired-dired.el} | 0 lisp/image/image-dired-external.el | 3080 +++++++++++++++++ lisp/image/image-dired-tags.el | 3080 +++++++++++++++++ lisp/image/image-dired-util.el | 3080 +++++++++++++++++ lisp/image/image-dired.el | 3080 +++++++++++++++++ test/lisp/{ => image}/image-dired-tests.el | 0 6 files changed, 12320 insertions(+) rename lisp/{image-dired.el => image/image-dired-dired.el} (100%) create mode 100644 lisp/image/image-dired-external.el create mode 100644 lisp/image/image-dired-tags.el create mode 100644 lisp/image/image-dired-util.el create mode 100644 lisp/image/image-dired.el rename test/lisp/{ => image}/image-dired-tests.el (100%) diff --git a/lisp/image-dired.el b/lisp/image/image-dired-dired.el similarity index 100% rename from lisp/image-dired.el rename to lisp/image/image-dired-dired.el diff --git a/lisp/image/image-dired-external.el b/lisp/image/image-dired-external.el new file mode 100644 index 00000000000..9f12354111c --- /dev/null +++ b/lisp/image/image-dired-external.el @@ -0,0 +1,3080 @@ +;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- + +;; Copyright (C) 2005-2022 Free Software Foundation, Inc. + +;; Version: 0.4.11 +;; Keywords: multimedia +;; Author: Mathias Dahl + +;; 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 . + +;;; Commentary: + +;; BACKGROUND +;; ========== +;; +;; I needed a program to browse, organize and tag my pictures. I got +;; tired of the old gallery program I used as it did not allow +;; multi-file operations easily. Also, it put things out of my +;; control. Image viewing programs I tested did not allow multi-file +;; operations or did not do what I wanted it to. +;; +;; So, I got the idea to use the wonderful functionality of Emacs and +;; `dired' to do it. It would allow me to do almost anything I wanted, +;; which is basically just to browse all my pictures in an easy way, +;; letting me manipulate and tag them in various ways. `dired' already +;; provide all the file handling and navigation facilities; I only +;; needed to add some functions to display the images. +;; +;; I briefly tried out thumbs.el, and although it seemed more +;; powerful than this package, it did not work the way I wanted to. It +;; was too slow to create thumbnails of all files in a directory (I +;; currently keep all my 2000+ images in the same directory) and +;; browsing the thumbnail buffer was slow too. image-dired.el will not +;; create thumbnails until they are needed and the browsing is done +;; quickly and easily in Dired. I copied a great deal of ideas and +;; code from there though... :) +;; +;; `image-dired' stores the thumbnail files in `image-dired-dir' +;; using the file name format ORIGNAME.thumb.ORIGEXT. For example +;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for +;; now just a plain text file with the following format: +;; +;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN +;; +;; +;; PREREQUISITES +;; ============= +;; +;; * The GraphicsMagick or ImageMagick package; Image-Dired uses +;; whichever is available. +;; +;; A) For GraphicsMagick, `gm' is used. +;; Find it here: http://www.graphicsmagick.org/ +;; +;; B) For ImageMagick, `convert' and `mogrify' are used. +;; Find it here: https://www.imagemagick.org. +;; +;; * For non-lossy rotation of JPEG images, the JpegTRAN program is +;; needed. +;; +;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is +;; needed. It can be found here: https://exiftool.org/. This +;; function is, among other things, used for writing comments to +;; image files using `image-dired-thumbnail-set-image-description'. +;; +;; +;; USAGE +;; ===== +;; +;; This information has been moved to the manual. Type `C-h r' to open +;; the Emacs manual and go to the node Thumbnails by typing `g +;; Image-Dired RET'. +;; +;; Quickstart: M-x image-dired RET DIRNAME RET +;; +;; where DIRNAME is a directory containing image files. +;; +;; LIMITATIONS +;; =========== +;; +;; * Supports all image formats that Emacs and convert supports, but +;; the thumbnails are hard-coded to JPEG or PNG format. It uses +;; JPEG by default, but can optionally follow the Thumbnail Managing +;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user +;; option `image-dired-thumbnail-storage'. +;; +;; * WARNING: The "database" format used might be changed so keep a +;; backup of `image-dired-db-file' when testing new versions. +;; +;; TODO +;; ==== +;; +;; * Investigate if it is possible to also write the tags to the image +;; files. +;; +;; * From thumbs.el: Add an option for clean-up/max-size functionality +;; for thumbnail directory. +;; +;; * From thumbs.el: Add setroot function. +;; +;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out +;; which is best, saving old batch just before inserting new, or +;; saving the current batch in the ring when inserting it. Adding +;; it probably needs rewriting `image-dired-display-thumbs' to be more general. +;; +;; * Find some way of toggling on and off really nice keybindings in +;; Dired (for example, using C-n or instead of C-S-n). +;; Richard suggested that we could keep C-t as prefix for +;; image-dired commands as it is currently not used in Dired. He +;; also suggested that `dired-next-line' and `dired-previous-line' +;; figure out if image-dired is enabled in the current buffer and, +;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line', +;; respectively. Update: This is partly done; some bindings have +;; now been added to Dired. +;; +;; * In some way keep track of buffers and windows and stuff so that +;; it works as the user expects. +;; +;; * More/better documentation. + +;;; Code: + +(require 'dired) +(require 'exif) +(require 'image-mode) +(require 'widget) +(require 'xdg) + +(eval-when-compile + (require 'cl-lib) + (require 'wid-edit)) + + +;;; Customizable variables + +(defgroup image-dired nil + "Use Dired to browse your images as thumbnails, and more." + :prefix "image-dired-" + :link '(info-link "(emacs) Image-Dired") + :group 'multimedia) + +(defcustom image-dired-dir (locate-user-emacs-file "image-dired/") + "Directory where thumbnail images are stored. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; they will be +saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See +`image-dired-thumbnail-storage'." + :type 'directory) + +(defcustom image-dired-thumbnail-storage 'use-image-dired-dir + "How `image-dired' stores thumbnail files. +There are two ways that Image-Dired can store and generate +thumbnails. If you set this variable to one of the two following +values, they will be stored in the JPEG format: + +- `use-image-dired-dir' means that the thumbnails are stored in a + central directory. + +- `per-directory' means that each thumbnail is stored in a + subdirectory called \".image-dired\" in the same directory + where the image file is. + +It can also use the \"Thumbnail Managing Standard\", which allows +sharing of thumbnails across different programs. Thumbnails will +be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in +`image-dired-dir'. Thumbnails are saved in the PNG format, and +can be one of the following sizes: + +- `standard' means use thumbnails sized 128x128. +- `standard-large' means use thumbnails sized 256x256. +- `standard-x-large' means use thumbnails sized 512x512. +- `standard-xx-large' means use thumbnails sized 1024x1024. + +For more information on the Thumbnail Managing Standard, see: +https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html" + :type '(choice :tag "How to store thumbnail files" + (const :tag "Use image-dired-dir" use-image-dired-dir) + (const :tag "Thumbnail Managing Standard (normal 128x128)" + standard) + (const :tag "Thumbnail Managing Standard (large 256x256)" + standard-large) + (const :tag "Thumbnail Managing Standard (larger 512x512)" + standard-x-large) + (const :tag "Thumbnail Managing Standard (extra large 1024x1024)" + standard-xx-large) + (const :tag "Per-directory" per-directory)) + :version "29.1") + +(defconst image-dired--thumbnail-standard-sizes + '( standard standard-large + standard-x-large standard-xx-large) + "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.") + +(defcustom image-dired-db-file + (expand-file-name ".image-dired_db" image-dired-dir) + "Database file where file names and their associated tags are stored." + :type 'file) + +(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'." + :type 'file + :version "29.1") + +(defcustom image-dired-cmd-create-thumbnail-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-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'. +Available format specifiers are: %w which is replaced by +`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height', +%f which is replaced by the file name of the original image and %t +which is replaced by the file name of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-pngnq-program + ;; Prefer pngquant to pngnq-s9 as it is faster on my machine. + ;; The project also seems more active than the alternatives. + ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq. + ;; The pngnq project seems dead (?) since 2011 or so. + (or (executable-find "pngquant") + (executable-find "pngnq-s9") + (executable-find "pngnq")) + "The 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" + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngnq-options + (if (executable-find "pngquant") + '("--ext" "-nq8.png" "%t") ; same extension as "pngnq" + '("-f" "%t")) + "Arguments to pass `image-dired-cmd-pngnq-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options'." + :type '(repeat (string :tag "Argument")) + :version "29.1") + +(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush") + "The file name of the `pngcrush' program. +It optimizes the compression of PNG images. Also it adds PNG textual chunks +with the information required by the Thumbnail Managing Standard." + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngcrush-options + `("-q" + "-text" "b" "Description" "Thumbnail of file://%f" + "-text" "b" "Software" ,(emacs-version) + ;; "-text b \"Thumb::Image::Height\" \"%oh\" " + ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" " + ;; "-text b \"Thumb::Image::Width\" \"%ow\" " + "-text" "b" "Thumb::MTime" "%m" + ;; "-text b \"Thumb::Size\" \"%b\" " + "-text" "b" "Thumb::URI" "file://%f" + "%q" "%t") + "Arguments for `image-dired-cmd-pngcrush-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %q for a +temporary file name (typically generated by pnqnq)." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-optipng-program (executable-find "optipng") + "The 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'. +Available format specifiers are described in +`image-dired-cmd-create-thumbnail-options'." + :version "26.1" + :type '(repeat (string :tag "Argument")) + :link '(url-link "man:optipng(1)")) + +(defcustom image-dired-cmd-create-standard-thumbnail-options + (append '("-size" "%wx%h" "%f[0]") + (unless (or image-dired-cmd-pngcrush-program + image-dired-cmd-pngnq-program) + (list + "-set" "Thumb::MTime" "%m" + "-set" "Thumb::URI" "file://%f" + "-set" "Description" "Thumbnail of file://%f" + "-set" "Software" (emacs-version))) + '("-thumbnail" "%wx%h>" "png:%t")) + "Options for creating thumbnails according to the Thumbnail Managing Standard. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %m for file modification time." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-rotate-original-program + "jpegtran" + "Executable used to rotate original image. +Used together with `image-dired-cmd-rotate-original-options'." + :type 'file) + +(defcustom image-dired-cmd-rotate-original-options + '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o") + "Arguments of command used to rotate original image. +Used with `image-dired-cmd-rotate-original-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or +270 \(for 90 degrees right and left), %o which is replaced by the +original image file name and %t which is replaced by +`image-dired-temp-image-file'." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-temp-rotate-image-file + (expand-file-name ".image-dired_rotate_temp" image-dired-dir) + "Temporary file for rotate operations." + :type 'file) + +(defcustom image-dired-rotate-original-ask-before-overwrite t + "Confirm overwrite of original file after rotate operation. +If non-nil, ask user for confirmation before overwriting the +original file with `image-dired-temp-rotate-image-file'." + :type 'boolean) + +(defcustom image-dired-cmd-write-exif-data-program + "exiftool" + "Program used to write EXIF data to image. +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. +Used with `image-dired-cmd-write-exif-data-program'. +Available format specifiers are: %f which is replaced by +the image file name, %t which is replaced by the tag name and %v +which is replaced by the tag value." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-thumb-size + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t 100)) + "Size of thumbnails, in pixels. +This is the default size for both `image-dired-thumb-width' +and `image-dired-thumb-height'. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; the standard +sizes will be used instead. See `image-dired-thumbnail-storage'." + :type 'integer) + +(defcustom image-dired-thumb-width image-dired-thumb-size + "Width of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-height image-dired-thumb-size + "Height of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-relief 2 + "Size of button-like border around thumbnails." + :type 'integer) + +(defcustom image-dired-thumb-margin 2 + "Size of the margin around thumbnails. +This is where you see the cursor." + :type 'integer) + +(defcustom image-dired-thumb-visible-marks t + "Make marks and flags visible in thumbnail buffer. +If non-nil, apply the `image-dired-thumb-mark' face to marked +images and `image-dired-thumb-flagged' to images flagged for +deletion." + :type 'boolean + :version "28.1") + +(defface image-dired-thumb-mark + '((((class color) (min-colors 16)) :background "DarkOrange") + (((class color)) :foreground "yellow")) + "Face for marked images in thumbnail buffer." + :version "29.1") + +(defface image-dired-thumb-flagged + '((((class color) (min-colors 88) (background light)) :background "Red3") + (((class color) (min-colors 88) (background dark)) :background "Pink") + (((class color) (min-colors 16) (background light)) :background "Red3") + (((class color) (min-colors 16) (background dark)) :background "Pink") + (((class color) (min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for images flagged for deletion in thumbnail buffer." + :version "29.1") + +(defcustom image-dired-line-up-method 'dynamic + "Default method for line-up of thumbnails in thumbnail buffer. +Used by `image-dired-display-thumbs' and other functions that needs +to line-up thumbnails. Dynamic means to use the available width of +the window containing the thumbnail buffer, Fixed means to use +`image-dired-thumbs-per-row', Interactive is for asking the user, +and No line-up means that no automatic line-up will be done." + :type '(choice :tag "Default line-up method" + (const :tag "Dynamic" dynamic) + (const :tag "Fixed" fixed) + (const :tag "Interactive" interactive) + (const :tag "No line-up" none))) + +(defcustom image-dired-thumbs-per-row 3 + "Number of thumbnails to display per row in thumb buffer." + :type 'integer) + +(defcustom image-dired-track-movement t + "The current state of the tracking and mirroring. +For more information, see the documentation for +`image-dired-toggle-movement-tracking'." + :type 'boolean) + +(defcustom image-dired-append-when-browsing nil + "Append thumbnails in thumbnail buffer when browsing. +If non-nil, using `image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' will leave a trail of thumbnail +images in the thumbnail buffer. If you enable this and want to clean +the thumbnail buffer because it is filled with too many thumbnails, +just call `image-dired-display-thumb' to display only the image at point. +This value can be toggled using `image-dired-toggle-append-browsing'." + :type 'boolean) + +(defcustom image-dired-dired-disp-props t + "If non-nil, display properties for Dired file when browsing. +Used by `image-dired-next-line-and-display', +`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'. +If the database file is large, this can slow down image browsing in +Dired and you might want to turn it off." + :type 'boolean) + +(defcustom image-dired-display-properties-format "%b: %f (%t): %c" + "Display format for thumbnail properties. +%b is replaced with associated Dired buffer name, %f with file +name (without path) of original image file, %t with the list of +tags and %c with the comment." + :type 'string) + +(defcustom image-dired-external-viewer + ;; TODO: Use mailcap, dired-guess-shell-alist-default, + ;; dired-view-command-alist. + (cond ((executable-find "display")) + ((executable-find "xli")) + ((executable-find "qiv") "qiv -t") + ((executable-find "feh") "feh")) + "Name of external viewer. +Including parameters. Used when displaying original image from +`image-dired-thumbnail-mode'." + :version "28.1" + :type '(choice string + (const :tag "Not Set" nil))) + +(defcustom image-dired-main-image-directory + (or (xdg-user-dir "PICTURES") "~/pics/") + "Name of main image directory, if any. +Used by `image-dired-copy-with-exif-file-name'." + :type 'string + :version "29.1") + +(defcustom image-dired-show-all-from-dir-max-files 500 + "Maximum number of files in directory before prompting. + +If there are more image files than this in a selected directory, +the `image-dired-show-all-from-dir' command will ask for +confirmation before creating the thumbnail buffer. If this +variable is nil, it will never ask." + :type '(choice integer + (const :tag "Disable warning" nil)) + :version "29.1") + +(defcustom image-dired-marking-shows-next t + "If non-nil, marking, unmarking or flagging an image shows the next image. + +This affects the following commands: +\\ + `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file]) + `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file]) + `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])" + :type 'boolean + :version "29.1") + + +;;; Util functions + +(defvar image-dired-debug nil + "Non-nil means enable debug messages.") + +(defun image-dired-debug-message (&rest args) + "Display debug message ARGS when `image-dired-debug' is non-nil." + (when image-dired-debug + (apply #'message args))) + +(defmacro image-dired--with-db-file (&rest body) + "Run BODY in a temp buffer containing `image-dired-db-file'. +Return the last form in BODY." + (declare (indent 0) (debug t)) + `(with-temp-buffer + (if (file-exists-p image-dired-db-file) + (insert-file-contents image-dired-db-file)) + ,@body)) + +(defun image-dired-dir () + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." + (let ((image-dired-dir (file-name-as-directory + (expand-file-name image-dired-dir)))) + (unless (file-directory-p image-dired-dir) + (with-file-modes #o700 + (make-directory image-dired-dir t)) + (message "Thumbnail directory created: %s" image-dired-dir)) + image-dired-dir)) + +(defun image-dired-insert-image (file type relief margin) + "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point." + (let ((i `(image :type ,type + :file ,file + :relief ,relief + :margin ,margin))) + (insert-image i))) + +(defun image-dired-get-thumbnail-image (file) + "Return the image descriptor for a thumbnail of image file FILE." + (unless (string-match-p (image-file-name-regexp) file) + (error "%s is not a valid image file" file)) + (let* ((thumb-file (image-dired-thumb-name file)) + (thumb-attr (file-attributes thumb-file))) + (when (or (not thumb-attr) + (time-less-p (file-attribute-modification-time thumb-attr) + (file-attribute-modification-time + (file-attributes file)))) + (image-dired-create-thumb file thumb-file)) + (create-image thumb-file))) + +(defun image-dired-insert-thumbnail (file original-file-name + associated-dired-buffer) + "Insert thumbnail image FILE. +Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." + (let (beg end) + (setq beg (point)) + (image-dired-insert-image + file + ;; Thumbnails are created asynchronously, so we might not yet + ;; have a file. But if it exists, it might have been cached from + ;; before and we should use it instead of our current settings. + (or (and (file-exists-p file) + (image-type-from-file-header file)) + (and (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + 'png) + 'jpeg) + image-dired-thumb-relief + image-dired-thumb-margin) + (setq end (point)) + (add-text-properties + beg end + (list 'image-dired-thumbnail t + 'original-file-name original-file-name + 'associated-dired-buffer associated-dired-buffer + 'tags (image-dired-list-tags original-file-name) + 'mouse-face 'highlight + 'comment (image-dired-get-comment original-file-name))))) + +(defun image-dired-thumb-name (file) + "Return absolute file name for thumbnail FILE. +Depending on the value of `image-dired-thumbnail-storage', the +file name of the thumbnail will vary: +- For `use-image-dired-dir', make a SHA1-hash of the image file's + directory name and add that to make the thumbnail file name + unique. +- For `per-directory' storage, just add a subdirectory. +- For `standard' storage, produce the file name according to the + Thumbnail Managing Standard. Among other things, an MD5-hash + of the image file's directory name will be added to the + filename. +See also `image-dired-thumbnail-storage'." + (cond ((memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + (let ((thumbdir (cl-case image-dired-thumbnail-storage + (standard "thumbnails/normal") + (standard-large "thumbnails/large") + (standard-x-large "thumbnails/x-large") + (standard-xx-large "thumbnails/xx-large")))) + (expand-file-name + ;; MD5 is mandated by the Thumbnail Managing Standard. + (concat (md5 (concat "file://" (expand-file-name file))) ".png") + (expand-file-name thumbdir (xdg-cache-home))))) + ((eq 'use-image-dired-dir image-dired-thumbnail-storage) + (let* ((f (expand-file-name file)) + (hash + (md5 (file-name-as-directory (file-name-directory f))))) + (format "%s%s%s.thumb.%s" + (file-name-as-directory (expand-file-name (image-dired-dir))) + (file-name-base f) + (if hash (concat "_" hash) "") + (file-name-extension f)))) + ((eq 'per-directory image-dired-thumbnail-storage) + (let ((f (expand-file-name file))) + (format "%s.image-dired/%s.thumb.%s" + (file-name-directory f) + (file-name-base f) + (file-name-extension f)))))) + +(defun image-dired--check-executable-exists (executable) + (unless (executable-find (symbol-value executable)) + (error "Executable %S not found" executable))) + + +;;; Creating thumbnails + +(defun image-dired-thumb-size (dimension) + "Return thumb size depending on `image-dired-thumbnail-storage'. +DIMENSION should be either the symbol `width' or `height'." + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t (cl-ecase dimension + (width image-dired-thumb-width) + (height image-dired-thumb-height))))) + +(defvar image-dired--generate-thumbs-start nil + "Time when `display-thumbs' was called.") + +(defvar image-dired-queue nil + "List of items in the queue. +Each item has the form (ORIGINAL-FILE TARGET-FILE).") + +(defvar image-dired-queue-active-jobs 0 + "Number of active jobs in `image-dired-queue'.") + +(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2))) + "Maximum number of concurrent jobs permitted for generating images. +Increase at 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 `image-clear-cache' +and remove the cached thumbnail files between each trial run.") + +(defun image-dired-pngnq-thumb (spec) + "Quantize thumbnail described by format SPEC with pngnq(1)." + (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) + (lambda (process status) + (if (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + ;; Pass off to pngcrush, or just rename the + ;; THUMB-nq8.png file back to THUMB.png + (if (and image-dired-cmd-pngcrush-program + (executable-find image-dired-cmd-pngcrush-program)) + (image-dired-pngcrush-thumb spec) + (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)) + +(defun image-dired-pngcrush-thumb (spec) + "Optimize thumbnail described by format SPEC with pngcrush(1)." + ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist. + ;; pngcrush needs an infile and outfile, so we just copy THUMB to + ;; THUMB-nq8.png and use the latter as a temp file. + (when (not image-dired-cmd-pngnq-program) + (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)) + +(defun image-dired-optipng-thumb (spec) + "Optimize thumbnail described by format SPEC with optipng(1)." + (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)) + +(defun image-dired-create-thumb-1 (original-file thumbnail-file) + "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE." + (image-dired--check-executable-exists + 'image-dired-cmd-create-thumbnail-program) + (let* ((width (int-to-string (image-dired-thumb-size 'width))) + (height (int-to-string (image-dired-thumb-size 'height))) + (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 + (list + (cons ?w width) + (cons ?h height) + (cons ?m modif-time) + (cons ?f original-file) + (cons ?q thumbnail-nq8-file) + (cons ?t thumbnail-file))) + (thumbnail-dir (file-name-directory thumbnail-file)) + process) + (when (not (file-exists-p thumbnail-dir)) + (with-file-modes #o700 + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) + + ;; Thumbnail file creation processes begin here and are marshaled + ;; in a queue by `image-dired-create-thumb'. + (setq process + (apply #'start-process "image-dired-create-thumbnail" nil + image-dired-cmd-create-thumbnail-program + (mapcar + (lambda (arg) (format-spec arg spec)) + (if (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + image-dired-cmd-create-standard-thumbnail-options + image-dired-cmd-create-thumbnail-options)))) + + (setf (process-sentinel process) + (lambda (process status) + ;; Trigger next in queue once a thumbnail has been created + (cl-decf image-dired-queue-active-jobs) + (image-dired-thumb-queue-run) + (when (= image-dired-queue-active-jobs 0) + (image-dired-debug-message + (format-time-string + "Generated thumbnails in %s.%3N seconds" + (time-subtract nil + image-dired--generate-thumbs-start)))) + (if (not (and (eq (process-status process) 'exit) + (zerop (process-exit-status process)))) + (message "Thumb could not be created for %s: %s" + (abbreviate-file-name original-file) + (string-replace "\n" "" status)) + (set-file-modes thumbnail-file #o600) + (clear-image-cache thumbnail-file) + ;; 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) + (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))))))) + process)) + +(defun image-dired-thumb-queue-run () + "Run a queued job if one exists and not too many jobs are running. +Queued items live in `image-dired-queue'." + (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)))) + +(defun image-dired-create-thumb (original-file thumbnail-file) + "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'. +The new file will be named THUMBNAIL-FILE." + (setq image-dired-queue + (nconc image-dired-queue + (list (list original-file thumbnail-file)))) + (run-at-time 0 nil #'image-dired-thumb-queue-run)) + +(defmacro image-dired--with-marked (&rest body) + "Eval BODY with point on each marked thumbnail. +If no marked file could be found, execute BODY on the current +thumbnail." + `(with-current-buffer image-dired-thumbnail-buffer + (let (found) + (save-mark-and-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (image-dired-thumb-file-marked-p) + (setq found t) + ,@body) + (forward-char))) + (unless found + ,@body)))) + +;;;###autoload +(defun image-dired-dired-toggle-marked-thumbs (&optional arg) + "Toggle thumbnails in front of file names in the Dired buffer. +If no marked file could be found, insert or hide thumbnails on the +current line. ARG, if non-nil, specifies the files to use instead +of the marked files. If ARG is an integer, use the next ARG (or +previous -ARG, if ARG<0) files." + (interactive "P") + (dired-map-over-marks + (let ((image-pos (dired-move-to-filename)) + (image-file (dired-get-filename nil t)) + thumb-file + overlay) + (when (and image-file + (string-match-p (image-file-name-regexp) image-file)) + (setq thumb-file (image-dired-get-thumbnail-image image-file)) + ;; If image is not already added, then add it. + (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'thumb-file) return ov))) + (if thumb-ov + (delete-overlay thumb-ov) + (put-image thumb-file image-pos) + (setq overlay + (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'put-image) return ov)) + (overlay-put overlay 'image-file image-file) + (overlay-put overlay 'thumb-file thumb-file))))) + arg ; Show or hide image on ARG next files. + 'show-progress) ; Update dired display after each image is updated. + (add-hook 'dired-after-readin-hook + 'image-dired-dired-after-readin-hook nil t)) + +(defun image-dired-dired-after-readin-hook () + "Relocate existing thumbnail overlays in Dired buffer after reverting. +Move them to their corresponding files if they still exist. +Otherwise, delete overlays." + (mapc (lambda (overlay) + (when (overlay-get overlay 'put-image) + (let* ((image-file (overlay-get overlay 'image-file)) + (image-pos (dired-goto-file image-file))) + (if image-pos + (move-overlay overlay image-pos image-pos) + (delete-overlay overlay))))) + (overlays-in (point-min) (point-max)))) + +(defun image-dired-next-line-and-display () + "Move to next Dired line and display thumbnail image." + (interactive) + (dired-next-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-previous-line-and-display () + "Move to previous Dired line and display thumbnail image." + (interactive) + (dired-previous-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-append-browsing () + "Toggle `image-dired-append-when-browsing'." + (interactive) + (setq image-dired-append-when-browsing + (not image-dired-append-when-browsing)) + (message "Append browsing %s" + (if image-dired-append-when-browsing + "on" + "off"))) + +(defun image-dired-mark-and-display-next () + "Mark current file in Dired and display next thumbnail image." + (interactive) + (dired-mark 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-dired-display-properties () + "Toggle `image-dired-dired-disp-props'." + (interactive) + (setq image-dired-dired-disp-props + (not image-dired-dired-disp-props)) + (message "Dired display properties %s" + (if image-dired-dired-disp-props + "on" + "off"))) + +(defvar image-dired-thumbnail-buffer "*image-dired*" + "Image-Dired's thumbnail buffer.") + +(defun image-dired-create-thumbnail-buffer () + "Create thumb buffer and set `image-dired-thumbnail-mode'." + (let ((buf (get-buffer-create image-dired-thumbnail-buffer))) + (with-current-buffer buf + (setq buffer-read-only t) + (if (not (eq major-mode 'image-dired-thumbnail-mode)) + (image-dired-thumbnail-mode))) + buf)) + +(defvar image-dired-display-image-buffer "*image-dired-display-image*" + "Where larger versions of the images are display.") + +(defvar image-dired-saved-window-configuration nil + "Saved window configuration.") + +;;;###autoload +(defun image-dired-dired-with-window-configuration (dir &optional arg) + "Open directory DIR and create a default window configuration. + +Convenience command that: + + - Opens Dired in folder DIR + - Splits windows in most useful (?) way + - Sets `truncate-lines' to t + +After the command has finished, you would typically mark some +image files in Dired and type +\\[image-dired-display-thumbs] (`image-dired-display-thumbs'). + +If called with prefix argument ARG, skip splitting of windows. + +The current window configuration is saved and can be restored by +calling `image-dired-restore-window-configuration'." + (interactive "DDirectory: \nP") + (let ((buf (image-dired-create-thumbnail-buffer)) + (buf2 (get-buffer-create image-dired-display-image-buffer))) + (setq image-dired-saved-window-configuration + (current-window-configuration)) + (dired dir) + (delete-other-windows) + (when (not arg) + (split-window-right) + (setq truncate-lines t) + (save-excursion + (other-window 1) + (pop-to-buffer-same-window buf) + (select-window (split-window-below)) + (pop-to-buffer-same-window buf2) + (other-window -2))))) + +(defun image-dired-restore-window-configuration () + "Restore window configuration. +Restore any changes to the window configuration made by calling +`image-dired-dired-with-window-configuration'." + (interactive nil image-dired-thumbnail-mode) + (if image-dired-saved-window-configuration + (set-window-configuration image-dired-saved-window-configuration) + (message "No saved window configuration"))) + +(defun image-dired--line-up-with-method () + "Line up thumbnails according to `image-dired-line-up-method'." + (cond ((eq 'dynamic image-dired-line-up-method) + (image-dired-line-up-dynamic)) + ((eq 'fixed image-dired-line-up-method) + (image-dired-line-up)) + ((eq 'interactive image-dired-line-up-method) + (image-dired-line-up-interactive)) + ((eq 'none image-dired-line-up-method) + nil) + (t + (image-dired-line-up-dynamic)))) + +;;;###autoload +(defun image-dired-display-thumbs (&optional arg append do-not-pop) + "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'. +If a thumbnail image does not exist for a file, it is created on the +fly. With prefix argument ARG, display only thumbnail for file at +point (this is useful if you have marked some files but want to show +another one). + +Recommended usage is to split the current frame horizontally so that +you have the Dired buffer in the left window and the +`image-dired-thumbnail-buffer' buffer in the right window. + +With optional argument APPEND, append thumbnail to thumbnail buffer +instead of erasing it first. + +Optional argument DO-NOT-POP controls if `pop-to-buffer' should be +used or not. If non-nil, use `display-buffer' instead of +`pop-to-buffer'. This is used from functions like +`image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' where we do not want the +thumbnail buffer to be selected." + (interactive "P") + (setq image-dired--generate-thumbs-start (current-time)) + (let ((buf (image-dired-create-thumbnail-buffer)) + thumb-name files dired-buf) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (setq dired-buf (current-buffer)) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (if (not append) + (erase-buffer) + (goto-char (point-max))) + (dolist (curr-file files) + (setq thumb-name (image-dired-thumb-name curr-file)) + (when (not (file-exists-p thumb-name)) + (image-dired-create-thumb curr-file thumb-name)) + (image-dired-insert-thumbnail thumb-name curr-file dired-buf))) + (if do-not-pop + (display-buffer buf) + (pop-to-buffer buf)) + (image-dired--line-up-with-method)))) + +;;;###autoload +(defun image-dired-show-all-from-dir (dir) + "Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation." + (interactive "DImage-Dired: ") + (dired dir) + (dired-mark-files-regexp (image-file-name-regexp)) + (let ((files (dired-get-marked-files nil nil nil t))) + (cond ((and (null (cdr files))) + (message "No image files in directory")) + ((or (not image-dired-show-all-from-dir-max-files) + (<= (length (cdr files)) image-dired-show-all-from-dir-max-files) + (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files) + (y-or-n-p + (format + "Directory contains more than %d image files. Proceed?" + image-dired-show-all-from-dir-max-files)))) + (image-dired-display-thumbs) + (pop-to-buffer image-dired-thumbnail-buffer) + (setq default-directory dir) + (image-dired-unmark-all-marks)) + (t (message "Image-Dired canceled"))))) + +;;;###autoload +(defalias 'image-dired 'image-dired-show-all-from-dir) + + +;;; Tags + +(defun image-dired-sane-db-file () + "Check if `image-dired-db-file' exists. +If not, try to create it (including any parent directories). +Signal error if there are problems creating it." + (or (file-exists-p image-dired-db-file) + (let (dir buf) + (unless (file-directory-p (setq dir (file-name-directory + image-dired-db-file))) + (with-file-modes #o700 + (make-directory dir t))) + (with-current-buffer (setq buf (create-file-buffer + image-dired-db-file)) + (with-file-modes #o600 + (write-file image-dired-db-file))) + (kill-buffer buf) + (file-exists-p image-dired-db-file)) + (error "Could not create %s" image-dired-db-file))) + +(defvar image-dired-tag-history nil "Variable holding the tag history.") + +(defun image-dired-write-tags (file-tags) + "Write file tags to database. +Write each file and tag in FILE-TAGS to the database. +FILE-TAGS is an alist in the following form: + ((FILE . TAG) ... )" + (image-dired-sane-db-file) + (let (end file tag) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-tags) + (setq file (car elt) + tag (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + (when (not (search-forward (format ";%s" tag) end t)) + (end-of-line) + (insert (format ";%s" tag)))) + (goto-char (point-max)) + (insert (format "%s;%s\n" file tag)))) + (save-buffer)))) + +(defun image-dired-remove-tag (files tag) + "For all FILES, remove TAG from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (let (end) + (unless (listp files) + (if (stringp files) + (setq files (list files)) + (error "Files must be a string or a list of strings!"))) + (dolist (file files) + (goto-char (point-min)) + (when (search-forward-regexp (format "^%s;" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward-regexp + (format "\\(;%s\\)\\($\\|;\\)" tag) end t) + (delete-region (match-beginning 1) (match-end 1)) + ;; Check if file should still be in the database. If + ;; it has no tags or comments, it will be removed. + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (not (search-forward ";" end t)) + (kill-line 1)))))) + (save-buffer))) + +(defun image-dired-list-tags (file) + "Read all tags for image FILE from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end (tags "")) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (if (search-forward ";" end t) + (if (search-forward "comment:" end t) + (if (search-forward ";" end t) + (setq tags (buffer-substring (point) end))) + (setq tags (buffer-substring (point) end))))) + (split-string tags ";")))) + +;;;###autoload +(defun image-dired-tag-files (arg) + "Tag marked file(s) in Dired. With prefix ARG, tag file at point." + (interactive "P") + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-write-tags + (mapcar + (lambda (x) + (cons x tag)) + files)))) + +(defun image-dired-tag-thumbnail () + "Tag current or marked thumbnails." + (interactive) + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-write-tags + (list (cons (image-dired-original-file-name) tag))) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + +;;;###autoload +(defun image-dired-delete-tag (arg) + "Remove tag for selected file(s). +With prefix argument ARG, remove tag from file at point." + (interactive "P") + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-remove-tag files tag))) + +(defun image-dired-tag-thumbnail-remove () + "Remove tag from current or marked thumbnails." + (interactive) + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-remove-tag (image-dired-original-file-name) tag) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + + +;;; Thumbnail mode (cont.) + +(defun image-dired-original-file-name () + "Get original file name for thumbnail or display image at point." + (get-text-property (point) 'original-file-name)) + +(defun image-dired-file-name-at-point () + "Get abbreviated file name for thumbnail or display image at point." + (let ((f (image-dired-original-file-name))) + (when f + (abbreviate-file-name f)))) + +(defun image-dired-associated-dired-buffer () + "Get associated Dired buffer at point." + (get-text-property (point) 'associated-dired-buffer)) + +(defun image-dired-get-buffer-window (buf) + "Return window where buffer BUF is." + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)) + nil t)) + +(defun image-dired-track-original-file () + "Track the original file in the associated Dired buffer. +See documentation for `image-dired-toggle-movement-tracking'. +Interactive use only useful if `image-dired-track-movement' is nil." + (interactive) + (let* ((dired-buf (image-dired-associated-dired-buffer)) + (file-name (image-dired-original-file-name)) + (window (image-dired-get-buffer-window dired-buf))) + (and (buffer-live-p dired-buf) file-name + (with-current-buffer dired-buf + (if (not (dired-goto-file file-name)) + (message "Could not track file") + (if window (set-window-point window (point)))))))) + +(defun image-dired-toggle-movement-tracking () + "Turn on and off `image-dired-track-movement'. +Tracking of the movements between thumbnail and Dired buffer so that +they are \"mirrored\" in the dired buffer. When this is on, moving +around in the thumbnail or dired buffer will find the matching +position in the other buffer." + (interactive) + (setq image-dired-track-movement (not image-dired-track-movement)) + (message "Movement tracking %s" (if image-dired-track-movement "on" "off"))) + +(defun image-dired-track-thumbnail () + "Track current Dired file's thumb in `image-dired-thumbnail-buffer'. +This is almost the same as what `image-dired-track-original-file' does, +but the other way around." + (let ((file (dired-get-filename)) + prop-val found window) + (when (get-buffer image-dired-thumbnail-buffer) + (with-current-buffer image-dired-thumbnail-buffer + (goto-char (point-min)) + (while (and (not (eobp)) + (not found)) + (if (and (setq prop-val + (get-text-property (point) 'original-file-name)) + (string= prop-val file)) + (setq found t)) + (if (not found) + (forward-char 1))) + (when found + (if (setq window (image-dired-thumbnail-window)) + (set-window-point window (point))) + (image-dired-update-header-line)))))) + +(defun image-dired-dired-next-line (&optional arg) + "Call `dired-next-line', then track thumbnail. +This can safely replace `dired-next-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-next-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired-dired-previous-line (&optional arg) + "Call `dired-previous-line', then track thumbnail. +This can safely replace `dired-previous-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-previous-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired--display-thumb-properties-fun () + (let ((old-buf (current-buffer)) + (old-point (point))) + (lambda () + (when (and (equal (current-buffer) old-buf) + (= (point) old-point)) + (ignore-errors + (image-dired-update-header-line)))))) + +(defun image-dired-forward-image (&optional arg wrap-around) + "Move to next image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move backwards. +On reaching end or beginning of buffer, stop and show a message. + +If optional argument WRAP-AROUND is non-nil, wrap around: if +point is on the last image, move to the last one and vice versa." + (interactive "p") + (setq arg (or arg 1)) + (let (pos) + (dotimes (_ (abs arg)) + (if (and (not (if (> arg 0) (eobp) (bobp))) + (save-excursion + (forward-char (if (> arg 0) 1 -1)) + (while (and (not (if (> arg 0) (eobp) (bobp))) + (not (image-dired-image-at-point-p))) + (forward-char (if (> arg 0) 1 -1))) + (setq pos (point)) + (image-dired-image-at-point-p))) + (progn (goto-char pos) + (image-dired-update-header-line)) + (if wrap-around + (progn (goto-char (if (> arg 0) + (point-min) + ;; There are two spaces after the last image. + (- (point-max) 2))) + (image-dired-update-header-line)) + (message "At %s image" (if (> arg 0) "last" "first")) + (run-at-time 1 nil (image-dired--display-thumb-properties-fun)))))) + (when image-dired-track-movement + (image-dired-track-original-file))) + +(defun image-dired-backward-image (&optional arg) + "Move to previous image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move forward. +On reaching end or beginning of buffer, stop and show a message." + (interactive "p") + (image-dired-forward-image (- (or arg 1)))) + +(defun image-dired-next-line () + "Move to next line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line 1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next thumbnail. + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + +(defun image-dired-previous-line () + "Move to previous line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line -1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next + ;; thumbnail. This should only happen if the user deleted a + ;; thumbnail and did not refresh, so it is not very common. But we + ;; can handle it in a good manner, so why not? + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-beginning-of-buffer () + "Move to the first image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-min)) + (while (and (not (image-at-point-p)) + (not (eobp))) + (forward-char 1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-end-of-buffer () + "Move to the last image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-max)) + (while (and (not (image-at-point-p)) + (not (bobp))) + (forward-char -1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-format-properties-string (buf file props comment) + "Format display properties. +BUF is the associated Dired buffer, FILE is the original image file +name, PROPS is a stringified list of tags and COMMENT is the image file's +comment." + (format-spec + image-dired-display-properties-format + (list + (cons ?b (or buf "")) + (cons ?f file) + (cons ?t (or props "")) + (cons ?c (or comment ""))))) + +(defun image-dired-update-header-line () + "Update image information in the header line." + (when (and (not (eobp)) + (memq major-mode '(image-dired-thumbnail-mode + image-dired-display-image-mode))) + (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) + (dired-buf (buffer-name (image-dired-associated-dired-buffer))) + (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (comment (get-text-property (point) 'comment)) + (message-log-max nil)) + (if file-name + (setq header-line-format + (image-dired-format-properties-string + dired-buf + file-name + props + comment)))))) + +(defun image-dired-dired-file-marked-p (&optional marker) + "In Dired, return t if file on current line is marked. +If optional argument MARKER is non-nil, it is a character to look +for. The default is to look for `dired-marker-char'." + (setq marker (or marker dired-marker-char)) + (save-excursion + (beginning-of-line) + (and (looking-at dired-re-mark) + (= (aref (match-string 0) 0) marker)))) + +(defun image-dired-dired-file-flagged-p () + "In Dired, return t if file on current line is flagged for deletion." + (image-dired-dired-file-marked-p dired-del-marker)) + +(defmacro image-dired--with-thumbnail-buffer (&rest body) + (declare (indent defun) (debug t)) + `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (if-let ((win (get-buffer-window buf))) + (with-selected-window win + ,@body) + ,@body)) + (user-error "No such buffer: %s" image-dired-thumbnail-buffer))) + +(defmacro image-dired--on-file-in-dired-buffer (&rest body) + "Run BODY with point on file at point in Dired buffer. +Should be called from commands in `image-dired-thumbnail-mode'." + (declare (indent defun) (debug t)) + `(let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + ,@body + (image-dired-thumb-update-marks)))))) + +(defmacro image-dired--do-mark-command (maybe-next &rest body) + "Helper macro for the mark, unmark and flag commands. +Run BODY in Dired buffer. +If optional argument MAYBE-NEXT is non-nil, show next image +according to `image-dired-marking-shows-next'." + (declare (indent defun) (debug t)) + `(image-dired--with-thumbnail-buffer + (image-dired--on-file-in-dired-buffer + ,@body) + ,(when maybe-next + '(if image-dired-marking-shows-next + (image-dired-display-next-thumbnail-original) + (image-dired-next-line))))) + +(defun image-dired-mark-thumb-original-file () + "Mark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-mark 1))) + +(defun image-dired-unmark-thumb-original-file () + "Unmark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-unmark 1))) + +(defun image-dired-flag-thumb-original-file () + "Flag original image file for deletion in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-flag-file-deletion 1))) + +(defun image-dired-toggle-mark-thumb-original-file () + "Toggle mark on original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1)))) + +(defun image-dired-unmark-all-marks () + "Remove all marks from all files in associated Dired buffer. +Also update the marks in the thumbnail buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (dired-unmark-all-marks)) + (image-dired--with-thumbnail-buffer + (image-dired-thumb-update-marks))) + +(defun image-dired-jump-original-dired-buffer () + "Jump to the Dired buffer associated with the current image file. +You probably want to use this together with +`image-dired-track-original-file'." + (interactive nil image-dired-thumbnail-mode) + (let ((buf (image-dired-associated-dired-buffer)) + window frame) + (setq window (image-dired-get-buffer-window buf)) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Associated dired buffer not visible")))) + +;;;###autoload +(defun image-dired-jump-thumbnail-buffer () + "Jump to thumbnail buffer." + (interactive) + (let ((window (image-dired-thumbnail-window)) + frame) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Thumbnail buffer not visible")))) + +(defvar image-dired-thumbnail-mode-line-up-map + (let ((map (make-sparse-keymap))) + ;; map it to "g" so that the user can press it more quickly + (define-key map "g" #'image-dired-line-up-dynamic) + ;; "f" for "fixed" number of thumbs per row + (define-key map "f" #'image-dired-line-up) + ;; "i" for "interactive" + (define-key map "i" #'image-dired-line-up-interactive) + map) + "Keymap for line-up commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-tag-map + (let ((map (make-sparse-keymap))) + ;; map it to "t" so that the user can press it more quickly + (define-key map "t" #'image-dired-tag-thumbnail) + ;; "r" for "remove" + (define-key map "r" #'image-dired-tag-thumbnail-remove) + map) + "Keymap for tag commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) + + (define-key map "<" #'image-dired-beginning-of-buffer) + (define-key map ">" #'image-dired-end-of-buffer) + (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) + (define-key map (kbd "M->") #'image-dired-end-of-buffer) + + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) + + ;; add line-up map + (define-key map "g" image-dired-thumbnail-mode-line-up-map) + ;; add tag map + (define-key map "t" image-dired-thumbnail-mode-tag-map) + + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) + + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) + + (define-key map "D" #'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) + + ;; Mouse + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail) + ;; Seems I must first set C-down-mouse-1 to undefined, or else it + ;; will trigger the buffer menu. If I try to instead bind + ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message + ;; about C-mouse-1 not being defined afterwards. Annoying, but I + ;; probably do not completely understand mouse events. + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) + map) + "Keymap for `image-dired-thumbnail-mode'.") + +(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map + "Menu for `image-dired-thumbnail-mode'." + '("Image-Dired" + ["Display image" image-dired-display-thumbnail-original-image] + ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] + "---" + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] + "---" + ["Rotate original right" image-dired-rotate-original-right] + ["Rotate original left" image-dired-rotate-original-left] + "---" + ["Comment thumbnail" image-dired-comment-thumbnail] + ["Tag current or marked thumbnails" image-dired-tag-thumbnail] + ["Remove tag from current or marked thumbnails" + image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] + "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) + ["Quit" quit-window])) + +(defvar image-dired-display-image-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "n" #'image-dired-display-next-thumbnail-original) + (define-key map "p" #'image-dired-display-previous-thumbnail-original) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + ;; Disable keybindings from `image-mode-map' that doesn't make sense here. + (define-key map "o" nil) ; image-save + map) + "Keymap for `image-dired-display-image-mode'.") + +(define-derived-mode image-dired-thumbnail-mode + special-mode "image-dired-thumbnail" + "Browse and manipulate thumbnail images using Dired. +Use `image-dired-minor-mode' to get a nice setup." + :interactive nil + (buffer-disable-undo) + (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) + (setq-local window-resize-pixelwise t) + (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record) + ;; Use approximately as much vertical spacing as horizontal. + (setq-local line-spacing (frame-char-width))) + + +;;; Display image mode + +(define-derived-mode image-dired-display-image-mode + image-mode "image-dired-image-display" + "Mode for displaying and manipulating original image. +Resized or in full-size." + :interactive nil + (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t)) + +(defvar image-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + ;; (set-keymap-parent map dired-mode-map) + ;; Hijack previous and next line movement. Let C-p and C-b be + ;; though... + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) + map) + "Keymap for `image-dired-minor-mode'.") + +(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map + "Menu for `image-dired-minor-mode'." + '("Image-dired" + ["Display thumb for next file" image-dired-next-line-and-display] + ["Display thumb for previous file" image-dired-previous-line-and-display] + ["Mark and display next" image-dired-mark-and-display-next] + "---" + ["Create thumbnails for marked files" image-dired-create-thumbs] + "---" + ["Display thumbnails append" image-dired-display-thumbs-append] + ["Display this thumbnail" image-dired-display-thumb] + ["Display image" image-dired-dired-display-image] + ["Display in external viewer" image-dired-dired-display-external] + "---" + ["Toggle display properties" image-dired-toggle-dired-display-properties + :style toggle + :selected image-dired-dired-disp-props] + ["Toggle append browsing" image-dired-toggle-append-browsing + :style toggle + :selected image-dired-append-when-browsing] + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] + ["Mark tagged files" image-dired-mark-tagged-files] + ["Comment files" image-dired-dired-comment-files] + ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + +;;;###autoload +(define-minor-mode image-dired-minor-mode + "Setup easy-to-use keybindings for the commands to be used in Dired mode. +Note that n, p and and will be hijacked and bound to +`image-dired-dired-next-line' and `image-dired-dired-previous-line'." + :keymap image-dired-minor-mode-map) + +(declare-function clear-image-cache "image.c" (&optional filter)) + +(defun image-dired-create-thumbs (&optional arg) + "Create thumbnail images for all marked files in Dired. +With prefix argument ARG, create thumbnails even if they already exist +\(i.e. use this to refresh your thumbnails)." + (interactive "P") + (let (thumb-name) + (dolist (curr-file (dired-get-marked-files)) + (setq thumb-name (image-dired-thumb-name curr-file)) + ;; If the user overrides the exist check, we must clear the + ;; image cache so that if the user wants to display the + ;; thumbnail, it is not fetched from cache. + (when arg + (clear-image-cache (expand-file-name thumb-name))) + (when (or (not (file-exists-p thumb-name)) + arg) + (image-dired-create-thumb curr-file thumb-name))))) + + +;;; Slideshow + +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") + +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") + +(defvar image-dired--slideshow-initial nil) + +(defun image-dired-slideshow-step () + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) + (image-dired-slideshow-stop))) + +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow, waiting `image-dired-slideshow-delay' between images. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (not arg) + image-dired-slideshow-delay + (if (> arg 0) + arg + (string-to-number + (let ((delay (number-to-string image-dired-slideshow-delay))) + (read-string + (format-prompt "Delay, in seconds. Decimals are accepted" delay)) + delay)))))) + (setq image-dired--slideshow-timer + (run-with-timer + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) + +(defun image-dired-slideshow-stop () + "Cancel slideshow." + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) + + +;;; Thumbnail mode (cont. 3) + +(defun image-dired-delete-char () + "Remove current thumbnail from thumbnail buffer and line up." + (interactive nil image-dired-thumbnail-mode) + (let ((inhibit-read-only t)) + (delete-char 1) + (when (= (following-char) ?\s) + (delete-char 1)))) + +;;;###autoload +(defun image-dired-display-thumbs-append () + "Append thumbnails to `image-dired-thumbnail-buffer'." + (interactive) + (image-dired-display-thumbs nil t t)) + +;;;###autoload +(defun image-dired-display-thumb () + "Shorthand for `image-dired-display-thumbs' with prefix argument." + (interactive) + (image-dired-display-thumbs t nil t)) + +(defun image-dired-line-up () + "Line up thumbnails according to `image-dired-thumbs-per-row'. +See also `image-dired-line-up-dynamic'." + (interactive) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1)) + (while (not (eobp)) + (forward-char) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1))) + (goto-char (point-min)) + (let ((seen 0) + (thumb-prev-pos 0) + (thumb-width-chars + (ceiling (/ (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width)) + (float (frame-char-width)))))) + (while (not (eobp)) + (forward-char) + (if (= image-dired-thumbs-per-row 1) + (insert "\n") + (cl-incf thumb-prev-pos thumb-width-chars) + (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos))) + (cl-incf seen) + (when (and (= seen (- image-dired-thumbs-per-row 1)) + (not (eobp))) + (forward-char) + (insert "\n") + (setq seen 0) + (setq thumb-prev-pos 0))))) + (goto-char (point-min)))) + +(defun image-dired-line-up-dynamic () + "Line up thumbnails images dynamically. +Calculate how many thumbnails fit." + (interactive) + (let* ((char-width (frame-char-width)) + (width (image-dired-window-width-pixels (image-dired-thumbnail-window))) + (image-dired-thumbs-per-row + (/ width + (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width) + char-width)))) + (image-dired-line-up))) + +(defun image-dired-line-up-interactive () + "Line up thumbnails interactively. +Ask user how many thumbnails should be displayed per row." + (interactive) + (let ((image-dired-thumbs-per-row + (string-to-number (read-string "How many thumbs per row: ")))) + (if (not (> image-dired-thumbs-per-row 0)) + (message "Number must be greater than 0") + (image-dired-line-up)))) + +(defun image-dired-thumbnail-display-external () + "Display original image for thumbnail at point using external viewer." + (interactive) + (let ((file (image-dired-original-file-name))) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (start-process "image-dired-thumb-external" nil + image-dired-external-viewer file))))) + +;;;###autoload +(defun image-dired-dired-display-external () + "Display file at point using an external viewer." + (interactive) + (let ((file (dired-get-filename))) + (start-process "image-dired-external" nil + image-dired-external-viewer file))) + +(defun image-dired-window-width-pixels (window) + "Calculate WINDOW width in pixels." + (* (window-width window) (frame-char-width))) + +(defun image-dired-display-window () + "Return window where `image-dired-display-image-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer)) + nil t)) + +(defun image-dired-thumbnail-window () + "Return window where `image-dired-thumbnail-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer)) + nil t)) + +(defun image-dired-associated-dired-buffer-window () + "Return window where associated Dired buffer is visible." + (let (buf) + (if (image-dired-image-at-point-p) + (progn + (setq buf (image-dired-associated-dired-buffer)) + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)))) + (error "No thumbnail image at point")))) + +(defun image-dired-display-image (file &optional _ignored) + "Display image FILE in image buffer. +Use this when you want to display the image, in a new window. +The window will use `image-dired-display-image-mode' which is +based on `image-mode'." + (declare (advertised-calling-convention (file) "29.1")) + (setq file (expand-file-name file)) + (when (not (file-exists-p file)) + (error "No such file: %s" file)) + (let ((buf (get-buffer image-dired-display-image-buffer)) + (cur-win (selected-window))) + (when buf + (kill-buffer buf)) + (when-let ((buf (find-file-noselect file nil t))) + (pop-to-buffer buf) + (rename-buffer image-dired-display-image-buffer) + (image-dired-display-image-mode) + (select-window cur-win)))) + +(defun image-dired-display-thumbnail-original-image (&optional arg) + "Display current thumbnail's original image in display buffer. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (let ((file (image-dired-original-file-name))) + (if (not (string-equal major-mode "image-dired-thumbnail-mode")) + (message "Not in image-dired-thumbnail-mode") + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (image-dired-display-image file arg)))))) + + +;;;###autoload +(defun image-dired-dired-display-image (&optional arg) + "Display current image file. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (image-dired-display-image (dired-get-filename) arg)) + +(defun image-dired-image-at-point-p () + "Return non-nil if there is an `image-dired' thumbnail at point." + (get-text-property (point) 'image-dired-thumbnail)) + +(defun image-dired-refresh-thumb () + "Force creation of new image for current thumbnail." + (interactive nil image-dired-thumbnail-mode) + (let* ((file (image-dired-original-file-name)) + (thumb (expand-file-name (image-dired-thumb-name file)))) + (clear-image-cache (expand-file-name thumb)) + (image-dired-create-thumb file thumb))) + +(defun image-dired-rotate-original (degrees) + "Rotate original image DEGREES degrees." + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-original-program) + (if (not (image-dired-image-at-point-p)) + (message "No image at point") + (let* ((file (image-dired-original-file-name)) + (spec + (list + (cons ?d degrees) + (cons ?o (expand-file-name file)) + (cons ?t image-dired-temp-rotate-image-file)))) + (unless (eq 'jpeg (image-type file)) + (user-error "Only JPEG images can be rotated")) + (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program + nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-original-options)))) + (error "Could not rotate image") + (image-dired-display-image image-dired-temp-rotate-image-file) + (if (or (and image-dired-rotate-original-ask-before-overwrite + (y-or-n-p + "Rotate to temp file OK. Overwrite original image? ")) + (not image-dired-rotate-original-ask-before-overwrite)) + (progn + (copy-file image-dired-temp-rotate-image-file file t) + (image-dired-refresh-thumb)) + (image-dired-display-image file)))))) + +(defun image-dired-rotate-original-left () + "Rotate original image left (counter clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "270")) + +(defun image-dired-rotate-original-right () + "Rotate original image right (clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "90")) + + +;;; EXIF support + +(defun image-dired-get-exif-file-name (file) + "Use the image's EXIF information to return a unique file name. +The file name should be unique as long as you do not take more than +one picture per second. The original file name is suffixed at the end +for traceability. The format of the returned file name is +YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from +`image-dired-copy-with-exif-file-name'." + (let (data no-exif-data-found) + (if (not (eq 'jpeg (image-type (expand-file-name file)))) + (setq no-exif-data-found t + data (format-time-string + "%Y:%m:%d %H:%M:%S" + (file-attribute-modification-time + (file-attributes (expand-file-name file))))) + (setq data (exif-field 'date-time (exif-parse-file + (expand-file-name file))))) + (while (string-match "[ :]" data) + (setq data (replace-match "_" nil nil data))) + (format "%s%s%s" data + (if no-exif-data-found + "_noexif_" + "_") + (file-name-nondirectory file)))) + +(defun image-dired-thumbnail-set-image-description () + "Set the ImageDescription EXIF tag for the original image. +If the image already has a value for this tag, it is used as the +default value at the prompt." + (interactive) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-original-file-name)) + (old-value (or (exif-field 'description (exif-parse-file file)) ""))) + (if (eq 0 + (image-dired-set-exif-data file "ImageDescription" + (read-string "Value of ImageDescription: " + old-value))) + (message "Successfully wrote ImageDescription tag") + (error "Could not write ImageDescription tag"))))) + +(defun image-dired-set-exif-data (file tag-name tag-value) + "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE." + (image-dired--check-executable-exists + 'image-dired-cmd-write-exif-data-program) + (let ((spec + (list + (cons ?f (expand-file-name file)) + (cons ?t tag-name) + (cons ?v tag-value)))) + (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-write-exif-data-options)))) + +(defun image-dired-copy-with-exif-file-name () + "Copy file with unique name to main image directory. +Copy current or all marked files in Dired to a new file in your +main image directory, using a file name generated by +`image-dired-get-exif-file-name'. A typical usage for this if when +copying images from a digital camera into the image directory. + + Typically, you would open up the folder with the incoming +digital images, mark the files to be copied, and execute this +function. The result is a couple of new files in +`image-dired-main-image-directory' called +2005_05_08_12_52_00_dscn0319.jpg, +2005_05_08_14_27_45_dscn0320.jpg etc." + (interactive) + (let (new-name + (files (dired-get-marked-files))) + (mapc + (lambda (curr-file) + (setq new-name + (format "%s/%s" + (file-name-as-directory + (expand-file-name image-dired-main-image-directory)) + (image-dired-get-exif-file-name curr-file))) + (message "Copying %s to %s" curr-file new-name) + (copy-file curr-file new-name)) + files))) + +;;; Thumbnail mode (cont.) + +(defun image-dired-display-next-thumbnail-original (&optional arg) + "Move to the next image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--with-thumbnail-buffer + (image-dired-forward-image arg t) + (image-dired-display-thumbnail-original-image))) + +(defun image-dired-display-previous-thumbnail-original (arg) + "Move to the previous image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired-display-next-thumbnail-original (- arg))) + + +;;; Image Comments + +(defun image-dired-write-comments (file-comments) + "Write file comments to database. +Write file comments to one or more files. +FILE-COMMENTS is an alist on the following form: + ((FILE . COMMENT) ... )" + (image-dired-sane-db-file) + (let (end comment-beg-pos comment-end-pos file comment) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-comments) + (setq file (car elt) + comment (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + ;; Delete old comment, if any + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (match-beginning 0)) + ;; Any tags after the comment? + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + ;; Delete comment tag and comment + (delete-region comment-beg-pos comment-end-pos)) + ;; Insert new comment + (beginning-of-line) + (unless (search-forward ";" end t) + (end-of-line) + (insert ";")) + (insert (format "comment:%s;" comment))) + ;; File does not exist in database - add it. + (goto-char (point-max)) + (insert (format "%s;comment:%s\n" file comment)))) + (save-buffer)))) + +(defun image-dired-update-property (prop value) + "Update text property PROP with value VALUE at point." + (let ((inhibit-read-only t)) + (put-text-property + (point) (1+ (point)) + prop + value))) + +;;;###autoload +(defun image-dired-dired-comment-files () + "Add comment to current or marked files in Dired." + (interactive) + (let ((comment (image-dired-read-comment))) + (image-dired-write-comments + (mapcar + (lambda (curr-file) + (cons curr-file comment)) + (dired-get-marked-files))))) + +(defun image-dired-comment-thumbnail () + "Add comment to current thumbnail in thumbnail buffer." + (interactive) + (let* ((file (image-dired-original-file-name)) + (comment (image-dired-read-comment file))) + (image-dired-write-comments (list (cons file comment))) + (image-dired-update-property 'comment comment)) + (image-dired-update-header-line)) + +(defun image-dired-read-comment (&optional file) + "Read comment for an image. +Optionally use old comment from FILE as initial value." + (let ((comment + (read-string + "Comment: " + (if file (image-dired-get-comment file))))) + comment)) + +(defun image-dired-get-comment (file) + "Get comment for file FILE." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end comment-beg-pos comment-end-pos comment) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (point)) + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + (setq comment (buffer-substring + comment-beg-pos comment-end-pos)))) + comment))) + +;;;###autoload +(defun image-dired-mark-tagged-files (regexp) + "Use REGEXP to mark files with matching tag. +A `tag' is a keyword, a piece of meta data, associated with an +image file and stored in image-dired's database file. This command +lets you input a regexp and this will be matched against all tags +on all image files in the database file. The files that have a +matching tag will be marked in the Dired buffer." + (interactive "sMark tagged files (regexp): ") + (image-dired-sane-db-file) + (let ((hits 0) + files) + (image-dired--with-db-file + ;; Collect matches + (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t) + (let ((file (match-string 1)) + (tags (split-string (match-string 2) ";"))) + (when (seq-find (lambda (tag) + (string-match-p regexp tag)) + tags) + (push file files))))) + ;; Mark files + (dolist (curr-file files) + ;; I tried using `dired-mark-files-regexp' but it was waaaay to + ;; slow. Don't bother about hits found in other directories + ;; than the current one. + (when (string= (file-name-as-directory + (expand-file-name default-directory)) + (file-name-as-directory + (file-name-directory curr-file))) + (setq curr-file (file-name-nondirectory curr-file)) + (goto-char (point-min)) + (when (search-forward-regexp (format "\\s %s$" curr-file) nil t) + (setq hits (+ hits 1)) + (dired-mark 1)))) + (message "%d files with matching tag marked" hits))) + + + +;;; Mouse support + +(defun image-dired-mouse-display-image (event) + "Use mouse EVENT, call `image-dired-display-image' to display image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (let ((file (image-dired-original-file-name))) + (when file + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-display-image file)))) + +(defun image-dired-mouse-select-thumbnail (event) + "Use mouse EVENT to select thumbnail image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + + +;;; Dired marks and tags + +(defun image-dired-thumb-file-marked-p (&optional flagged) + "Check if file is marked in associated Dired buffer. +If optional argument FLAGGED is non-nil, check if file is flagged +for deletion instead." + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (when (and dired-buf file-name) + (with-current-buffer dired-buf + (save-excursion + (when (dired-goto-file file-name) + (if flagged + (image-dired-dired-file-flagged-p) + (image-dired-dired-file-marked-p)))))))) + +(defun image-dired-thumb-file-flagged-p () + "Check if file is flagged for deletion in associated Dired buffer." + (image-dired-thumb-file-marked-p t)) + +(defun image-dired-delete-marked () + "Delete current or marked thumbnails and associated images." + (interactive) + (image-dired--with-marked + (image-dired-delete-char) + (unless (bobp) + (backward-char))) + (image-dired--line-up-with-method) + (with-current-buffer (image-dired-associated-dired-buffer) + (dired-do-delete))) + +(defun image-dired-thumb-update-marks () + "Update the marks in the thumbnail buffer." + (when image-dired-thumb-visible-marks + (with-current-buffer image-dired-thumbnail-buffer + (save-mark-and-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (while (not (eobp)) + (with-silent-modifications + (cond ((image-dired-thumb-file-marked-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-mark)) + ((image-dired-thumb-file-flagged-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-flagged)) + (t (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))))) + (forward-char))))))) + +(defun image-dired-mouse-toggle-mark-1 () + "Toggle Dired mark for current thumbnail. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-toggle-mark-thumb-original-file)) + +(defun image-dired-mouse-toggle-mark (event) + "Use mouse EVENT to toggle Dired mark for thumbnail. +Toggle marks of all thumbnails in region, if it's active. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (interactive "e") + (if (use-region-p) + (let ((end (region-end))) + (save-excursion + (goto-char (region-beginning)) + (while (<= (point) end) + (when (image-dired-image-at-point-p) + (image-dired-mouse-toggle-mark-1)) + (forward-char)))) + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (image-dired-mouse-toggle-mark-1)) + (image-dired-thumb-update-marks)) + +(defun image-dired-dired-display-properties () + "Display properties for Dired file in the echo area." + (interactive) + (let* ((file (dired-get-filename)) + (file-name (file-name-nondirectory file)) + (dired-buf (buffer-name (current-buffer))) + (props (mapconcat #'identity (image-dired-list-tags file) ", ")) + (comment (image-dired-get-comment file)) + (message-log-max nil)) + (if file-name + (message "%s" + (image-dired-format-properties-string + dired-buf + file-name + props + comment))))) + + + +;;; Gallery support + +;; TODO: +;; * Support gallery creation when using per-directory thumbnail +;; storage. +;; * Enhanced gallery creation with basic CSS-support and pagination +;; of tag pages with many pictures. + +(defgroup image-dired-gallery nil + "Image-Dired support for generating a HTML gallery." + :prefix "image-dired-" + :group 'image-dired + :version "29.1") + +(defcustom image-dired-gallery-dir + (expand-file-name ".image-dired_gallery" image-dired-dir) + "Directory to store generated gallery html pages. +The name of this directory needs to be \"shared\" to the public +so that it can access the index.html page that image-dired creates." + :type 'directory) + +(defcustom image-dired-gallery-image-root-url + "https://example.org/image-diredpics" + "URL where the full size images are to be found on your web server. +Note that this URL has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-thumb-image-root-url + "https://example.org/image-diredthumbs" + "URL where the thumbnail images are to be found on your web server. +Note that URL path has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-hidden-tags + (list "private" "hidden" "pending") + "List of \"hidden\" tags. +Used by `image-dired-gallery-generate' to leave out \"hidden\" images." + :type '(repeat string)) + +(defvar image-dired-tag-file-list nil + "List to store tag-file structure.") + +(defvar image-dired-file-tag-list nil + "List to store file-tag structure.") + +(defvar image-dired-file-comment-list nil + "List to store file comments.") + +(defun image-dired--add-to-tag-file-lists (tag file) + "Helper function used from `image-dired--create-gallery-lists'. + +Add TAG to FILE in one list and FILE to TAG in the other. + +Lisp structures look like the following: + +image-dired-file-tag-list: + + ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...) + (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...) + ...) + +image-dired-tag-file-list: + + ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...) + (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...) + ...)" + ;; Add tag to file list + (let (curr) + (if image-dired-file-tag-list + (if (setq curr (assoc file image-dired-file-tag-list)) + (setcdr curr (cons tag (cdr curr))) + (setcdr image-dired-file-tag-list + (cons (list file tag) (cdr image-dired-file-tag-list)))) + (setq image-dired-file-tag-list (list (list file tag)))) + ;; Add file to tag list + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired--add-to-file-comment-list (file comment) + "Helper function used from `image-dired--create-gallery-lists'. + +For FILE, add COMMENT to list. + +Lisp structure looks like the following: + +image-dired-file-comment-list: + + ((\"filename1\" . \"comment1\") + (\"filename2\" . \"comment2\") + ...)" + (if image-dired-file-comment-list + (if (not (assoc file image-dired-file-comment-list)) + (setcdr image-dired-file-comment-list + (cons (cons file comment) + (cdr image-dired-file-comment-list)))) + (setq image-dired-file-comment-list (list (cons file comment))))) + +(defun image-dired--create-gallery-lists () + "Create temporary lists used by `image-dired-gallery-generate'." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end beg file row-tags) + (setq image-dired-tag-file-list nil) + (setq image-dired-file-tag-list nil) + (setq image-dired-file-comment-list nil) + (goto-char (point-min)) + (while (search-forward-regexp "^." nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (setq beg (point)) + (unless (search-forward ";" end nil) + (error "Something is really wrong, check format of database")) + (setq row-tags (split-string + (buffer-substring beg end) ";")) + (setq file (car row-tags)) + (dolist (x (cdr row-tags)) + (if (not (string-match "^comment:\\(.*\\)" x)) + (image-dired--add-to-tag-file-lists x file) + (image-dired--add-to-file-comment-list file (match-string 1 x))))))) + ;; Sort tag-file list + (setq image-dired-tag-file-list + (sort image-dired-tag-file-list + (lambda (x y) + (string< (car x) (car y)))))) + +(defun image-dired--hidden-p (file) + "Return t if image FILE has a \"hidden\" tag." + (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list)) + if (member tag image-dired-gallery-hidden-tags) return t)) + +(defun image-dired-gallery-generate () + "Generate gallery pages. +First we create a couple of Lisp structures from the database to make +it easier to generate, then HTML-files are created in +`image-dired-gallery-dir'." + (interactive) + (if (eq 'per-directory image-dired-thumbnail-storage) + (error "Currently, gallery generation is not supported \ +when using per-directory thumbnail file storage")) + (image-dired--create-gallery-lists) + (let ((tags image-dired-tag-file-list) + (index-file (format "%s/index.html" image-dired-gallery-dir)) + count tag tag-file + comment file-tags tag-link tag-link-list) + ;; Make sure gallery root exist + (if (file-exists-p image-dired-gallery-dir) + (if (not (file-directory-p image-dired-gallery-dir)) + (error "Variable image-dired-gallery-dir is not a directory")) + ;; FIXME: Should we set umask to 077 here, as we do for thumbnails? + (make-directory image-dired-gallery-dir)) + ;; Open index file + (with-temp-file index-file + (if (file-exists-p index-file) + (insert-file-contents index-file)) + (insert "\n") + (insert " \n") + (insert "

Image-Dired Gallery

\n") + (insert (format "

\n Gallery generated %s\n

\n" + (current-time-string))) + (insert "

Tag index

\n") + (setq count 1) + ;; Pre-generate list of all tag links + (dolist (curr tags) + (setq tag (car curr)) + (when (not (member tag image-dired-gallery-hidden-tags)) + (setq tag-link (format "%s" count tag)) + (if tag-link-list + (setq tag-link-list + (append tag-link-list (list (cons tag tag-link)))) + (setq tag-link-list (list (cons tag tag-link)))) + (setq count (1+ count)))) + (setq count 1) + ;; Main loop where we generated thumbnail pages per tag + (dolist (curr tags) + (setq tag (car curr)) + ;; Don't display hidden tags + (when (not (member tag image-dired-gallery-hidden-tags)) + ;; Insert link to tag page in index + (insert (format " %s
\n" (cdr (assoc tag tag-link-list)))) + ;; Open per-tag file + (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count)) + (with-temp-file tag-file + (if (file-exists-p tag-file) + (insert-file-contents tag-file)) + (erase-buffer) + (insert "\n") + (insert " \n") + (insert "

Index

\n") + (insert (format "

Images with tag "%s"

" tag)) + ;; Main loop for files per tag page + (dolist (file (cdr curr)) + (unless (image-dired-hidden-p file) + ;; Insert thumbnail with link to full image + (insert + (format "\n" + image-dired-gallery-image-root-url + (file-name-nondirectory file) + image-dired-gallery-thumb-image-root-url + (file-name-nondirectory (image-dired-thumb-name file)) file)) + ;; Insert comment, if any + (if (setq comment (cdr (assoc file image-dired-file-comment-list))) + (insert (format "
\n%s
\n" comment)) + (insert "
\n")) + ;; Insert links to other tags, if any + (when (> (length + (setq file-tags (assoc file image-dired-file-tag-list))) 2) + (insert "[ ") + (dolist (extra-tag file-tags) + ;; Only insert if not file name or the main tag + (if (and (not (equal extra-tag tag)) + (not (equal extra-tag file))) + (insert + (format "%s " (cdr (assoc extra-tag tag-link-list)))))) + (insert "]
\n")))) + (insert "

Index

\n") + (insert " \n") + (insert "\n")) + (setq count (1+ count)))) + (insert " \n") + (insert "")))) + + +;;; Tag support + +(defvar image-dired-widget-list nil + "List to keep track of meta data in edit buffer.") + +(declare-function widget-forward "wid-edit" (arg)) + +;;;###autoload +(defun image-dired-dired-edit-comment-and-tags () + "Edit comment and tags of current or marked image files. +Edit comment and tags for all marked image files in an +easy-to-use form." + (interactive) + (setq image-dired-widget-list nil) + ;; Setup buffer. + (let ((files (dired-get-marked-files))) + (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*") + (kill-all-local-variables) + (let ((inhibit-read-only t)) + (erase-buffer)) + (remove-overlays) + ;; Some help for the user. + (widget-insert +"\nEdit comments and tags for each image. Separate multiple tags +with a comma. Move forward between fields using TAB or RET. +Move to the previous field using backtab (S-TAB). Save by +activating the Save button at the bottom of the form or cancel +the operation by activating the Cancel button.\n\n") + ;; Here comes all images and a comment and tag field for each + ;; image. + (let (thumb-file img comment-widget tag-widget) + + (dolist (file files) + + (setq thumb-file (image-dired-thumb-name file) + img (create-image thumb-file)) + + (insert-image img) + (widget-insert "\n\nComment: ") + (setq comment-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (image-dired-get-comment file) ""))) + (widget-insert "\nTags: ") + (setq tag-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (mapconcat + #'identity + (image-dired-list-tags file) + ",") ""))) + ;; Save information in all widgets so that we can use it when + ;; the user saves the form. + (setq image-dired-widget-list + (append image-dired-widget-list + (list (list file comment-widget tag-widget)))) + (widget-insert "\n\n"))) + + ;; Footer with Save and Cancel button. + (widget-insert "\n") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (image-dired-save-information-from-widgets) + (bury-buffer) + (message "Done")) + "Save") + (widget-insert " ") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (bury-buffer) + (message "Operation canceled")) + "Cancel") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + ;; Jump to the first widget. + (widget-forward 1))) + +(defun image-dired-save-information-from-widgets () + "Save information found in `image-dired-widget-list'. +Use the information in `image-dired-widget-list' to save comments and +tags to their respective image file. Internal function used by +`image-dired-dired-edit-comment-and-tags'." + (let (file comment tag-string tag-list lst) + (image-dired-write-comments + (mapcar + (lambda (widget) + (setq file (car widget) + comment (widget-value (cadr widget))) + (cons file comment)) + image-dired-widget-list)) + (image-dired-write-tags + (dolist (widget image-dired-widget-list lst) + (setq file (car widget) + tag-string (widget-value (car (cddr widget))) + tag-list (split-string tag-string ",")) + (dolist (tag tag-list) + (push (cons file tag) lst)))))) + + +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun image-dired-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (file-name-nondirectory + (directory-file-name + (file-name-directory (image-dired-original-file-name))))) + +(defun image-dired-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(image-dired-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(file-name-directory (image-dired-original-file-name))) + (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name))) + (handler . image-dired-bookmark-jump))) + +;;;###autoload +(defun image-dired-bookmark-jump (bookmark) + "Default bookmark handler for Image-Dired buffers." + ;; User already cached thumbnails, so disable any checking. + (let ((image-dired-show-all-from-dir-max-files nil)) + (image-dired (bookmark-prop-get bookmark 'location)) + ;; TODO: Go to the bookmarked file, if it exists. + ;; (bookmark-prop-get bookmark 'image-dired-file) + (goto-char (point-min)))) + +(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired") + +;;; Obsolete + +;;;###autoload +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +;;;###autoload +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings + #'image-dired-minor-mode "26.1") + +(defcustom image-dired-temp-image-file + (expand-file-name ".image-dired_temp" image-dired-dir) + "Name of temporary image file used by various commands." + :type 'file) +(make-obsolete-variable 'image-dired-temp-image-file + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-program + (if (executable-find "gm") "gm" "convert") + "Executable used to create temporary image. +Used together with `image-dired-cmd-create-temp-image-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-create-temp-image-program + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) + "Options of command used to create temporary image for display window. +Used together with `image-dired-cmd-create-temp-image-program', +Available format specifiers are: %w and %h which are replaced by +the calculated max size for width and height in the image display window, +%f which is replaced by the file name of the original image and %t which +is replaced by the file name of the temporary file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-create-temp-image-options + "no longer used." "29.1") + +(defcustom image-dired-display-window-width-correction 1 + "Number to be used to correct image display window width. +Change if the default (1) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-width-correction + "no longer used." "29.1") + +(defcustom image-dired-display-window-height-correction 0 + "Number to be used to correct image display window height. +Change if the default (0) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-height-correction + "no longer used." "29.1") + +(defun image-dired-display-window-width (window) + "Return width, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-width-pixels window) + image-dired-display-window-width-correction)) + +(defun image-dired-display-window-height (window) + "Return height, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-height-pixels window) + image-dired-display-window-height-correction)) + +(defun image-dired-window-height-pixels (window) + "Calculate WINDOW height in pixels." + (declare (obsolete nil "29.1")) + ;; Note: The mode-line consumes one line + (* (- (window-height window) 1) (frame-char-height))) + +(defcustom image-dired-cmd-read-exif-data-program "exiftool" + "Program used to read EXIF data to image. +Used together with `image-dired-cmd-read-exif-data-options'." + :type 'file) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-program + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f") + "Arguments of command used to read EXIF data. +Used with `image-dired-cmd-read-exif-data-program'. +Available format specifiers are: %f which is replaced +by the image file name and %t which is replaced by the tag name." + :version "26.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-options + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defun image-dired-get-exif-data (file tag-name) + "From FILE, return EXIF tag TAG-NAME." + (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-read-exif-data-program) + (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) + (spec (list (cons ?f file) (cons ?t tag-name))) + tag-value) + (with-current-buffer buf + (delete-region (point-min) (point-max)) + (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program + nil t nil + (mapcar + (lambda (arg) (format-spec arg spec)) + image-dired-cmd-read-exif-data-options)) + 0)) + (error "Could not get EXIF tag") + (goto-char (point-min)) + ;; Clean buffer from newlines and carriage returns before + ;; getting final info + (while (search-forward-regexp "[\n\r]" nil t) + (replace-match "" nil t)) + (setq tag-value (buffer-substring (point-min) (point-max))))) + tag-value)) + +(defcustom image-dired-cmd-rotate-thumbnail-program + (if (executable-find "gm") "gm" "mogrify") + "Executable used to rotate thumbnail. +Used together with `image-dired-cmd-rotate-thumbnail-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1") + +(defcustom image-dired-cmd-rotate-thumbnail-options + (let ((opts '("-rotate" "%d" "%t"))) + (if (executable-find "gm") (cons "mogrify" opts) opts)) + "Arguments of command used to rotate thumbnail image. +Used with `image-dired-cmd-rotate-thumbnail-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or 270 +\(for 90 degrees right and left), %t which is replaced by the file name +of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") + +(defun image-dired-rotate-thumbnail (degrees) + "Rotate thumbnail DEGREES degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-thumbnail-program) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) + (thumb (expand-file-name file)) + (spec (list (cons ?d degrees) (cons ?t thumb)))) + (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-thumbnail-options)) + (clear-image-cache thumb)))) + +(defun image-dired-rotate-thumbnail-left () + "Rotate thumbnail left (counter clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "270"))) + +(defun image-dired-rotate-thumbnail-right () + "Rotate thumbnail counter right (clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "90"))) + +(defun image-dired-modify-mark-on-thumb-original-file (command) + "Modify mark in Dired buffer. +COMMAND is one of `mark' for marking file in Dired, `unmark' for +unmarking file in Dired or `flag' for flagging file for delete in +Dired." + (declare (obsolete image-dired--on-file-in-dired-buffer "29.1")) + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (message "%s" file-name) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) + +(defun image-dired-display-current-image-full () + "Display current image in full size." + (declare (obsolete image-transform-original "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file) + (with-current-buffer image-dired-display-image-buffer + (image-transform-original))) + (error "No original file name at point")))) + +(defun image-dired-display-current-image-sized () + "Display current image in sized to fit window dimensions." + (declare (obsolete image-mode-fit-frame "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file)) + (error "No original file name at point")))) + +(defun image-dired-add-to-tag-file-list (tag file) + "Add relation between TAG and FILE." + (declare (obsolete nil "29.1")) + (let (curr) + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired-display-thumb-properties () + "Display thumbnail properties in the echo area." + (declare (obsolete image-dired-update-header-line "29.1")) + (image-dired-update-header-line)) + +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + +(define-obsolete-function-alias 'image-dired-create-display-image-buffer + #'ignore "29.1") +(define-obsolete-function-alias 'image-dired-create-gallery-lists + #'image-dired--create-gallery-lists "29.1") +(define-obsolete-function-alias 'image-dired-add-to-file-comment-list + #'image-dired--add-to-file-comment-list "29.1") +(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists + #'image-dired--add-to-tag-file-lists "29.1") +(define-obsolete-function-alias 'image-dired-hidden-p + #'image-dired--hidden-p "29.1") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;; TEST-SECTION ;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defvar image-dired-dir-max-size 12300000) + +;; (defun image-dired-test-clean-old-files () +;; "Clean `image-dired-dir' from old thumbnail files. +;; \"Oldness\" measured using last access time. If the total size of all +;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size', +;; old files are deleted until the max size is reached." +;; (let* ((files +;; (sort +;; (mapcar +;; (lambda (f) +;; (let ((fattribs (file-attributes f))) +;; `(,(file-attribute-access-time fattribs) +;; ,(file-attribute-size fattribs) ,f))) +;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$")) +;; ;; Sort function. Compare time between two files. +;; (lambda (l1 l2) +;; (time-less-p (car l1) (car l2))))) +;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files)))) +;; (while (> dirsize image-dired-dir-max-size) +;; (y-or-n-p +;; (format "Size of thumbnail directory: %d, delete old file %s? " +;; dirsize (cadr (cdar files)))) +;; (delete-file (cadr (cdar files))) +;; (setq dirsize (- dirsize (car (cdar files)))) +;; (setq files (cdr files))))) + +(provide 'image-dired) + +;;; image-dired.el ends here diff --git a/lisp/image/image-dired-tags.el b/lisp/image/image-dired-tags.el new file mode 100644 index 00000000000..9f12354111c --- /dev/null +++ b/lisp/image/image-dired-tags.el @@ -0,0 +1,3080 @@ +;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- + +;; Copyright (C) 2005-2022 Free Software Foundation, Inc. + +;; Version: 0.4.11 +;; Keywords: multimedia +;; Author: Mathias Dahl + +;; 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 . + +;;; Commentary: + +;; BACKGROUND +;; ========== +;; +;; I needed a program to browse, organize and tag my pictures. I got +;; tired of the old gallery program I used as it did not allow +;; multi-file operations easily. Also, it put things out of my +;; control. Image viewing programs I tested did not allow multi-file +;; operations or did not do what I wanted it to. +;; +;; So, I got the idea to use the wonderful functionality of Emacs and +;; `dired' to do it. It would allow me to do almost anything I wanted, +;; which is basically just to browse all my pictures in an easy way, +;; letting me manipulate and tag them in various ways. `dired' already +;; provide all the file handling and navigation facilities; I only +;; needed to add some functions to display the images. +;; +;; I briefly tried out thumbs.el, and although it seemed more +;; powerful than this package, it did not work the way I wanted to. It +;; was too slow to create thumbnails of all files in a directory (I +;; currently keep all my 2000+ images in the same directory) and +;; browsing the thumbnail buffer was slow too. image-dired.el will not +;; create thumbnails until they are needed and the browsing is done +;; quickly and easily in Dired. I copied a great deal of ideas and +;; code from there though... :) +;; +;; `image-dired' stores the thumbnail files in `image-dired-dir' +;; using the file name format ORIGNAME.thumb.ORIGEXT. For example +;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for +;; now just a plain text file with the following format: +;; +;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN +;; +;; +;; PREREQUISITES +;; ============= +;; +;; * The GraphicsMagick or ImageMagick package; Image-Dired uses +;; whichever is available. +;; +;; A) For GraphicsMagick, `gm' is used. +;; Find it here: http://www.graphicsmagick.org/ +;; +;; B) For ImageMagick, `convert' and `mogrify' are used. +;; Find it here: https://www.imagemagick.org. +;; +;; * For non-lossy rotation of JPEG images, the JpegTRAN program is +;; needed. +;; +;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is +;; needed. It can be found here: https://exiftool.org/. This +;; function is, among other things, used for writing comments to +;; image files using `image-dired-thumbnail-set-image-description'. +;; +;; +;; USAGE +;; ===== +;; +;; This information has been moved to the manual. Type `C-h r' to open +;; the Emacs manual and go to the node Thumbnails by typing `g +;; Image-Dired RET'. +;; +;; Quickstart: M-x image-dired RET DIRNAME RET +;; +;; where DIRNAME is a directory containing image files. +;; +;; LIMITATIONS +;; =========== +;; +;; * Supports all image formats that Emacs and convert supports, but +;; the thumbnails are hard-coded to JPEG or PNG format. It uses +;; JPEG by default, but can optionally follow the Thumbnail Managing +;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user +;; option `image-dired-thumbnail-storage'. +;; +;; * WARNING: The "database" format used might be changed so keep a +;; backup of `image-dired-db-file' when testing new versions. +;; +;; TODO +;; ==== +;; +;; * Investigate if it is possible to also write the tags to the image +;; files. +;; +;; * From thumbs.el: Add an option for clean-up/max-size functionality +;; for thumbnail directory. +;; +;; * From thumbs.el: Add setroot function. +;; +;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out +;; which is best, saving old batch just before inserting new, or +;; saving the current batch in the ring when inserting it. Adding +;; it probably needs rewriting `image-dired-display-thumbs' to be more general. +;; +;; * Find some way of toggling on and off really nice keybindings in +;; Dired (for example, using C-n or instead of C-S-n). +;; Richard suggested that we could keep C-t as prefix for +;; image-dired commands as it is currently not used in Dired. He +;; also suggested that `dired-next-line' and `dired-previous-line' +;; figure out if image-dired is enabled in the current buffer and, +;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line', +;; respectively. Update: This is partly done; some bindings have +;; now been added to Dired. +;; +;; * In some way keep track of buffers and windows and stuff so that +;; it works as the user expects. +;; +;; * More/better documentation. + +;;; Code: + +(require 'dired) +(require 'exif) +(require 'image-mode) +(require 'widget) +(require 'xdg) + +(eval-when-compile + (require 'cl-lib) + (require 'wid-edit)) + + +;;; Customizable variables + +(defgroup image-dired nil + "Use Dired to browse your images as thumbnails, and more." + :prefix "image-dired-" + :link '(info-link "(emacs) Image-Dired") + :group 'multimedia) + +(defcustom image-dired-dir (locate-user-emacs-file "image-dired/") + "Directory where thumbnail images are stored. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; they will be +saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See +`image-dired-thumbnail-storage'." + :type 'directory) + +(defcustom image-dired-thumbnail-storage 'use-image-dired-dir + "How `image-dired' stores thumbnail files. +There are two ways that Image-Dired can store and generate +thumbnails. If you set this variable to one of the two following +values, they will be stored in the JPEG format: + +- `use-image-dired-dir' means that the thumbnails are stored in a + central directory. + +- `per-directory' means that each thumbnail is stored in a + subdirectory called \".image-dired\" in the same directory + where the image file is. + +It can also use the \"Thumbnail Managing Standard\", which allows +sharing of thumbnails across different programs. Thumbnails will +be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in +`image-dired-dir'. Thumbnails are saved in the PNG format, and +can be one of the following sizes: + +- `standard' means use thumbnails sized 128x128. +- `standard-large' means use thumbnails sized 256x256. +- `standard-x-large' means use thumbnails sized 512x512. +- `standard-xx-large' means use thumbnails sized 1024x1024. + +For more information on the Thumbnail Managing Standard, see: +https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html" + :type '(choice :tag "How to store thumbnail files" + (const :tag "Use image-dired-dir" use-image-dired-dir) + (const :tag "Thumbnail Managing Standard (normal 128x128)" + standard) + (const :tag "Thumbnail Managing Standard (large 256x256)" + standard-large) + (const :tag "Thumbnail Managing Standard (larger 512x512)" + standard-x-large) + (const :tag "Thumbnail Managing Standard (extra large 1024x1024)" + standard-xx-large) + (const :tag "Per-directory" per-directory)) + :version "29.1") + +(defconst image-dired--thumbnail-standard-sizes + '( standard standard-large + standard-x-large standard-xx-large) + "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.") + +(defcustom image-dired-db-file + (expand-file-name ".image-dired_db" image-dired-dir) + "Database file where file names and their associated tags are stored." + :type 'file) + +(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'." + :type 'file + :version "29.1") + +(defcustom image-dired-cmd-create-thumbnail-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-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'. +Available format specifiers are: %w which is replaced by +`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height', +%f which is replaced by the file name of the original image and %t +which is replaced by the file name of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-pngnq-program + ;; Prefer pngquant to pngnq-s9 as it is faster on my machine. + ;; The project also seems more active than the alternatives. + ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq. + ;; The pngnq project seems dead (?) since 2011 or so. + (or (executable-find "pngquant") + (executable-find "pngnq-s9") + (executable-find "pngnq")) + "The 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" + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngnq-options + (if (executable-find "pngquant") + '("--ext" "-nq8.png" "%t") ; same extension as "pngnq" + '("-f" "%t")) + "Arguments to pass `image-dired-cmd-pngnq-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options'." + :type '(repeat (string :tag "Argument")) + :version "29.1") + +(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush") + "The file name of the `pngcrush' program. +It optimizes the compression of PNG images. Also it adds PNG textual chunks +with the information required by the Thumbnail Managing Standard." + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngcrush-options + `("-q" + "-text" "b" "Description" "Thumbnail of file://%f" + "-text" "b" "Software" ,(emacs-version) + ;; "-text b \"Thumb::Image::Height\" \"%oh\" " + ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" " + ;; "-text b \"Thumb::Image::Width\" \"%ow\" " + "-text" "b" "Thumb::MTime" "%m" + ;; "-text b \"Thumb::Size\" \"%b\" " + "-text" "b" "Thumb::URI" "file://%f" + "%q" "%t") + "Arguments for `image-dired-cmd-pngcrush-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %q for a +temporary file name (typically generated by pnqnq)." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-optipng-program (executable-find "optipng") + "The 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'. +Available format specifiers are described in +`image-dired-cmd-create-thumbnail-options'." + :version "26.1" + :type '(repeat (string :tag "Argument")) + :link '(url-link "man:optipng(1)")) + +(defcustom image-dired-cmd-create-standard-thumbnail-options + (append '("-size" "%wx%h" "%f[0]") + (unless (or image-dired-cmd-pngcrush-program + image-dired-cmd-pngnq-program) + (list + "-set" "Thumb::MTime" "%m" + "-set" "Thumb::URI" "file://%f" + "-set" "Description" "Thumbnail of file://%f" + "-set" "Software" (emacs-version))) + '("-thumbnail" "%wx%h>" "png:%t")) + "Options for creating thumbnails according to the Thumbnail Managing Standard. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %m for file modification time." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-rotate-original-program + "jpegtran" + "Executable used to rotate original image. +Used together with `image-dired-cmd-rotate-original-options'." + :type 'file) + +(defcustom image-dired-cmd-rotate-original-options + '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o") + "Arguments of command used to rotate original image. +Used with `image-dired-cmd-rotate-original-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or +270 \(for 90 degrees right and left), %o which is replaced by the +original image file name and %t which is replaced by +`image-dired-temp-image-file'." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-temp-rotate-image-file + (expand-file-name ".image-dired_rotate_temp" image-dired-dir) + "Temporary file for rotate operations." + :type 'file) + +(defcustom image-dired-rotate-original-ask-before-overwrite t + "Confirm overwrite of original file after rotate operation. +If non-nil, ask user for confirmation before overwriting the +original file with `image-dired-temp-rotate-image-file'." + :type 'boolean) + +(defcustom image-dired-cmd-write-exif-data-program + "exiftool" + "Program used to write EXIF data to image. +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. +Used with `image-dired-cmd-write-exif-data-program'. +Available format specifiers are: %f which is replaced by +the image file name, %t which is replaced by the tag name and %v +which is replaced by the tag value." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-thumb-size + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t 100)) + "Size of thumbnails, in pixels. +This is the default size for both `image-dired-thumb-width' +and `image-dired-thumb-height'. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; the standard +sizes will be used instead. See `image-dired-thumbnail-storage'." + :type 'integer) + +(defcustom image-dired-thumb-width image-dired-thumb-size + "Width of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-height image-dired-thumb-size + "Height of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-relief 2 + "Size of button-like border around thumbnails." + :type 'integer) + +(defcustom image-dired-thumb-margin 2 + "Size of the margin around thumbnails. +This is where you see the cursor." + :type 'integer) + +(defcustom image-dired-thumb-visible-marks t + "Make marks and flags visible in thumbnail buffer. +If non-nil, apply the `image-dired-thumb-mark' face to marked +images and `image-dired-thumb-flagged' to images flagged for +deletion." + :type 'boolean + :version "28.1") + +(defface image-dired-thumb-mark + '((((class color) (min-colors 16)) :background "DarkOrange") + (((class color)) :foreground "yellow")) + "Face for marked images in thumbnail buffer." + :version "29.1") + +(defface image-dired-thumb-flagged + '((((class color) (min-colors 88) (background light)) :background "Red3") + (((class color) (min-colors 88) (background dark)) :background "Pink") + (((class color) (min-colors 16) (background light)) :background "Red3") + (((class color) (min-colors 16) (background dark)) :background "Pink") + (((class color) (min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for images flagged for deletion in thumbnail buffer." + :version "29.1") + +(defcustom image-dired-line-up-method 'dynamic + "Default method for line-up of thumbnails in thumbnail buffer. +Used by `image-dired-display-thumbs' and other functions that needs +to line-up thumbnails. Dynamic means to use the available width of +the window containing the thumbnail buffer, Fixed means to use +`image-dired-thumbs-per-row', Interactive is for asking the user, +and No line-up means that no automatic line-up will be done." + :type '(choice :tag "Default line-up method" + (const :tag "Dynamic" dynamic) + (const :tag "Fixed" fixed) + (const :tag "Interactive" interactive) + (const :tag "No line-up" none))) + +(defcustom image-dired-thumbs-per-row 3 + "Number of thumbnails to display per row in thumb buffer." + :type 'integer) + +(defcustom image-dired-track-movement t + "The current state of the tracking and mirroring. +For more information, see the documentation for +`image-dired-toggle-movement-tracking'." + :type 'boolean) + +(defcustom image-dired-append-when-browsing nil + "Append thumbnails in thumbnail buffer when browsing. +If non-nil, using `image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' will leave a trail of thumbnail +images in the thumbnail buffer. If you enable this and want to clean +the thumbnail buffer because it is filled with too many thumbnails, +just call `image-dired-display-thumb' to display only the image at point. +This value can be toggled using `image-dired-toggle-append-browsing'." + :type 'boolean) + +(defcustom image-dired-dired-disp-props t + "If non-nil, display properties for Dired file when browsing. +Used by `image-dired-next-line-and-display', +`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'. +If the database file is large, this can slow down image browsing in +Dired and you might want to turn it off." + :type 'boolean) + +(defcustom image-dired-display-properties-format "%b: %f (%t): %c" + "Display format for thumbnail properties. +%b is replaced with associated Dired buffer name, %f with file +name (without path) of original image file, %t with the list of +tags and %c with the comment." + :type 'string) + +(defcustom image-dired-external-viewer + ;; TODO: Use mailcap, dired-guess-shell-alist-default, + ;; dired-view-command-alist. + (cond ((executable-find "display")) + ((executable-find "xli")) + ((executable-find "qiv") "qiv -t") + ((executable-find "feh") "feh")) + "Name of external viewer. +Including parameters. Used when displaying original image from +`image-dired-thumbnail-mode'." + :version "28.1" + :type '(choice string + (const :tag "Not Set" nil))) + +(defcustom image-dired-main-image-directory + (or (xdg-user-dir "PICTURES") "~/pics/") + "Name of main image directory, if any. +Used by `image-dired-copy-with-exif-file-name'." + :type 'string + :version "29.1") + +(defcustom image-dired-show-all-from-dir-max-files 500 + "Maximum number of files in directory before prompting. + +If there are more image files than this in a selected directory, +the `image-dired-show-all-from-dir' command will ask for +confirmation before creating the thumbnail buffer. If this +variable is nil, it will never ask." + :type '(choice integer + (const :tag "Disable warning" nil)) + :version "29.1") + +(defcustom image-dired-marking-shows-next t + "If non-nil, marking, unmarking or flagging an image shows the next image. + +This affects the following commands: +\\ + `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file]) + `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file]) + `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])" + :type 'boolean + :version "29.1") + + +;;; Util functions + +(defvar image-dired-debug nil + "Non-nil means enable debug messages.") + +(defun image-dired-debug-message (&rest args) + "Display debug message ARGS when `image-dired-debug' is non-nil." + (when image-dired-debug + (apply #'message args))) + +(defmacro image-dired--with-db-file (&rest body) + "Run BODY in a temp buffer containing `image-dired-db-file'. +Return the last form in BODY." + (declare (indent 0) (debug t)) + `(with-temp-buffer + (if (file-exists-p image-dired-db-file) + (insert-file-contents image-dired-db-file)) + ,@body)) + +(defun image-dired-dir () + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." + (let ((image-dired-dir (file-name-as-directory + (expand-file-name image-dired-dir)))) + (unless (file-directory-p image-dired-dir) + (with-file-modes #o700 + (make-directory image-dired-dir t)) + (message "Thumbnail directory created: %s" image-dired-dir)) + image-dired-dir)) + +(defun image-dired-insert-image (file type relief margin) + "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point." + (let ((i `(image :type ,type + :file ,file + :relief ,relief + :margin ,margin))) + (insert-image i))) + +(defun image-dired-get-thumbnail-image (file) + "Return the image descriptor for a thumbnail of image file FILE." + (unless (string-match-p (image-file-name-regexp) file) + (error "%s is not a valid image file" file)) + (let* ((thumb-file (image-dired-thumb-name file)) + (thumb-attr (file-attributes thumb-file))) + (when (or (not thumb-attr) + (time-less-p (file-attribute-modification-time thumb-attr) + (file-attribute-modification-time + (file-attributes file)))) + (image-dired-create-thumb file thumb-file)) + (create-image thumb-file))) + +(defun image-dired-insert-thumbnail (file original-file-name + associated-dired-buffer) + "Insert thumbnail image FILE. +Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." + (let (beg end) + (setq beg (point)) + (image-dired-insert-image + file + ;; Thumbnails are created asynchronously, so we might not yet + ;; have a file. But if it exists, it might have been cached from + ;; before and we should use it instead of our current settings. + (or (and (file-exists-p file) + (image-type-from-file-header file)) + (and (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + 'png) + 'jpeg) + image-dired-thumb-relief + image-dired-thumb-margin) + (setq end (point)) + (add-text-properties + beg end + (list 'image-dired-thumbnail t + 'original-file-name original-file-name + 'associated-dired-buffer associated-dired-buffer + 'tags (image-dired-list-tags original-file-name) + 'mouse-face 'highlight + 'comment (image-dired-get-comment original-file-name))))) + +(defun image-dired-thumb-name (file) + "Return absolute file name for thumbnail FILE. +Depending on the value of `image-dired-thumbnail-storage', the +file name of the thumbnail will vary: +- For `use-image-dired-dir', make a SHA1-hash of the image file's + directory name and add that to make the thumbnail file name + unique. +- For `per-directory' storage, just add a subdirectory. +- For `standard' storage, produce the file name according to the + Thumbnail Managing Standard. Among other things, an MD5-hash + of the image file's directory name will be added to the + filename. +See also `image-dired-thumbnail-storage'." + (cond ((memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + (let ((thumbdir (cl-case image-dired-thumbnail-storage + (standard "thumbnails/normal") + (standard-large "thumbnails/large") + (standard-x-large "thumbnails/x-large") + (standard-xx-large "thumbnails/xx-large")))) + (expand-file-name + ;; MD5 is mandated by the Thumbnail Managing Standard. + (concat (md5 (concat "file://" (expand-file-name file))) ".png") + (expand-file-name thumbdir (xdg-cache-home))))) + ((eq 'use-image-dired-dir image-dired-thumbnail-storage) + (let* ((f (expand-file-name file)) + (hash + (md5 (file-name-as-directory (file-name-directory f))))) + (format "%s%s%s.thumb.%s" + (file-name-as-directory (expand-file-name (image-dired-dir))) + (file-name-base f) + (if hash (concat "_" hash) "") + (file-name-extension f)))) + ((eq 'per-directory image-dired-thumbnail-storage) + (let ((f (expand-file-name file))) + (format "%s.image-dired/%s.thumb.%s" + (file-name-directory f) + (file-name-base f) + (file-name-extension f)))))) + +(defun image-dired--check-executable-exists (executable) + (unless (executable-find (symbol-value executable)) + (error "Executable %S not found" executable))) + + +;;; Creating thumbnails + +(defun image-dired-thumb-size (dimension) + "Return thumb size depending on `image-dired-thumbnail-storage'. +DIMENSION should be either the symbol `width' or `height'." + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t (cl-ecase dimension + (width image-dired-thumb-width) + (height image-dired-thumb-height))))) + +(defvar image-dired--generate-thumbs-start nil + "Time when `display-thumbs' was called.") + +(defvar image-dired-queue nil + "List of items in the queue. +Each item has the form (ORIGINAL-FILE TARGET-FILE).") + +(defvar image-dired-queue-active-jobs 0 + "Number of active jobs in `image-dired-queue'.") + +(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2))) + "Maximum number of concurrent jobs permitted for generating images. +Increase at 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 `image-clear-cache' +and remove the cached thumbnail files between each trial run.") + +(defun image-dired-pngnq-thumb (spec) + "Quantize thumbnail described by format SPEC with pngnq(1)." + (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) + (lambda (process status) + (if (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + ;; Pass off to pngcrush, or just rename the + ;; THUMB-nq8.png file back to THUMB.png + (if (and image-dired-cmd-pngcrush-program + (executable-find image-dired-cmd-pngcrush-program)) + (image-dired-pngcrush-thumb spec) + (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)) + +(defun image-dired-pngcrush-thumb (spec) + "Optimize thumbnail described by format SPEC with pngcrush(1)." + ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist. + ;; pngcrush needs an infile and outfile, so we just copy THUMB to + ;; THUMB-nq8.png and use the latter as a temp file. + (when (not image-dired-cmd-pngnq-program) + (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)) + +(defun image-dired-optipng-thumb (spec) + "Optimize thumbnail described by format SPEC with optipng(1)." + (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)) + +(defun image-dired-create-thumb-1 (original-file thumbnail-file) + "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE." + (image-dired--check-executable-exists + 'image-dired-cmd-create-thumbnail-program) + (let* ((width (int-to-string (image-dired-thumb-size 'width))) + (height (int-to-string (image-dired-thumb-size 'height))) + (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 + (list + (cons ?w width) + (cons ?h height) + (cons ?m modif-time) + (cons ?f original-file) + (cons ?q thumbnail-nq8-file) + (cons ?t thumbnail-file))) + (thumbnail-dir (file-name-directory thumbnail-file)) + process) + (when (not (file-exists-p thumbnail-dir)) + (with-file-modes #o700 + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) + + ;; Thumbnail file creation processes begin here and are marshaled + ;; in a queue by `image-dired-create-thumb'. + (setq process + (apply #'start-process "image-dired-create-thumbnail" nil + image-dired-cmd-create-thumbnail-program + (mapcar + (lambda (arg) (format-spec arg spec)) + (if (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + image-dired-cmd-create-standard-thumbnail-options + image-dired-cmd-create-thumbnail-options)))) + + (setf (process-sentinel process) + (lambda (process status) + ;; Trigger next in queue once a thumbnail has been created + (cl-decf image-dired-queue-active-jobs) + (image-dired-thumb-queue-run) + (when (= image-dired-queue-active-jobs 0) + (image-dired-debug-message + (format-time-string + "Generated thumbnails in %s.%3N seconds" + (time-subtract nil + image-dired--generate-thumbs-start)))) + (if (not (and (eq (process-status process) 'exit) + (zerop (process-exit-status process)))) + (message "Thumb could not be created for %s: %s" + (abbreviate-file-name original-file) + (string-replace "\n" "" status)) + (set-file-modes thumbnail-file #o600) + (clear-image-cache thumbnail-file) + ;; 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) + (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))))))) + process)) + +(defun image-dired-thumb-queue-run () + "Run a queued job if one exists and not too many jobs are running. +Queued items live in `image-dired-queue'." + (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)))) + +(defun image-dired-create-thumb (original-file thumbnail-file) + "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'. +The new file will be named THUMBNAIL-FILE." + (setq image-dired-queue + (nconc image-dired-queue + (list (list original-file thumbnail-file)))) + (run-at-time 0 nil #'image-dired-thumb-queue-run)) + +(defmacro image-dired--with-marked (&rest body) + "Eval BODY with point on each marked thumbnail. +If no marked file could be found, execute BODY on the current +thumbnail." + `(with-current-buffer image-dired-thumbnail-buffer + (let (found) + (save-mark-and-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (image-dired-thumb-file-marked-p) + (setq found t) + ,@body) + (forward-char))) + (unless found + ,@body)))) + +;;;###autoload +(defun image-dired-dired-toggle-marked-thumbs (&optional arg) + "Toggle thumbnails in front of file names in the Dired buffer. +If no marked file could be found, insert or hide thumbnails on the +current line. ARG, if non-nil, specifies the files to use instead +of the marked files. If ARG is an integer, use the next ARG (or +previous -ARG, if ARG<0) files." + (interactive "P") + (dired-map-over-marks + (let ((image-pos (dired-move-to-filename)) + (image-file (dired-get-filename nil t)) + thumb-file + overlay) + (when (and image-file + (string-match-p (image-file-name-regexp) image-file)) + (setq thumb-file (image-dired-get-thumbnail-image image-file)) + ;; If image is not already added, then add it. + (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'thumb-file) return ov))) + (if thumb-ov + (delete-overlay thumb-ov) + (put-image thumb-file image-pos) + (setq overlay + (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'put-image) return ov)) + (overlay-put overlay 'image-file image-file) + (overlay-put overlay 'thumb-file thumb-file))))) + arg ; Show or hide image on ARG next files. + 'show-progress) ; Update dired display after each image is updated. + (add-hook 'dired-after-readin-hook + 'image-dired-dired-after-readin-hook nil t)) + +(defun image-dired-dired-after-readin-hook () + "Relocate existing thumbnail overlays in Dired buffer after reverting. +Move them to their corresponding files if they still exist. +Otherwise, delete overlays." + (mapc (lambda (overlay) + (when (overlay-get overlay 'put-image) + (let* ((image-file (overlay-get overlay 'image-file)) + (image-pos (dired-goto-file image-file))) + (if image-pos + (move-overlay overlay image-pos image-pos) + (delete-overlay overlay))))) + (overlays-in (point-min) (point-max)))) + +(defun image-dired-next-line-and-display () + "Move to next Dired line and display thumbnail image." + (interactive) + (dired-next-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-previous-line-and-display () + "Move to previous Dired line and display thumbnail image." + (interactive) + (dired-previous-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-append-browsing () + "Toggle `image-dired-append-when-browsing'." + (interactive) + (setq image-dired-append-when-browsing + (not image-dired-append-when-browsing)) + (message "Append browsing %s" + (if image-dired-append-when-browsing + "on" + "off"))) + +(defun image-dired-mark-and-display-next () + "Mark current file in Dired and display next thumbnail image." + (interactive) + (dired-mark 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-dired-display-properties () + "Toggle `image-dired-dired-disp-props'." + (interactive) + (setq image-dired-dired-disp-props + (not image-dired-dired-disp-props)) + (message "Dired display properties %s" + (if image-dired-dired-disp-props + "on" + "off"))) + +(defvar image-dired-thumbnail-buffer "*image-dired*" + "Image-Dired's thumbnail buffer.") + +(defun image-dired-create-thumbnail-buffer () + "Create thumb buffer and set `image-dired-thumbnail-mode'." + (let ((buf (get-buffer-create image-dired-thumbnail-buffer))) + (with-current-buffer buf + (setq buffer-read-only t) + (if (not (eq major-mode 'image-dired-thumbnail-mode)) + (image-dired-thumbnail-mode))) + buf)) + +(defvar image-dired-display-image-buffer "*image-dired-display-image*" + "Where larger versions of the images are display.") + +(defvar image-dired-saved-window-configuration nil + "Saved window configuration.") + +;;;###autoload +(defun image-dired-dired-with-window-configuration (dir &optional arg) + "Open directory DIR and create a default window configuration. + +Convenience command that: + + - Opens Dired in folder DIR + - Splits windows in most useful (?) way + - Sets `truncate-lines' to t + +After the command has finished, you would typically mark some +image files in Dired and type +\\[image-dired-display-thumbs] (`image-dired-display-thumbs'). + +If called with prefix argument ARG, skip splitting of windows. + +The current window configuration is saved and can be restored by +calling `image-dired-restore-window-configuration'." + (interactive "DDirectory: \nP") + (let ((buf (image-dired-create-thumbnail-buffer)) + (buf2 (get-buffer-create image-dired-display-image-buffer))) + (setq image-dired-saved-window-configuration + (current-window-configuration)) + (dired dir) + (delete-other-windows) + (when (not arg) + (split-window-right) + (setq truncate-lines t) + (save-excursion + (other-window 1) + (pop-to-buffer-same-window buf) + (select-window (split-window-below)) + (pop-to-buffer-same-window buf2) + (other-window -2))))) + +(defun image-dired-restore-window-configuration () + "Restore window configuration. +Restore any changes to the window configuration made by calling +`image-dired-dired-with-window-configuration'." + (interactive nil image-dired-thumbnail-mode) + (if image-dired-saved-window-configuration + (set-window-configuration image-dired-saved-window-configuration) + (message "No saved window configuration"))) + +(defun image-dired--line-up-with-method () + "Line up thumbnails according to `image-dired-line-up-method'." + (cond ((eq 'dynamic image-dired-line-up-method) + (image-dired-line-up-dynamic)) + ((eq 'fixed image-dired-line-up-method) + (image-dired-line-up)) + ((eq 'interactive image-dired-line-up-method) + (image-dired-line-up-interactive)) + ((eq 'none image-dired-line-up-method) + nil) + (t + (image-dired-line-up-dynamic)))) + +;;;###autoload +(defun image-dired-display-thumbs (&optional arg append do-not-pop) + "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'. +If a thumbnail image does not exist for a file, it is created on the +fly. With prefix argument ARG, display only thumbnail for file at +point (this is useful if you have marked some files but want to show +another one). + +Recommended usage is to split the current frame horizontally so that +you have the Dired buffer in the left window and the +`image-dired-thumbnail-buffer' buffer in the right window. + +With optional argument APPEND, append thumbnail to thumbnail buffer +instead of erasing it first. + +Optional argument DO-NOT-POP controls if `pop-to-buffer' should be +used or not. If non-nil, use `display-buffer' instead of +`pop-to-buffer'. This is used from functions like +`image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' where we do not want the +thumbnail buffer to be selected." + (interactive "P") + (setq image-dired--generate-thumbs-start (current-time)) + (let ((buf (image-dired-create-thumbnail-buffer)) + thumb-name files dired-buf) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (setq dired-buf (current-buffer)) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (if (not append) + (erase-buffer) + (goto-char (point-max))) + (dolist (curr-file files) + (setq thumb-name (image-dired-thumb-name curr-file)) + (when (not (file-exists-p thumb-name)) + (image-dired-create-thumb curr-file thumb-name)) + (image-dired-insert-thumbnail thumb-name curr-file dired-buf))) + (if do-not-pop + (display-buffer buf) + (pop-to-buffer buf)) + (image-dired--line-up-with-method)))) + +;;;###autoload +(defun image-dired-show-all-from-dir (dir) + "Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation." + (interactive "DImage-Dired: ") + (dired dir) + (dired-mark-files-regexp (image-file-name-regexp)) + (let ((files (dired-get-marked-files nil nil nil t))) + (cond ((and (null (cdr files))) + (message "No image files in directory")) + ((or (not image-dired-show-all-from-dir-max-files) + (<= (length (cdr files)) image-dired-show-all-from-dir-max-files) + (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files) + (y-or-n-p + (format + "Directory contains more than %d image files. Proceed?" + image-dired-show-all-from-dir-max-files)))) + (image-dired-display-thumbs) + (pop-to-buffer image-dired-thumbnail-buffer) + (setq default-directory dir) + (image-dired-unmark-all-marks)) + (t (message "Image-Dired canceled"))))) + +;;;###autoload +(defalias 'image-dired 'image-dired-show-all-from-dir) + + +;;; Tags + +(defun image-dired-sane-db-file () + "Check if `image-dired-db-file' exists. +If not, try to create it (including any parent directories). +Signal error if there are problems creating it." + (or (file-exists-p image-dired-db-file) + (let (dir buf) + (unless (file-directory-p (setq dir (file-name-directory + image-dired-db-file))) + (with-file-modes #o700 + (make-directory dir t))) + (with-current-buffer (setq buf (create-file-buffer + image-dired-db-file)) + (with-file-modes #o600 + (write-file image-dired-db-file))) + (kill-buffer buf) + (file-exists-p image-dired-db-file)) + (error "Could not create %s" image-dired-db-file))) + +(defvar image-dired-tag-history nil "Variable holding the tag history.") + +(defun image-dired-write-tags (file-tags) + "Write file tags to database. +Write each file and tag in FILE-TAGS to the database. +FILE-TAGS is an alist in the following form: + ((FILE . TAG) ... )" + (image-dired-sane-db-file) + (let (end file tag) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-tags) + (setq file (car elt) + tag (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + (when (not (search-forward (format ";%s" tag) end t)) + (end-of-line) + (insert (format ";%s" tag)))) + (goto-char (point-max)) + (insert (format "%s;%s\n" file tag)))) + (save-buffer)))) + +(defun image-dired-remove-tag (files tag) + "For all FILES, remove TAG from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (let (end) + (unless (listp files) + (if (stringp files) + (setq files (list files)) + (error "Files must be a string or a list of strings!"))) + (dolist (file files) + (goto-char (point-min)) + (when (search-forward-regexp (format "^%s;" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward-regexp + (format "\\(;%s\\)\\($\\|;\\)" tag) end t) + (delete-region (match-beginning 1) (match-end 1)) + ;; Check if file should still be in the database. If + ;; it has no tags or comments, it will be removed. + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (not (search-forward ";" end t)) + (kill-line 1)))))) + (save-buffer))) + +(defun image-dired-list-tags (file) + "Read all tags for image FILE from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end (tags "")) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (if (search-forward ";" end t) + (if (search-forward "comment:" end t) + (if (search-forward ";" end t) + (setq tags (buffer-substring (point) end))) + (setq tags (buffer-substring (point) end))))) + (split-string tags ";")))) + +;;;###autoload +(defun image-dired-tag-files (arg) + "Tag marked file(s) in Dired. With prefix ARG, tag file at point." + (interactive "P") + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-write-tags + (mapcar + (lambda (x) + (cons x tag)) + files)))) + +(defun image-dired-tag-thumbnail () + "Tag current or marked thumbnails." + (interactive) + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-write-tags + (list (cons (image-dired-original-file-name) tag))) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + +;;;###autoload +(defun image-dired-delete-tag (arg) + "Remove tag for selected file(s). +With prefix argument ARG, remove tag from file at point." + (interactive "P") + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-remove-tag files tag))) + +(defun image-dired-tag-thumbnail-remove () + "Remove tag from current or marked thumbnails." + (interactive) + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-remove-tag (image-dired-original-file-name) tag) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + + +;;; Thumbnail mode (cont.) + +(defun image-dired-original-file-name () + "Get original file name for thumbnail or display image at point." + (get-text-property (point) 'original-file-name)) + +(defun image-dired-file-name-at-point () + "Get abbreviated file name for thumbnail or display image at point." + (let ((f (image-dired-original-file-name))) + (when f + (abbreviate-file-name f)))) + +(defun image-dired-associated-dired-buffer () + "Get associated Dired buffer at point." + (get-text-property (point) 'associated-dired-buffer)) + +(defun image-dired-get-buffer-window (buf) + "Return window where buffer BUF is." + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)) + nil t)) + +(defun image-dired-track-original-file () + "Track the original file in the associated Dired buffer. +See documentation for `image-dired-toggle-movement-tracking'. +Interactive use only useful if `image-dired-track-movement' is nil." + (interactive) + (let* ((dired-buf (image-dired-associated-dired-buffer)) + (file-name (image-dired-original-file-name)) + (window (image-dired-get-buffer-window dired-buf))) + (and (buffer-live-p dired-buf) file-name + (with-current-buffer dired-buf + (if (not (dired-goto-file file-name)) + (message "Could not track file") + (if window (set-window-point window (point)))))))) + +(defun image-dired-toggle-movement-tracking () + "Turn on and off `image-dired-track-movement'. +Tracking of the movements between thumbnail and Dired buffer so that +they are \"mirrored\" in the dired buffer. When this is on, moving +around in the thumbnail or dired buffer will find the matching +position in the other buffer." + (interactive) + (setq image-dired-track-movement (not image-dired-track-movement)) + (message "Movement tracking %s" (if image-dired-track-movement "on" "off"))) + +(defun image-dired-track-thumbnail () + "Track current Dired file's thumb in `image-dired-thumbnail-buffer'. +This is almost the same as what `image-dired-track-original-file' does, +but the other way around." + (let ((file (dired-get-filename)) + prop-val found window) + (when (get-buffer image-dired-thumbnail-buffer) + (with-current-buffer image-dired-thumbnail-buffer + (goto-char (point-min)) + (while (and (not (eobp)) + (not found)) + (if (and (setq prop-val + (get-text-property (point) 'original-file-name)) + (string= prop-val file)) + (setq found t)) + (if (not found) + (forward-char 1))) + (when found + (if (setq window (image-dired-thumbnail-window)) + (set-window-point window (point))) + (image-dired-update-header-line)))))) + +(defun image-dired-dired-next-line (&optional arg) + "Call `dired-next-line', then track thumbnail. +This can safely replace `dired-next-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-next-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired-dired-previous-line (&optional arg) + "Call `dired-previous-line', then track thumbnail. +This can safely replace `dired-previous-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-previous-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired--display-thumb-properties-fun () + (let ((old-buf (current-buffer)) + (old-point (point))) + (lambda () + (when (and (equal (current-buffer) old-buf) + (= (point) old-point)) + (ignore-errors + (image-dired-update-header-line)))))) + +(defun image-dired-forward-image (&optional arg wrap-around) + "Move to next image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move backwards. +On reaching end or beginning of buffer, stop and show a message. + +If optional argument WRAP-AROUND is non-nil, wrap around: if +point is on the last image, move to the last one and vice versa." + (interactive "p") + (setq arg (or arg 1)) + (let (pos) + (dotimes (_ (abs arg)) + (if (and (not (if (> arg 0) (eobp) (bobp))) + (save-excursion + (forward-char (if (> arg 0) 1 -1)) + (while (and (not (if (> arg 0) (eobp) (bobp))) + (not (image-dired-image-at-point-p))) + (forward-char (if (> arg 0) 1 -1))) + (setq pos (point)) + (image-dired-image-at-point-p))) + (progn (goto-char pos) + (image-dired-update-header-line)) + (if wrap-around + (progn (goto-char (if (> arg 0) + (point-min) + ;; There are two spaces after the last image. + (- (point-max) 2))) + (image-dired-update-header-line)) + (message "At %s image" (if (> arg 0) "last" "first")) + (run-at-time 1 nil (image-dired--display-thumb-properties-fun)))))) + (when image-dired-track-movement + (image-dired-track-original-file))) + +(defun image-dired-backward-image (&optional arg) + "Move to previous image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move forward. +On reaching end or beginning of buffer, stop and show a message." + (interactive "p") + (image-dired-forward-image (- (or arg 1)))) + +(defun image-dired-next-line () + "Move to next line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line 1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next thumbnail. + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + +(defun image-dired-previous-line () + "Move to previous line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line -1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next + ;; thumbnail. This should only happen if the user deleted a + ;; thumbnail and did not refresh, so it is not very common. But we + ;; can handle it in a good manner, so why not? + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-beginning-of-buffer () + "Move to the first image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-min)) + (while (and (not (image-at-point-p)) + (not (eobp))) + (forward-char 1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-end-of-buffer () + "Move to the last image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-max)) + (while (and (not (image-at-point-p)) + (not (bobp))) + (forward-char -1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-format-properties-string (buf file props comment) + "Format display properties. +BUF is the associated Dired buffer, FILE is the original image file +name, PROPS is a stringified list of tags and COMMENT is the image file's +comment." + (format-spec + image-dired-display-properties-format + (list + (cons ?b (or buf "")) + (cons ?f file) + (cons ?t (or props "")) + (cons ?c (or comment ""))))) + +(defun image-dired-update-header-line () + "Update image information in the header line." + (when (and (not (eobp)) + (memq major-mode '(image-dired-thumbnail-mode + image-dired-display-image-mode))) + (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) + (dired-buf (buffer-name (image-dired-associated-dired-buffer))) + (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (comment (get-text-property (point) 'comment)) + (message-log-max nil)) + (if file-name + (setq header-line-format + (image-dired-format-properties-string + dired-buf + file-name + props + comment)))))) + +(defun image-dired-dired-file-marked-p (&optional marker) + "In Dired, return t if file on current line is marked. +If optional argument MARKER is non-nil, it is a character to look +for. The default is to look for `dired-marker-char'." + (setq marker (or marker dired-marker-char)) + (save-excursion + (beginning-of-line) + (and (looking-at dired-re-mark) + (= (aref (match-string 0) 0) marker)))) + +(defun image-dired-dired-file-flagged-p () + "In Dired, return t if file on current line is flagged for deletion." + (image-dired-dired-file-marked-p dired-del-marker)) + +(defmacro image-dired--with-thumbnail-buffer (&rest body) + (declare (indent defun) (debug t)) + `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (if-let ((win (get-buffer-window buf))) + (with-selected-window win + ,@body) + ,@body)) + (user-error "No such buffer: %s" image-dired-thumbnail-buffer))) + +(defmacro image-dired--on-file-in-dired-buffer (&rest body) + "Run BODY with point on file at point in Dired buffer. +Should be called from commands in `image-dired-thumbnail-mode'." + (declare (indent defun) (debug t)) + `(let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + ,@body + (image-dired-thumb-update-marks)))))) + +(defmacro image-dired--do-mark-command (maybe-next &rest body) + "Helper macro for the mark, unmark and flag commands. +Run BODY in Dired buffer. +If optional argument MAYBE-NEXT is non-nil, show next image +according to `image-dired-marking-shows-next'." + (declare (indent defun) (debug t)) + `(image-dired--with-thumbnail-buffer + (image-dired--on-file-in-dired-buffer + ,@body) + ,(when maybe-next + '(if image-dired-marking-shows-next + (image-dired-display-next-thumbnail-original) + (image-dired-next-line))))) + +(defun image-dired-mark-thumb-original-file () + "Mark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-mark 1))) + +(defun image-dired-unmark-thumb-original-file () + "Unmark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-unmark 1))) + +(defun image-dired-flag-thumb-original-file () + "Flag original image file for deletion in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-flag-file-deletion 1))) + +(defun image-dired-toggle-mark-thumb-original-file () + "Toggle mark on original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1)))) + +(defun image-dired-unmark-all-marks () + "Remove all marks from all files in associated Dired buffer. +Also update the marks in the thumbnail buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (dired-unmark-all-marks)) + (image-dired--with-thumbnail-buffer + (image-dired-thumb-update-marks))) + +(defun image-dired-jump-original-dired-buffer () + "Jump to the Dired buffer associated with the current image file. +You probably want to use this together with +`image-dired-track-original-file'." + (interactive nil image-dired-thumbnail-mode) + (let ((buf (image-dired-associated-dired-buffer)) + window frame) + (setq window (image-dired-get-buffer-window buf)) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Associated dired buffer not visible")))) + +;;;###autoload +(defun image-dired-jump-thumbnail-buffer () + "Jump to thumbnail buffer." + (interactive) + (let ((window (image-dired-thumbnail-window)) + frame) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Thumbnail buffer not visible")))) + +(defvar image-dired-thumbnail-mode-line-up-map + (let ((map (make-sparse-keymap))) + ;; map it to "g" so that the user can press it more quickly + (define-key map "g" #'image-dired-line-up-dynamic) + ;; "f" for "fixed" number of thumbs per row + (define-key map "f" #'image-dired-line-up) + ;; "i" for "interactive" + (define-key map "i" #'image-dired-line-up-interactive) + map) + "Keymap for line-up commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-tag-map + (let ((map (make-sparse-keymap))) + ;; map it to "t" so that the user can press it more quickly + (define-key map "t" #'image-dired-tag-thumbnail) + ;; "r" for "remove" + (define-key map "r" #'image-dired-tag-thumbnail-remove) + map) + "Keymap for tag commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) + + (define-key map "<" #'image-dired-beginning-of-buffer) + (define-key map ">" #'image-dired-end-of-buffer) + (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) + (define-key map (kbd "M->") #'image-dired-end-of-buffer) + + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) + + ;; add line-up map + (define-key map "g" image-dired-thumbnail-mode-line-up-map) + ;; add tag map + (define-key map "t" image-dired-thumbnail-mode-tag-map) + + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) + + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) + + (define-key map "D" #'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) + + ;; Mouse + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail) + ;; Seems I must first set C-down-mouse-1 to undefined, or else it + ;; will trigger the buffer menu. If I try to instead bind + ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message + ;; about C-mouse-1 not being defined afterwards. Annoying, but I + ;; probably do not completely understand mouse events. + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) + map) + "Keymap for `image-dired-thumbnail-mode'.") + +(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map + "Menu for `image-dired-thumbnail-mode'." + '("Image-Dired" + ["Display image" image-dired-display-thumbnail-original-image] + ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] + "---" + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] + "---" + ["Rotate original right" image-dired-rotate-original-right] + ["Rotate original left" image-dired-rotate-original-left] + "---" + ["Comment thumbnail" image-dired-comment-thumbnail] + ["Tag current or marked thumbnails" image-dired-tag-thumbnail] + ["Remove tag from current or marked thumbnails" + image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] + "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) + ["Quit" quit-window])) + +(defvar image-dired-display-image-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "n" #'image-dired-display-next-thumbnail-original) + (define-key map "p" #'image-dired-display-previous-thumbnail-original) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + ;; Disable keybindings from `image-mode-map' that doesn't make sense here. + (define-key map "o" nil) ; image-save + map) + "Keymap for `image-dired-display-image-mode'.") + +(define-derived-mode image-dired-thumbnail-mode + special-mode "image-dired-thumbnail" + "Browse and manipulate thumbnail images using Dired. +Use `image-dired-minor-mode' to get a nice setup." + :interactive nil + (buffer-disable-undo) + (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) + (setq-local window-resize-pixelwise t) + (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record) + ;; Use approximately as much vertical spacing as horizontal. + (setq-local line-spacing (frame-char-width))) + + +;;; Display image mode + +(define-derived-mode image-dired-display-image-mode + image-mode "image-dired-image-display" + "Mode for displaying and manipulating original image. +Resized or in full-size." + :interactive nil + (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t)) + +(defvar image-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + ;; (set-keymap-parent map dired-mode-map) + ;; Hijack previous and next line movement. Let C-p and C-b be + ;; though... + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) + map) + "Keymap for `image-dired-minor-mode'.") + +(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map + "Menu for `image-dired-minor-mode'." + '("Image-dired" + ["Display thumb for next file" image-dired-next-line-and-display] + ["Display thumb for previous file" image-dired-previous-line-and-display] + ["Mark and display next" image-dired-mark-and-display-next] + "---" + ["Create thumbnails for marked files" image-dired-create-thumbs] + "---" + ["Display thumbnails append" image-dired-display-thumbs-append] + ["Display this thumbnail" image-dired-display-thumb] + ["Display image" image-dired-dired-display-image] + ["Display in external viewer" image-dired-dired-display-external] + "---" + ["Toggle display properties" image-dired-toggle-dired-display-properties + :style toggle + :selected image-dired-dired-disp-props] + ["Toggle append browsing" image-dired-toggle-append-browsing + :style toggle + :selected image-dired-append-when-browsing] + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] + ["Mark tagged files" image-dired-mark-tagged-files] + ["Comment files" image-dired-dired-comment-files] + ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + +;;;###autoload +(define-minor-mode image-dired-minor-mode + "Setup easy-to-use keybindings for the commands to be used in Dired mode. +Note that n, p and and will be hijacked and bound to +`image-dired-dired-next-line' and `image-dired-dired-previous-line'." + :keymap image-dired-minor-mode-map) + +(declare-function clear-image-cache "image.c" (&optional filter)) + +(defun image-dired-create-thumbs (&optional arg) + "Create thumbnail images for all marked files in Dired. +With prefix argument ARG, create thumbnails even if they already exist +\(i.e. use this to refresh your thumbnails)." + (interactive "P") + (let (thumb-name) + (dolist (curr-file (dired-get-marked-files)) + (setq thumb-name (image-dired-thumb-name curr-file)) + ;; If the user overrides the exist check, we must clear the + ;; image cache so that if the user wants to display the + ;; thumbnail, it is not fetched from cache. + (when arg + (clear-image-cache (expand-file-name thumb-name))) + (when (or (not (file-exists-p thumb-name)) + arg) + (image-dired-create-thumb curr-file thumb-name))))) + + +;;; Slideshow + +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") + +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") + +(defvar image-dired--slideshow-initial nil) + +(defun image-dired-slideshow-step () + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) + (image-dired-slideshow-stop))) + +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow, waiting `image-dired-slideshow-delay' between images. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (not arg) + image-dired-slideshow-delay + (if (> arg 0) + arg + (string-to-number + (let ((delay (number-to-string image-dired-slideshow-delay))) + (read-string + (format-prompt "Delay, in seconds. Decimals are accepted" delay)) + delay)))))) + (setq image-dired--slideshow-timer + (run-with-timer + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) + +(defun image-dired-slideshow-stop () + "Cancel slideshow." + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) + + +;;; Thumbnail mode (cont. 3) + +(defun image-dired-delete-char () + "Remove current thumbnail from thumbnail buffer and line up." + (interactive nil image-dired-thumbnail-mode) + (let ((inhibit-read-only t)) + (delete-char 1) + (when (= (following-char) ?\s) + (delete-char 1)))) + +;;;###autoload +(defun image-dired-display-thumbs-append () + "Append thumbnails to `image-dired-thumbnail-buffer'." + (interactive) + (image-dired-display-thumbs nil t t)) + +;;;###autoload +(defun image-dired-display-thumb () + "Shorthand for `image-dired-display-thumbs' with prefix argument." + (interactive) + (image-dired-display-thumbs t nil t)) + +(defun image-dired-line-up () + "Line up thumbnails according to `image-dired-thumbs-per-row'. +See also `image-dired-line-up-dynamic'." + (interactive) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1)) + (while (not (eobp)) + (forward-char) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1))) + (goto-char (point-min)) + (let ((seen 0) + (thumb-prev-pos 0) + (thumb-width-chars + (ceiling (/ (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width)) + (float (frame-char-width)))))) + (while (not (eobp)) + (forward-char) + (if (= image-dired-thumbs-per-row 1) + (insert "\n") + (cl-incf thumb-prev-pos thumb-width-chars) + (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos))) + (cl-incf seen) + (when (and (= seen (- image-dired-thumbs-per-row 1)) + (not (eobp))) + (forward-char) + (insert "\n") + (setq seen 0) + (setq thumb-prev-pos 0))))) + (goto-char (point-min)))) + +(defun image-dired-line-up-dynamic () + "Line up thumbnails images dynamically. +Calculate how many thumbnails fit." + (interactive) + (let* ((char-width (frame-char-width)) + (width (image-dired-window-width-pixels (image-dired-thumbnail-window))) + (image-dired-thumbs-per-row + (/ width + (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width) + char-width)))) + (image-dired-line-up))) + +(defun image-dired-line-up-interactive () + "Line up thumbnails interactively. +Ask user how many thumbnails should be displayed per row." + (interactive) + (let ((image-dired-thumbs-per-row + (string-to-number (read-string "How many thumbs per row: ")))) + (if (not (> image-dired-thumbs-per-row 0)) + (message "Number must be greater than 0") + (image-dired-line-up)))) + +(defun image-dired-thumbnail-display-external () + "Display original image for thumbnail at point using external viewer." + (interactive) + (let ((file (image-dired-original-file-name))) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (start-process "image-dired-thumb-external" nil + image-dired-external-viewer file))))) + +;;;###autoload +(defun image-dired-dired-display-external () + "Display file at point using an external viewer." + (interactive) + (let ((file (dired-get-filename))) + (start-process "image-dired-external" nil + image-dired-external-viewer file))) + +(defun image-dired-window-width-pixels (window) + "Calculate WINDOW width in pixels." + (* (window-width window) (frame-char-width))) + +(defun image-dired-display-window () + "Return window where `image-dired-display-image-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer)) + nil t)) + +(defun image-dired-thumbnail-window () + "Return window where `image-dired-thumbnail-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer)) + nil t)) + +(defun image-dired-associated-dired-buffer-window () + "Return window where associated Dired buffer is visible." + (let (buf) + (if (image-dired-image-at-point-p) + (progn + (setq buf (image-dired-associated-dired-buffer)) + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)))) + (error "No thumbnail image at point")))) + +(defun image-dired-display-image (file &optional _ignored) + "Display image FILE in image buffer. +Use this when you want to display the image, in a new window. +The window will use `image-dired-display-image-mode' which is +based on `image-mode'." + (declare (advertised-calling-convention (file) "29.1")) + (setq file (expand-file-name file)) + (when (not (file-exists-p file)) + (error "No such file: %s" file)) + (let ((buf (get-buffer image-dired-display-image-buffer)) + (cur-win (selected-window))) + (when buf + (kill-buffer buf)) + (when-let ((buf (find-file-noselect file nil t))) + (pop-to-buffer buf) + (rename-buffer image-dired-display-image-buffer) + (image-dired-display-image-mode) + (select-window cur-win)))) + +(defun image-dired-display-thumbnail-original-image (&optional arg) + "Display current thumbnail's original image in display buffer. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (let ((file (image-dired-original-file-name))) + (if (not (string-equal major-mode "image-dired-thumbnail-mode")) + (message "Not in image-dired-thumbnail-mode") + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (image-dired-display-image file arg)))))) + + +;;;###autoload +(defun image-dired-dired-display-image (&optional arg) + "Display current image file. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (image-dired-display-image (dired-get-filename) arg)) + +(defun image-dired-image-at-point-p () + "Return non-nil if there is an `image-dired' thumbnail at point." + (get-text-property (point) 'image-dired-thumbnail)) + +(defun image-dired-refresh-thumb () + "Force creation of new image for current thumbnail." + (interactive nil image-dired-thumbnail-mode) + (let* ((file (image-dired-original-file-name)) + (thumb (expand-file-name (image-dired-thumb-name file)))) + (clear-image-cache (expand-file-name thumb)) + (image-dired-create-thumb file thumb))) + +(defun image-dired-rotate-original (degrees) + "Rotate original image DEGREES degrees." + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-original-program) + (if (not (image-dired-image-at-point-p)) + (message "No image at point") + (let* ((file (image-dired-original-file-name)) + (spec + (list + (cons ?d degrees) + (cons ?o (expand-file-name file)) + (cons ?t image-dired-temp-rotate-image-file)))) + (unless (eq 'jpeg (image-type file)) + (user-error "Only JPEG images can be rotated")) + (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program + nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-original-options)))) + (error "Could not rotate image") + (image-dired-display-image image-dired-temp-rotate-image-file) + (if (or (and image-dired-rotate-original-ask-before-overwrite + (y-or-n-p + "Rotate to temp file OK. Overwrite original image? ")) + (not image-dired-rotate-original-ask-before-overwrite)) + (progn + (copy-file image-dired-temp-rotate-image-file file t) + (image-dired-refresh-thumb)) + (image-dired-display-image file)))))) + +(defun image-dired-rotate-original-left () + "Rotate original image left (counter clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "270")) + +(defun image-dired-rotate-original-right () + "Rotate original image right (clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "90")) + + +;;; EXIF support + +(defun image-dired-get-exif-file-name (file) + "Use the image's EXIF information to return a unique file name. +The file name should be unique as long as you do not take more than +one picture per second. The original file name is suffixed at the end +for traceability. The format of the returned file name is +YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from +`image-dired-copy-with-exif-file-name'." + (let (data no-exif-data-found) + (if (not (eq 'jpeg (image-type (expand-file-name file)))) + (setq no-exif-data-found t + data (format-time-string + "%Y:%m:%d %H:%M:%S" + (file-attribute-modification-time + (file-attributes (expand-file-name file))))) + (setq data (exif-field 'date-time (exif-parse-file + (expand-file-name file))))) + (while (string-match "[ :]" data) + (setq data (replace-match "_" nil nil data))) + (format "%s%s%s" data + (if no-exif-data-found + "_noexif_" + "_") + (file-name-nondirectory file)))) + +(defun image-dired-thumbnail-set-image-description () + "Set the ImageDescription EXIF tag for the original image. +If the image already has a value for this tag, it is used as the +default value at the prompt." + (interactive) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-original-file-name)) + (old-value (or (exif-field 'description (exif-parse-file file)) ""))) + (if (eq 0 + (image-dired-set-exif-data file "ImageDescription" + (read-string "Value of ImageDescription: " + old-value))) + (message "Successfully wrote ImageDescription tag") + (error "Could not write ImageDescription tag"))))) + +(defun image-dired-set-exif-data (file tag-name tag-value) + "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE." + (image-dired--check-executable-exists + 'image-dired-cmd-write-exif-data-program) + (let ((spec + (list + (cons ?f (expand-file-name file)) + (cons ?t tag-name) + (cons ?v tag-value)))) + (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-write-exif-data-options)))) + +(defun image-dired-copy-with-exif-file-name () + "Copy file with unique name to main image directory. +Copy current or all marked files in Dired to a new file in your +main image directory, using a file name generated by +`image-dired-get-exif-file-name'. A typical usage for this if when +copying images from a digital camera into the image directory. + + Typically, you would open up the folder with the incoming +digital images, mark the files to be copied, and execute this +function. The result is a couple of new files in +`image-dired-main-image-directory' called +2005_05_08_12_52_00_dscn0319.jpg, +2005_05_08_14_27_45_dscn0320.jpg etc." + (interactive) + (let (new-name + (files (dired-get-marked-files))) + (mapc + (lambda (curr-file) + (setq new-name + (format "%s/%s" + (file-name-as-directory + (expand-file-name image-dired-main-image-directory)) + (image-dired-get-exif-file-name curr-file))) + (message "Copying %s to %s" curr-file new-name) + (copy-file curr-file new-name)) + files))) + +;;; Thumbnail mode (cont.) + +(defun image-dired-display-next-thumbnail-original (&optional arg) + "Move to the next image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--with-thumbnail-buffer + (image-dired-forward-image arg t) + (image-dired-display-thumbnail-original-image))) + +(defun image-dired-display-previous-thumbnail-original (arg) + "Move to the previous image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired-display-next-thumbnail-original (- arg))) + + +;;; Image Comments + +(defun image-dired-write-comments (file-comments) + "Write file comments to database. +Write file comments to one or more files. +FILE-COMMENTS is an alist on the following form: + ((FILE . COMMENT) ... )" + (image-dired-sane-db-file) + (let (end comment-beg-pos comment-end-pos file comment) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-comments) + (setq file (car elt) + comment (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + ;; Delete old comment, if any + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (match-beginning 0)) + ;; Any tags after the comment? + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + ;; Delete comment tag and comment + (delete-region comment-beg-pos comment-end-pos)) + ;; Insert new comment + (beginning-of-line) + (unless (search-forward ";" end t) + (end-of-line) + (insert ";")) + (insert (format "comment:%s;" comment))) + ;; File does not exist in database - add it. + (goto-char (point-max)) + (insert (format "%s;comment:%s\n" file comment)))) + (save-buffer)))) + +(defun image-dired-update-property (prop value) + "Update text property PROP with value VALUE at point." + (let ((inhibit-read-only t)) + (put-text-property + (point) (1+ (point)) + prop + value))) + +;;;###autoload +(defun image-dired-dired-comment-files () + "Add comment to current or marked files in Dired." + (interactive) + (let ((comment (image-dired-read-comment))) + (image-dired-write-comments + (mapcar + (lambda (curr-file) + (cons curr-file comment)) + (dired-get-marked-files))))) + +(defun image-dired-comment-thumbnail () + "Add comment to current thumbnail in thumbnail buffer." + (interactive) + (let* ((file (image-dired-original-file-name)) + (comment (image-dired-read-comment file))) + (image-dired-write-comments (list (cons file comment))) + (image-dired-update-property 'comment comment)) + (image-dired-update-header-line)) + +(defun image-dired-read-comment (&optional file) + "Read comment for an image. +Optionally use old comment from FILE as initial value." + (let ((comment + (read-string + "Comment: " + (if file (image-dired-get-comment file))))) + comment)) + +(defun image-dired-get-comment (file) + "Get comment for file FILE." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end comment-beg-pos comment-end-pos comment) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (point)) + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + (setq comment (buffer-substring + comment-beg-pos comment-end-pos)))) + comment))) + +;;;###autoload +(defun image-dired-mark-tagged-files (regexp) + "Use REGEXP to mark files with matching tag. +A `tag' is a keyword, a piece of meta data, associated with an +image file and stored in image-dired's database file. This command +lets you input a regexp and this will be matched against all tags +on all image files in the database file. The files that have a +matching tag will be marked in the Dired buffer." + (interactive "sMark tagged files (regexp): ") + (image-dired-sane-db-file) + (let ((hits 0) + files) + (image-dired--with-db-file + ;; Collect matches + (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t) + (let ((file (match-string 1)) + (tags (split-string (match-string 2) ";"))) + (when (seq-find (lambda (tag) + (string-match-p regexp tag)) + tags) + (push file files))))) + ;; Mark files + (dolist (curr-file files) + ;; I tried using `dired-mark-files-regexp' but it was waaaay to + ;; slow. Don't bother about hits found in other directories + ;; than the current one. + (when (string= (file-name-as-directory + (expand-file-name default-directory)) + (file-name-as-directory + (file-name-directory curr-file))) + (setq curr-file (file-name-nondirectory curr-file)) + (goto-char (point-min)) + (when (search-forward-regexp (format "\\s %s$" curr-file) nil t) + (setq hits (+ hits 1)) + (dired-mark 1)))) + (message "%d files with matching tag marked" hits))) + + + +;;; Mouse support + +(defun image-dired-mouse-display-image (event) + "Use mouse EVENT, call `image-dired-display-image' to display image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (let ((file (image-dired-original-file-name))) + (when file + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-display-image file)))) + +(defun image-dired-mouse-select-thumbnail (event) + "Use mouse EVENT to select thumbnail image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + + +;;; Dired marks and tags + +(defun image-dired-thumb-file-marked-p (&optional flagged) + "Check if file is marked in associated Dired buffer. +If optional argument FLAGGED is non-nil, check if file is flagged +for deletion instead." + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (when (and dired-buf file-name) + (with-current-buffer dired-buf + (save-excursion + (when (dired-goto-file file-name) + (if flagged + (image-dired-dired-file-flagged-p) + (image-dired-dired-file-marked-p)))))))) + +(defun image-dired-thumb-file-flagged-p () + "Check if file is flagged for deletion in associated Dired buffer." + (image-dired-thumb-file-marked-p t)) + +(defun image-dired-delete-marked () + "Delete current or marked thumbnails and associated images." + (interactive) + (image-dired--with-marked + (image-dired-delete-char) + (unless (bobp) + (backward-char))) + (image-dired--line-up-with-method) + (with-current-buffer (image-dired-associated-dired-buffer) + (dired-do-delete))) + +(defun image-dired-thumb-update-marks () + "Update the marks in the thumbnail buffer." + (when image-dired-thumb-visible-marks + (with-current-buffer image-dired-thumbnail-buffer + (save-mark-and-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (while (not (eobp)) + (with-silent-modifications + (cond ((image-dired-thumb-file-marked-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-mark)) + ((image-dired-thumb-file-flagged-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-flagged)) + (t (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))))) + (forward-char))))))) + +(defun image-dired-mouse-toggle-mark-1 () + "Toggle Dired mark for current thumbnail. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-toggle-mark-thumb-original-file)) + +(defun image-dired-mouse-toggle-mark (event) + "Use mouse EVENT to toggle Dired mark for thumbnail. +Toggle marks of all thumbnails in region, if it's active. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (interactive "e") + (if (use-region-p) + (let ((end (region-end))) + (save-excursion + (goto-char (region-beginning)) + (while (<= (point) end) + (when (image-dired-image-at-point-p) + (image-dired-mouse-toggle-mark-1)) + (forward-char)))) + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (image-dired-mouse-toggle-mark-1)) + (image-dired-thumb-update-marks)) + +(defun image-dired-dired-display-properties () + "Display properties for Dired file in the echo area." + (interactive) + (let* ((file (dired-get-filename)) + (file-name (file-name-nondirectory file)) + (dired-buf (buffer-name (current-buffer))) + (props (mapconcat #'identity (image-dired-list-tags file) ", ")) + (comment (image-dired-get-comment file)) + (message-log-max nil)) + (if file-name + (message "%s" + (image-dired-format-properties-string + dired-buf + file-name + props + comment))))) + + + +;;; Gallery support + +;; TODO: +;; * Support gallery creation when using per-directory thumbnail +;; storage. +;; * Enhanced gallery creation with basic CSS-support and pagination +;; of tag pages with many pictures. + +(defgroup image-dired-gallery nil + "Image-Dired support for generating a HTML gallery." + :prefix "image-dired-" + :group 'image-dired + :version "29.1") + +(defcustom image-dired-gallery-dir + (expand-file-name ".image-dired_gallery" image-dired-dir) + "Directory to store generated gallery html pages. +The name of this directory needs to be \"shared\" to the public +so that it can access the index.html page that image-dired creates." + :type 'directory) + +(defcustom image-dired-gallery-image-root-url + "https://example.org/image-diredpics" + "URL where the full size images are to be found on your web server. +Note that this URL has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-thumb-image-root-url + "https://example.org/image-diredthumbs" + "URL where the thumbnail images are to be found on your web server. +Note that URL path has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-hidden-tags + (list "private" "hidden" "pending") + "List of \"hidden\" tags. +Used by `image-dired-gallery-generate' to leave out \"hidden\" images." + :type '(repeat string)) + +(defvar image-dired-tag-file-list nil + "List to store tag-file structure.") + +(defvar image-dired-file-tag-list nil + "List to store file-tag structure.") + +(defvar image-dired-file-comment-list nil + "List to store file comments.") + +(defun image-dired--add-to-tag-file-lists (tag file) + "Helper function used from `image-dired--create-gallery-lists'. + +Add TAG to FILE in one list and FILE to TAG in the other. + +Lisp structures look like the following: + +image-dired-file-tag-list: + + ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...) + (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...) + ...) + +image-dired-tag-file-list: + + ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...) + (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...) + ...)" + ;; Add tag to file list + (let (curr) + (if image-dired-file-tag-list + (if (setq curr (assoc file image-dired-file-tag-list)) + (setcdr curr (cons tag (cdr curr))) + (setcdr image-dired-file-tag-list + (cons (list file tag) (cdr image-dired-file-tag-list)))) + (setq image-dired-file-tag-list (list (list file tag)))) + ;; Add file to tag list + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired--add-to-file-comment-list (file comment) + "Helper function used from `image-dired--create-gallery-lists'. + +For FILE, add COMMENT to list. + +Lisp structure looks like the following: + +image-dired-file-comment-list: + + ((\"filename1\" . \"comment1\") + (\"filename2\" . \"comment2\") + ...)" + (if image-dired-file-comment-list + (if (not (assoc file image-dired-file-comment-list)) + (setcdr image-dired-file-comment-list + (cons (cons file comment) + (cdr image-dired-file-comment-list)))) + (setq image-dired-file-comment-list (list (cons file comment))))) + +(defun image-dired--create-gallery-lists () + "Create temporary lists used by `image-dired-gallery-generate'." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end beg file row-tags) + (setq image-dired-tag-file-list nil) + (setq image-dired-file-tag-list nil) + (setq image-dired-file-comment-list nil) + (goto-char (point-min)) + (while (search-forward-regexp "^." nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (setq beg (point)) + (unless (search-forward ";" end nil) + (error "Something is really wrong, check format of database")) + (setq row-tags (split-string + (buffer-substring beg end) ";")) + (setq file (car row-tags)) + (dolist (x (cdr row-tags)) + (if (not (string-match "^comment:\\(.*\\)" x)) + (image-dired--add-to-tag-file-lists x file) + (image-dired--add-to-file-comment-list file (match-string 1 x))))))) + ;; Sort tag-file list + (setq image-dired-tag-file-list + (sort image-dired-tag-file-list + (lambda (x y) + (string< (car x) (car y)))))) + +(defun image-dired--hidden-p (file) + "Return t if image FILE has a \"hidden\" tag." + (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list)) + if (member tag image-dired-gallery-hidden-tags) return t)) + +(defun image-dired-gallery-generate () + "Generate gallery pages. +First we create a couple of Lisp structures from the database to make +it easier to generate, then HTML-files are created in +`image-dired-gallery-dir'." + (interactive) + (if (eq 'per-directory image-dired-thumbnail-storage) + (error "Currently, gallery generation is not supported \ +when using per-directory thumbnail file storage")) + (image-dired--create-gallery-lists) + (let ((tags image-dired-tag-file-list) + (index-file (format "%s/index.html" image-dired-gallery-dir)) + count tag tag-file + comment file-tags tag-link tag-link-list) + ;; Make sure gallery root exist + (if (file-exists-p image-dired-gallery-dir) + (if (not (file-directory-p image-dired-gallery-dir)) + (error "Variable image-dired-gallery-dir is not a directory")) + ;; FIXME: Should we set umask to 077 here, as we do for thumbnails? + (make-directory image-dired-gallery-dir)) + ;; Open index file + (with-temp-file index-file + (if (file-exists-p index-file) + (insert-file-contents index-file)) + (insert "\n") + (insert " \n") + (insert "

Image-Dired Gallery

\n") + (insert (format "

\n Gallery generated %s\n

\n" + (current-time-string))) + (insert "

Tag index

\n") + (setq count 1) + ;; Pre-generate list of all tag links + (dolist (curr tags) + (setq tag (car curr)) + (when (not (member tag image-dired-gallery-hidden-tags)) + (setq tag-link (format "%s" count tag)) + (if tag-link-list + (setq tag-link-list + (append tag-link-list (list (cons tag tag-link)))) + (setq tag-link-list (list (cons tag tag-link)))) + (setq count (1+ count)))) + (setq count 1) + ;; Main loop where we generated thumbnail pages per tag + (dolist (curr tags) + (setq tag (car curr)) + ;; Don't display hidden tags + (when (not (member tag image-dired-gallery-hidden-tags)) + ;; Insert link to tag page in index + (insert (format " %s
\n" (cdr (assoc tag tag-link-list)))) + ;; Open per-tag file + (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count)) + (with-temp-file tag-file + (if (file-exists-p tag-file) + (insert-file-contents tag-file)) + (erase-buffer) + (insert "\n") + (insert " \n") + (insert "

Index

\n") + (insert (format "

Images with tag "%s"

" tag)) + ;; Main loop for files per tag page + (dolist (file (cdr curr)) + (unless (image-dired-hidden-p file) + ;; Insert thumbnail with link to full image + (insert + (format "\n" + image-dired-gallery-image-root-url + (file-name-nondirectory file) + image-dired-gallery-thumb-image-root-url + (file-name-nondirectory (image-dired-thumb-name file)) file)) + ;; Insert comment, if any + (if (setq comment (cdr (assoc file image-dired-file-comment-list))) + (insert (format "
\n%s
\n" comment)) + (insert "
\n")) + ;; Insert links to other tags, if any + (when (> (length + (setq file-tags (assoc file image-dired-file-tag-list))) 2) + (insert "[ ") + (dolist (extra-tag file-tags) + ;; Only insert if not file name or the main tag + (if (and (not (equal extra-tag tag)) + (not (equal extra-tag file))) + (insert + (format "%s " (cdr (assoc extra-tag tag-link-list)))))) + (insert "]
\n")))) + (insert "

Index

\n") + (insert " \n") + (insert "\n")) + (setq count (1+ count)))) + (insert " \n") + (insert "")))) + + +;;; Tag support + +(defvar image-dired-widget-list nil + "List to keep track of meta data in edit buffer.") + +(declare-function widget-forward "wid-edit" (arg)) + +;;;###autoload +(defun image-dired-dired-edit-comment-and-tags () + "Edit comment and tags of current or marked image files. +Edit comment and tags for all marked image files in an +easy-to-use form." + (interactive) + (setq image-dired-widget-list nil) + ;; Setup buffer. + (let ((files (dired-get-marked-files))) + (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*") + (kill-all-local-variables) + (let ((inhibit-read-only t)) + (erase-buffer)) + (remove-overlays) + ;; Some help for the user. + (widget-insert +"\nEdit comments and tags for each image. Separate multiple tags +with a comma. Move forward between fields using TAB or RET. +Move to the previous field using backtab (S-TAB). Save by +activating the Save button at the bottom of the form or cancel +the operation by activating the Cancel button.\n\n") + ;; Here comes all images and a comment and tag field for each + ;; image. + (let (thumb-file img comment-widget tag-widget) + + (dolist (file files) + + (setq thumb-file (image-dired-thumb-name file) + img (create-image thumb-file)) + + (insert-image img) + (widget-insert "\n\nComment: ") + (setq comment-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (image-dired-get-comment file) ""))) + (widget-insert "\nTags: ") + (setq tag-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (mapconcat + #'identity + (image-dired-list-tags file) + ",") ""))) + ;; Save information in all widgets so that we can use it when + ;; the user saves the form. + (setq image-dired-widget-list + (append image-dired-widget-list + (list (list file comment-widget tag-widget)))) + (widget-insert "\n\n"))) + + ;; Footer with Save and Cancel button. + (widget-insert "\n") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (image-dired-save-information-from-widgets) + (bury-buffer) + (message "Done")) + "Save") + (widget-insert " ") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (bury-buffer) + (message "Operation canceled")) + "Cancel") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + ;; Jump to the first widget. + (widget-forward 1))) + +(defun image-dired-save-information-from-widgets () + "Save information found in `image-dired-widget-list'. +Use the information in `image-dired-widget-list' to save comments and +tags to their respective image file. Internal function used by +`image-dired-dired-edit-comment-and-tags'." + (let (file comment tag-string tag-list lst) + (image-dired-write-comments + (mapcar + (lambda (widget) + (setq file (car widget) + comment (widget-value (cadr widget))) + (cons file comment)) + image-dired-widget-list)) + (image-dired-write-tags + (dolist (widget image-dired-widget-list lst) + (setq file (car widget) + tag-string (widget-value (car (cddr widget))) + tag-list (split-string tag-string ",")) + (dolist (tag tag-list) + (push (cons file tag) lst)))))) + + +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun image-dired-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (file-name-nondirectory + (directory-file-name + (file-name-directory (image-dired-original-file-name))))) + +(defun image-dired-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(image-dired-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(file-name-directory (image-dired-original-file-name))) + (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name))) + (handler . image-dired-bookmark-jump))) + +;;;###autoload +(defun image-dired-bookmark-jump (bookmark) + "Default bookmark handler for Image-Dired buffers." + ;; User already cached thumbnails, so disable any checking. + (let ((image-dired-show-all-from-dir-max-files nil)) + (image-dired (bookmark-prop-get bookmark 'location)) + ;; TODO: Go to the bookmarked file, if it exists. + ;; (bookmark-prop-get bookmark 'image-dired-file) + (goto-char (point-min)))) + +(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired") + +;;; Obsolete + +;;;###autoload +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +;;;###autoload +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings + #'image-dired-minor-mode "26.1") + +(defcustom image-dired-temp-image-file + (expand-file-name ".image-dired_temp" image-dired-dir) + "Name of temporary image file used by various commands." + :type 'file) +(make-obsolete-variable 'image-dired-temp-image-file + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-program + (if (executable-find "gm") "gm" "convert") + "Executable used to create temporary image. +Used together with `image-dired-cmd-create-temp-image-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-create-temp-image-program + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) + "Options of command used to create temporary image for display window. +Used together with `image-dired-cmd-create-temp-image-program', +Available format specifiers are: %w and %h which are replaced by +the calculated max size for width and height in the image display window, +%f which is replaced by the file name of the original image and %t which +is replaced by the file name of the temporary file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-create-temp-image-options + "no longer used." "29.1") + +(defcustom image-dired-display-window-width-correction 1 + "Number to be used to correct image display window width. +Change if the default (1) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-width-correction + "no longer used." "29.1") + +(defcustom image-dired-display-window-height-correction 0 + "Number to be used to correct image display window height. +Change if the default (0) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-height-correction + "no longer used." "29.1") + +(defun image-dired-display-window-width (window) + "Return width, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-width-pixels window) + image-dired-display-window-width-correction)) + +(defun image-dired-display-window-height (window) + "Return height, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-height-pixels window) + image-dired-display-window-height-correction)) + +(defun image-dired-window-height-pixels (window) + "Calculate WINDOW height in pixels." + (declare (obsolete nil "29.1")) + ;; Note: The mode-line consumes one line + (* (- (window-height window) 1) (frame-char-height))) + +(defcustom image-dired-cmd-read-exif-data-program "exiftool" + "Program used to read EXIF data to image. +Used together with `image-dired-cmd-read-exif-data-options'." + :type 'file) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-program + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f") + "Arguments of command used to read EXIF data. +Used with `image-dired-cmd-read-exif-data-program'. +Available format specifiers are: %f which is replaced +by the image file name and %t which is replaced by the tag name." + :version "26.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-options + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defun image-dired-get-exif-data (file tag-name) + "From FILE, return EXIF tag TAG-NAME." + (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-read-exif-data-program) + (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) + (spec (list (cons ?f file) (cons ?t tag-name))) + tag-value) + (with-current-buffer buf + (delete-region (point-min) (point-max)) + (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program + nil t nil + (mapcar + (lambda (arg) (format-spec arg spec)) + image-dired-cmd-read-exif-data-options)) + 0)) + (error "Could not get EXIF tag") + (goto-char (point-min)) + ;; Clean buffer from newlines and carriage returns before + ;; getting final info + (while (search-forward-regexp "[\n\r]" nil t) + (replace-match "" nil t)) + (setq tag-value (buffer-substring (point-min) (point-max))))) + tag-value)) + +(defcustom image-dired-cmd-rotate-thumbnail-program + (if (executable-find "gm") "gm" "mogrify") + "Executable used to rotate thumbnail. +Used together with `image-dired-cmd-rotate-thumbnail-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1") + +(defcustom image-dired-cmd-rotate-thumbnail-options + (let ((opts '("-rotate" "%d" "%t"))) + (if (executable-find "gm") (cons "mogrify" opts) opts)) + "Arguments of command used to rotate thumbnail image. +Used with `image-dired-cmd-rotate-thumbnail-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or 270 +\(for 90 degrees right and left), %t which is replaced by the file name +of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") + +(defun image-dired-rotate-thumbnail (degrees) + "Rotate thumbnail DEGREES degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-thumbnail-program) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) + (thumb (expand-file-name file)) + (spec (list (cons ?d degrees) (cons ?t thumb)))) + (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-thumbnail-options)) + (clear-image-cache thumb)))) + +(defun image-dired-rotate-thumbnail-left () + "Rotate thumbnail left (counter clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "270"))) + +(defun image-dired-rotate-thumbnail-right () + "Rotate thumbnail counter right (clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "90"))) + +(defun image-dired-modify-mark-on-thumb-original-file (command) + "Modify mark in Dired buffer. +COMMAND is one of `mark' for marking file in Dired, `unmark' for +unmarking file in Dired or `flag' for flagging file for delete in +Dired." + (declare (obsolete image-dired--on-file-in-dired-buffer "29.1")) + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (message "%s" file-name) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) + +(defun image-dired-display-current-image-full () + "Display current image in full size." + (declare (obsolete image-transform-original "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file) + (with-current-buffer image-dired-display-image-buffer + (image-transform-original))) + (error "No original file name at point")))) + +(defun image-dired-display-current-image-sized () + "Display current image in sized to fit window dimensions." + (declare (obsolete image-mode-fit-frame "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file)) + (error "No original file name at point")))) + +(defun image-dired-add-to-tag-file-list (tag file) + "Add relation between TAG and FILE." + (declare (obsolete nil "29.1")) + (let (curr) + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired-display-thumb-properties () + "Display thumbnail properties in the echo area." + (declare (obsolete image-dired-update-header-line "29.1")) + (image-dired-update-header-line)) + +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + +(define-obsolete-function-alias 'image-dired-create-display-image-buffer + #'ignore "29.1") +(define-obsolete-function-alias 'image-dired-create-gallery-lists + #'image-dired--create-gallery-lists "29.1") +(define-obsolete-function-alias 'image-dired-add-to-file-comment-list + #'image-dired--add-to-file-comment-list "29.1") +(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists + #'image-dired--add-to-tag-file-lists "29.1") +(define-obsolete-function-alias 'image-dired-hidden-p + #'image-dired--hidden-p "29.1") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;; TEST-SECTION ;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defvar image-dired-dir-max-size 12300000) + +;; (defun image-dired-test-clean-old-files () +;; "Clean `image-dired-dir' from old thumbnail files. +;; \"Oldness\" measured using last access time. If the total size of all +;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size', +;; old files are deleted until the max size is reached." +;; (let* ((files +;; (sort +;; (mapcar +;; (lambda (f) +;; (let ((fattribs (file-attributes f))) +;; `(,(file-attribute-access-time fattribs) +;; ,(file-attribute-size fattribs) ,f))) +;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$")) +;; ;; Sort function. Compare time between two files. +;; (lambda (l1 l2) +;; (time-less-p (car l1) (car l2))))) +;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files)))) +;; (while (> dirsize image-dired-dir-max-size) +;; (y-or-n-p +;; (format "Size of thumbnail directory: %d, delete old file %s? " +;; dirsize (cadr (cdar files)))) +;; (delete-file (cadr (cdar files))) +;; (setq dirsize (- dirsize (car (cdar files)))) +;; (setq files (cdr files))))) + +(provide 'image-dired) + +;;; image-dired.el ends here diff --git a/lisp/image/image-dired-util.el b/lisp/image/image-dired-util.el new file mode 100644 index 00000000000..9f12354111c --- /dev/null +++ b/lisp/image/image-dired-util.el @@ -0,0 +1,3080 @@ +;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- + +;; Copyright (C) 2005-2022 Free Software Foundation, Inc. + +;; Version: 0.4.11 +;; Keywords: multimedia +;; Author: Mathias Dahl + +;; 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 . + +;;; Commentary: + +;; BACKGROUND +;; ========== +;; +;; I needed a program to browse, organize and tag my pictures. I got +;; tired of the old gallery program I used as it did not allow +;; multi-file operations easily. Also, it put things out of my +;; control. Image viewing programs I tested did not allow multi-file +;; operations or did not do what I wanted it to. +;; +;; So, I got the idea to use the wonderful functionality of Emacs and +;; `dired' to do it. It would allow me to do almost anything I wanted, +;; which is basically just to browse all my pictures in an easy way, +;; letting me manipulate and tag them in various ways. `dired' already +;; provide all the file handling and navigation facilities; I only +;; needed to add some functions to display the images. +;; +;; I briefly tried out thumbs.el, and although it seemed more +;; powerful than this package, it did not work the way I wanted to. It +;; was too slow to create thumbnails of all files in a directory (I +;; currently keep all my 2000+ images in the same directory) and +;; browsing the thumbnail buffer was slow too. image-dired.el will not +;; create thumbnails until they are needed and the browsing is done +;; quickly and easily in Dired. I copied a great deal of ideas and +;; code from there though... :) +;; +;; `image-dired' stores the thumbnail files in `image-dired-dir' +;; using the file name format ORIGNAME.thumb.ORIGEXT. For example +;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for +;; now just a plain text file with the following format: +;; +;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN +;; +;; +;; PREREQUISITES +;; ============= +;; +;; * The GraphicsMagick or ImageMagick package; Image-Dired uses +;; whichever is available. +;; +;; A) For GraphicsMagick, `gm' is used. +;; Find it here: http://www.graphicsmagick.org/ +;; +;; B) For ImageMagick, `convert' and `mogrify' are used. +;; Find it here: https://www.imagemagick.org. +;; +;; * For non-lossy rotation of JPEG images, the JpegTRAN program is +;; needed. +;; +;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is +;; needed. It can be found here: https://exiftool.org/. This +;; function is, among other things, used for writing comments to +;; image files using `image-dired-thumbnail-set-image-description'. +;; +;; +;; USAGE +;; ===== +;; +;; This information has been moved to the manual. Type `C-h r' to open +;; the Emacs manual and go to the node Thumbnails by typing `g +;; Image-Dired RET'. +;; +;; Quickstart: M-x image-dired RET DIRNAME RET +;; +;; where DIRNAME is a directory containing image files. +;; +;; LIMITATIONS +;; =========== +;; +;; * Supports all image formats that Emacs and convert supports, but +;; the thumbnails are hard-coded to JPEG or PNG format. It uses +;; JPEG by default, but can optionally follow the Thumbnail Managing +;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user +;; option `image-dired-thumbnail-storage'. +;; +;; * WARNING: The "database" format used might be changed so keep a +;; backup of `image-dired-db-file' when testing new versions. +;; +;; TODO +;; ==== +;; +;; * Investigate if it is possible to also write the tags to the image +;; files. +;; +;; * From thumbs.el: Add an option for clean-up/max-size functionality +;; for thumbnail directory. +;; +;; * From thumbs.el: Add setroot function. +;; +;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out +;; which is best, saving old batch just before inserting new, or +;; saving the current batch in the ring when inserting it. Adding +;; it probably needs rewriting `image-dired-display-thumbs' to be more general. +;; +;; * Find some way of toggling on and off really nice keybindings in +;; Dired (for example, using C-n or instead of C-S-n). +;; Richard suggested that we could keep C-t as prefix for +;; image-dired commands as it is currently not used in Dired. He +;; also suggested that `dired-next-line' and `dired-previous-line' +;; figure out if image-dired is enabled in the current buffer and, +;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line', +;; respectively. Update: This is partly done; some bindings have +;; now been added to Dired. +;; +;; * In some way keep track of buffers and windows and stuff so that +;; it works as the user expects. +;; +;; * More/better documentation. + +;;; Code: + +(require 'dired) +(require 'exif) +(require 'image-mode) +(require 'widget) +(require 'xdg) + +(eval-when-compile + (require 'cl-lib) + (require 'wid-edit)) + + +;;; Customizable variables + +(defgroup image-dired nil + "Use Dired to browse your images as thumbnails, and more." + :prefix "image-dired-" + :link '(info-link "(emacs) Image-Dired") + :group 'multimedia) + +(defcustom image-dired-dir (locate-user-emacs-file "image-dired/") + "Directory where thumbnail images are stored. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; they will be +saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See +`image-dired-thumbnail-storage'." + :type 'directory) + +(defcustom image-dired-thumbnail-storage 'use-image-dired-dir + "How `image-dired' stores thumbnail files. +There are two ways that Image-Dired can store and generate +thumbnails. If you set this variable to one of the two following +values, they will be stored in the JPEG format: + +- `use-image-dired-dir' means that the thumbnails are stored in a + central directory. + +- `per-directory' means that each thumbnail is stored in a + subdirectory called \".image-dired\" in the same directory + where the image file is. + +It can also use the \"Thumbnail Managing Standard\", which allows +sharing of thumbnails across different programs. Thumbnails will +be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in +`image-dired-dir'. Thumbnails are saved in the PNG format, and +can be one of the following sizes: + +- `standard' means use thumbnails sized 128x128. +- `standard-large' means use thumbnails sized 256x256. +- `standard-x-large' means use thumbnails sized 512x512. +- `standard-xx-large' means use thumbnails sized 1024x1024. + +For more information on the Thumbnail Managing Standard, see: +https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html" + :type '(choice :tag "How to store thumbnail files" + (const :tag "Use image-dired-dir" use-image-dired-dir) + (const :tag "Thumbnail Managing Standard (normal 128x128)" + standard) + (const :tag "Thumbnail Managing Standard (large 256x256)" + standard-large) + (const :tag "Thumbnail Managing Standard (larger 512x512)" + standard-x-large) + (const :tag "Thumbnail Managing Standard (extra large 1024x1024)" + standard-xx-large) + (const :tag "Per-directory" per-directory)) + :version "29.1") + +(defconst image-dired--thumbnail-standard-sizes + '( standard standard-large + standard-x-large standard-xx-large) + "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.") + +(defcustom image-dired-db-file + (expand-file-name ".image-dired_db" image-dired-dir) + "Database file where file names and their associated tags are stored." + :type 'file) + +(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'." + :type 'file + :version "29.1") + +(defcustom image-dired-cmd-create-thumbnail-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-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'. +Available format specifiers are: %w which is replaced by +`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height', +%f which is replaced by the file name of the original image and %t +which is replaced by the file name of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-pngnq-program + ;; Prefer pngquant to pngnq-s9 as it is faster on my machine. + ;; The project also seems more active than the alternatives. + ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq. + ;; The pngnq project seems dead (?) since 2011 or so. + (or (executable-find "pngquant") + (executable-find "pngnq-s9") + (executable-find "pngnq")) + "The 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" + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngnq-options + (if (executable-find "pngquant") + '("--ext" "-nq8.png" "%t") ; same extension as "pngnq" + '("-f" "%t")) + "Arguments to pass `image-dired-cmd-pngnq-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options'." + :type '(repeat (string :tag "Argument")) + :version "29.1") + +(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush") + "The file name of the `pngcrush' program. +It optimizes the compression of PNG images. Also it adds PNG textual chunks +with the information required by the Thumbnail Managing Standard." + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngcrush-options + `("-q" + "-text" "b" "Description" "Thumbnail of file://%f" + "-text" "b" "Software" ,(emacs-version) + ;; "-text b \"Thumb::Image::Height\" \"%oh\" " + ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" " + ;; "-text b \"Thumb::Image::Width\" \"%ow\" " + "-text" "b" "Thumb::MTime" "%m" + ;; "-text b \"Thumb::Size\" \"%b\" " + "-text" "b" "Thumb::URI" "file://%f" + "%q" "%t") + "Arguments for `image-dired-cmd-pngcrush-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %q for a +temporary file name (typically generated by pnqnq)." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-optipng-program (executable-find "optipng") + "The 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'. +Available format specifiers are described in +`image-dired-cmd-create-thumbnail-options'." + :version "26.1" + :type '(repeat (string :tag "Argument")) + :link '(url-link "man:optipng(1)")) + +(defcustom image-dired-cmd-create-standard-thumbnail-options + (append '("-size" "%wx%h" "%f[0]") + (unless (or image-dired-cmd-pngcrush-program + image-dired-cmd-pngnq-program) + (list + "-set" "Thumb::MTime" "%m" + "-set" "Thumb::URI" "file://%f" + "-set" "Description" "Thumbnail of file://%f" + "-set" "Software" (emacs-version))) + '("-thumbnail" "%wx%h>" "png:%t")) + "Options for creating thumbnails according to the Thumbnail Managing Standard. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %m for file modification time." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-rotate-original-program + "jpegtran" + "Executable used to rotate original image. +Used together with `image-dired-cmd-rotate-original-options'." + :type 'file) + +(defcustom image-dired-cmd-rotate-original-options + '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o") + "Arguments of command used to rotate original image. +Used with `image-dired-cmd-rotate-original-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or +270 \(for 90 degrees right and left), %o which is replaced by the +original image file name and %t which is replaced by +`image-dired-temp-image-file'." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-temp-rotate-image-file + (expand-file-name ".image-dired_rotate_temp" image-dired-dir) + "Temporary file for rotate operations." + :type 'file) + +(defcustom image-dired-rotate-original-ask-before-overwrite t + "Confirm overwrite of original file after rotate operation. +If non-nil, ask user for confirmation before overwriting the +original file with `image-dired-temp-rotate-image-file'." + :type 'boolean) + +(defcustom image-dired-cmd-write-exif-data-program + "exiftool" + "Program used to write EXIF data to image. +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. +Used with `image-dired-cmd-write-exif-data-program'. +Available format specifiers are: %f which is replaced by +the image file name, %t which is replaced by the tag name and %v +which is replaced by the tag value." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-thumb-size + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t 100)) + "Size of thumbnails, in pixels. +This is the default size for both `image-dired-thumb-width' +and `image-dired-thumb-height'. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; the standard +sizes will be used instead. See `image-dired-thumbnail-storage'." + :type 'integer) + +(defcustom image-dired-thumb-width image-dired-thumb-size + "Width of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-height image-dired-thumb-size + "Height of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-relief 2 + "Size of button-like border around thumbnails." + :type 'integer) + +(defcustom image-dired-thumb-margin 2 + "Size of the margin around thumbnails. +This is where you see the cursor." + :type 'integer) + +(defcustom image-dired-thumb-visible-marks t + "Make marks and flags visible in thumbnail buffer. +If non-nil, apply the `image-dired-thumb-mark' face to marked +images and `image-dired-thumb-flagged' to images flagged for +deletion." + :type 'boolean + :version "28.1") + +(defface image-dired-thumb-mark + '((((class color) (min-colors 16)) :background "DarkOrange") + (((class color)) :foreground "yellow")) + "Face for marked images in thumbnail buffer." + :version "29.1") + +(defface image-dired-thumb-flagged + '((((class color) (min-colors 88) (background light)) :background "Red3") + (((class color) (min-colors 88) (background dark)) :background "Pink") + (((class color) (min-colors 16) (background light)) :background "Red3") + (((class color) (min-colors 16) (background dark)) :background "Pink") + (((class color) (min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for images flagged for deletion in thumbnail buffer." + :version "29.1") + +(defcustom image-dired-line-up-method 'dynamic + "Default method for line-up of thumbnails in thumbnail buffer. +Used by `image-dired-display-thumbs' and other functions that needs +to line-up thumbnails. Dynamic means to use the available width of +the window containing the thumbnail buffer, Fixed means to use +`image-dired-thumbs-per-row', Interactive is for asking the user, +and No line-up means that no automatic line-up will be done." + :type '(choice :tag "Default line-up method" + (const :tag "Dynamic" dynamic) + (const :tag "Fixed" fixed) + (const :tag "Interactive" interactive) + (const :tag "No line-up" none))) + +(defcustom image-dired-thumbs-per-row 3 + "Number of thumbnails to display per row in thumb buffer." + :type 'integer) + +(defcustom image-dired-track-movement t + "The current state of the tracking and mirroring. +For more information, see the documentation for +`image-dired-toggle-movement-tracking'." + :type 'boolean) + +(defcustom image-dired-append-when-browsing nil + "Append thumbnails in thumbnail buffer when browsing. +If non-nil, using `image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' will leave a trail of thumbnail +images in the thumbnail buffer. If you enable this and want to clean +the thumbnail buffer because it is filled with too many thumbnails, +just call `image-dired-display-thumb' to display only the image at point. +This value can be toggled using `image-dired-toggle-append-browsing'." + :type 'boolean) + +(defcustom image-dired-dired-disp-props t + "If non-nil, display properties for Dired file when browsing. +Used by `image-dired-next-line-and-display', +`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'. +If the database file is large, this can slow down image browsing in +Dired and you might want to turn it off." + :type 'boolean) + +(defcustom image-dired-display-properties-format "%b: %f (%t): %c" + "Display format for thumbnail properties. +%b is replaced with associated Dired buffer name, %f with file +name (without path) of original image file, %t with the list of +tags and %c with the comment." + :type 'string) + +(defcustom image-dired-external-viewer + ;; TODO: Use mailcap, dired-guess-shell-alist-default, + ;; dired-view-command-alist. + (cond ((executable-find "display")) + ((executable-find "xli")) + ((executable-find "qiv") "qiv -t") + ((executable-find "feh") "feh")) + "Name of external viewer. +Including parameters. Used when displaying original image from +`image-dired-thumbnail-mode'." + :version "28.1" + :type '(choice string + (const :tag "Not Set" nil))) + +(defcustom image-dired-main-image-directory + (or (xdg-user-dir "PICTURES") "~/pics/") + "Name of main image directory, if any. +Used by `image-dired-copy-with-exif-file-name'." + :type 'string + :version "29.1") + +(defcustom image-dired-show-all-from-dir-max-files 500 + "Maximum number of files in directory before prompting. + +If there are more image files than this in a selected directory, +the `image-dired-show-all-from-dir' command will ask for +confirmation before creating the thumbnail buffer. If this +variable is nil, it will never ask." + :type '(choice integer + (const :tag "Disable warning" nil)) + :version "29.1") + +(defcustom image-dired-marking-shows-next t + "If non-nil, marking, unmarking or flagging an image shows the next image. + +This affects the following commands: +\\ + `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file]) + `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file]) + `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])" + :type 'boolean + :version "29.1") + + +;;; Util functions + +(defvar image-dired-debug nil + "Non-nil means enable debug messages.") + +(defun image-dired-debug-message (&rest args) + "Display debug message ARGS when `image-dired-debug' is non-nil." + (when image-dired-debug + (apply #'message args))) + +(defmacro image-dired--with-db-file (&rest body) + "Run BODY in a temp buffer containing `image-dired-db-file'. +Return the last form in BODY." + (declare (indent 0) (debug t)) + `(with-temp-buffer + (if (file-exists-p image-dired-db-file) + (insert-file-contents image-dired-db-file)) + ,@body)) + +(defun image-dired-dir () + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." + (let ((image-dired-dir (file-name-as-directory + (expand-file-name image-dired-dir)))) + (unless (file-directory-p image-dired-dir) + (with-file-modes #o700 + (make-directory image-dired-dir t)) + (message "Thumbnail directory created: %s" image-dired-dir)) + image-dired-dir)) + +(defun image-dired-insert-image (file type relief margin) + "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point." + (let ((i `(image :type ,type + :file ,file + :relief ,relief + :margin ,margin))) + (insert-image i))) + +(defun image-dired-get-thumbnail-image (file) + "Return the image descriptor for a thumbnail of image file FILE." + (unless (string-match-p (image-file-name-regexp) file) + (error "%s is not a valid image file" file)) + (let* ((thumb-file (image-dired-thumb-name file)) + (thumb-attr (file-attributes thumb-file))) + (when (or (not thumb-attr) + (time-less-p (file-attribute-modification-time thumb-attr) + (file-attribute-modification-time + (file-attributes file)))) + (image-dired-create-thumb file thumb-file)) + (create-image thumb-file))) + +(defun image-dired-insert-thumbnail (file original-file-name + associated-dired-buffer) + "Insert thumbnail image FILE. +Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." + (let (beg end) + (setq beg (point)) + (image-dired-insert-image + file + ;; Thumbnails are created asynchronously, so we might not yet + ;; have a file. But if it exists, it might have been cached from + ;; before and we should use it instead of our current settings. + (or (and (file-exists-p file) + (image-type-from-file-header file)) + (and (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + 'png) + 'jpeg) + image-dired-thumb-relief + image-dired-thumb-margin) + (setq end (point)) + (add-text-properties + beg end + (list 'image-dired-thumbnail t + 'original-file-name original-file-name + 'associated-dired-buffer associated-dired-buffer + 'tags (image-dired-list-tags original-file-name) + 'mouse-face 'highlight + 'comment (image-dired-get-comment original-file-name))))) + +(defun image-dired-thumb-name (file) + "Return absolute file name for thumbnail FILE. +Depending on the value of `image-dired-thumbnail-storage', the +file name of the thumbnail will vary: +- For `use-image-dired-dir', make a SHA1-hash of the image file's + directory name and add that to make the thumbnail file name + unique. +- For `per-directory' storage, just add a subdirectory. +- For `standard' storage, produce the file name according to the + Thumbnail Managing Standard. Among other things, an MD5-hash + of the image file's directory name will be added to the + filename. +See also `image-dired-thumbnail-storage'." + (cond ((memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + (let ((thumbdir (cl-case image-dired-thumbnail-storage + (standard "thumbnails/normal") + (standard-large "thumbnails/large") + (standard-x-large "thumbnails/x-large") + (standard-xx-large "thumbnails/xx-large")))) + (expand-file-name + ;; MD5 is mandated by the Thumbnail Managing Standard. + (concat (md5 (concat "file://" (expand-file-name file))) ".png") + (expand-file-name thumbdir (xdg-cache-home))))) + ((eq 'use-image-dired-dir image-dired-thumbnail-storage) + (let* ((f (expand-file-name file)) + (hash + (md5 (file-name-as-directory (file-name-directory f))))) + (format "%s%s%s.thumb.%s" + (file-name-as-directory (expand-file-name (image-dired-dir))) + (file-name-base f) + (if hash (concat "_" hash) "") + (file-name-extension f)))) + ((eq 'per-directory image-dired-thumbnail-storage) + (let ((f (expand-file-name file))) + (format "%s.image-dired/%s.thumb.%s" + (file-name-directory f) + (file-name-base f) + (file-name-extension f)))))) + +(defun image-dired--check-executable-exists (executable) + (unless (executable-find (symbol-value executable)) + (error "Executable %S not found" executable))) + + +;;; Creating thumbnails + +(defun image-dired-thumb-size (dimension) + "Return thumb size depending on `image-dired-thumbnail-storage'. +DIMENSION should be either the symbol `width' or `height'." + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t (cl-ecase dimension + (width image-dired-thumb-width) + (height image-dired-thumb-height))))) + +(defvar image-dired--generate-thumbs-start nil + "Time when `display-thumbs' was called.") + +(defvar image-dired-queue nil + "List of items in the queue. +Each item has the form (ORIGINAL-FILE TARGET-FILE).") + +(defvar image-dired-queue-active-jobs 0 + "Number of active jobs in `image-dired-queue'.") + +(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2))) + "Maximum number of concurrent jobs permitted for generating images. +Increase at 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 `image-clear-cache' +and remove the cached thumbnail files between each trial run.") + +(defun image-dired-pngnq-thumb (spec) + "Quantize thumbnail described by format SPEC with pngnq(1)." + (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) + (lambda (process status) + (if (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + ;; Pass off to pngcrush, or just rename the + ;; THUMB-nq8.png file back to THUMB.png + (if (and image-dired-cmd-pngcrush-program + (executable-find image-dired-cmd-pngcrush-program)) + (image-dired-pngcrush-thumb spec) + (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)) + +(defun image-dired-pngcrush-thumb (spec) + "Optimize thumbnail described by format SPEC with pngcrush(1)." + ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist. + ;; pngcrush needs an infile and outfile, so we just copy THUMB to + ;; THUMB-nq8.png and use the latter as a temp file. + (when (not image-dired-cmd-pngnq-program) + (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)) + +(defun image-dired-optipng-thumb (spec) + "Optimize thumbnail described by format SPEC with optipng(1)." + (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)) + +(defun image-dired-create-thumb-1 (original-file thumbnail-file) + "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE." + (image-dired--check-executable-exists + 'image-dired-cmd-create-thumbnail-program) + (let* ((width (int-to-string (image-dired-thumb-size 'width))) + (height (int-to-string (image-dired-thumb-size 'height))) + (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 + (list + (cons ?w width) + (cons ?h height) + (cons ?m modif-time) + (cons ?f original-file) + (cons ?q thumbnail-nq8-file) + (cons ?t thumbnail-file))) + (thumbnail-dir (file-name-directory thumbnail-file)) + process) + (when (not (file-exists-p thumbnail-dir)) + (with-file-modes #o700 + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) + + ;; Thumbnail file creation processes begin here and are marshaled + ;; in a queue by `image-dired-create-thumb'. + (setq process + (apply #'start-process "image-dired-create-thumbnail" nil + image-dired-cmd-create-thumbnail-program + (mapcar + (lambda (arg) (format-spec arg spec)) + (if (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + image-dired-cmd-create-standard-thumbnail-options + image-dired-cmd-create-thumbnail-options)))) + + (setf (process-sentinel process) + (lambda (process status) + ;; Trigger next in queue once a thumbnail has been created + (cl-decf image-dired-queue-active-jobs) + (image-dired-thumb-queue-run) + (when (= image-dired-queue-active-jobs 0) + (image-dired-debug-message + (format-time-string + "Generated thumbnails in %s.%3N seconds" + (time-subtract nil + image-dired--generate-thumbs-start)))) + (if (not (and (eq (process-status process) 'exit) + (zerop (process-exit-status process)))) + (message "Thumb could not be created for %s: %s" + (abbreviate-file-name original-file) + (string-replace "\n" "" status)) + (set-file-modes thumbnail-file #o600) + (clear-image-cache thumbnail-file) + ;; 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) + (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))))))) + process)) + +(defun image-dired-thumb-queue-run () + "Run a queued job if one exists and not too many jobs are running. +Queued items live in `image-dired-queue'." + (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)))) + +(defun image-dired-create-thumb (original-file thumbnail-file) + "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'. +The new file will be named THUMBNAIL-FILE." + (setq image-dired-queue + (nconc image-dired-queue + (list (list original-file thumbnail-file)))) + (run-at-time 0 nil #'image-dired-thumb-queue-run)) + +(defmacro image-dired--with-marked (&rest body) + "Eval BODY with point on each marked thumbnail. +If no marked file could be found, execute BODY on the current +thumbnail." + `(with-current-buffer image-dired-thumbnail-buffer + (let (found) + (save-mark-and-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (image-dired-thumb-file-marked-p) + (setq found t) + ,@body) + (forward-char))) + (unless found + ,@body)))) + +;;;###autoload +(defun image-dired-dired-toggle-marked-thumbs (&optional arg) + "Toggle thumbnails in front of file names in the Dired buffer. +If no marked file could be found, insert or hide thumbnails on the +current line. ARG, if non-nil, specifies the files to use instead +of the marked files. If ARG is an integer, use the next ARG (or +previous -ARG, if ARG<0) files." + (interactive "P") + (dired-map-over-marks + (let ((image-pos (dired-move-to-filename)) + (image-file (dired-get-filename nil t)) + thumb-file + overlay) + (when (and image-file + (string-match-p (image-file-name-regexp) image-file)) + (setq thumb-file (image-dired-get-thumbnail-image image-file)) + ;; If image is not already added, then add it. + (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'thumb-file) return ov))) + (if thumb-ov + (delete-overlay thumb-ov) + (put-image thumb-file image-pos) + (setq overlay + (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'put-image) return ov)) + (overlay-put overlay 'image-file image-file) + (overlay-put overlay 'thumb-file thumb-file))))) + arg ; Show or hide image on ARG next files. + 'show-progress) ; Update dired display after each image is updated. + (add-hook 'dired-after-readin-hook + 'image-dired-dired-after-readin-hook nil t)) + +(defun image-dired-dired-after-readin-hook () + "Relocate existing thumbnail overlays in Dired buffer after reverting. +Move them to their corresponding files if they still exist. +Otherwise, delete overlays." + (mapc (lambda (overlay) + (when (overlay-get overlay 'put-image) + (let* ((image-file (overlay-get overlay 'image-file)) + (image-pos (dired-goto-file image-file))) + (if image-pos + (move-overlay overlay image-pos image-pos) + (delete-overlay overlay))))) + (overlays-in (point-min) (point-max)))) + +(defun image-dired-next-line-and-display () + "Move to next Dired line and display thumbnail image." + (interactive) + (dired-next-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-previous-line-and-display () + "Move to previous Dired line and display thumbnail image." + (interactive) + (dired-previous-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-append-browsing () + "Toggle `image-dired-append-when-browsing'." + (interactive) + (setq image-dired-append-when-browsing + (not image-dired-append-when-browsing)) + (message "Append browsing %s" + (if image-dired-append-when-browsing + "on" + "off"))) + +(defun image-dired-mark-and-display-next () + "Mark current file in Dired and display next thumbnail image." + (interactive) + (dired-mark 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-dired-display-properties () + "Toggle `image-dired-dired-disp-props'." + (interactive) + (setq image-dired-dired-disp-props + (not image-dired-dired-disp-props)) + (message "Dired display properties %s" + (if image-dired-dired-disp-props + "on" + "off"))) + +(defvar image-dired-thumbnail-buffer "*image-dired*" + "Image-Dired's thumbnail buffer.") + +(defun image-dired-create-thumbnail-buffer () + "Create thumb buffer and set `image-dired-thumbnail-mode'." + (let ((buf (get-buffer-create image-dired-thumbnail-buffer))) + (with-current-buffer buf + (setq buffer-read-only t) + (if (not (eq major-mode 'image-dired-thumbnail-mode)) + (image-dired-thumbnail-mode))) + buf)) + +(defvar image-dired-display-image-buffer "*image-dired-display-image*" + "Where larger versions of the images are display.") + +(defvar image-dired-saved-window-configuration nil + "Saved window configuration.") + +;;;###autoload +(defun image-dired-dired-with-window-configuration (dir &optional arg) + "Open directory DIR and create a default window configuration. + +Convenience command that: + + - Opens Dired in folder DIR + - Splits windows in most useful (?) way + - Sets `truncate-lines' to t + +After the command has finished, you would typically mark some +image files in Dired and type +\\[image-dired-display-thumbs] (`image-dired-display-thumbs'). + +If called with prefix argument ARG, skip splitting of windows. + +The current window configuration is saved and can be restored by +calling `image-dired-restore-window-configuration'." + (interactive "DDirectory: \nP") + (let ((buf (image-dired-create-thumbnail-buffer)) + (buf2 (get-buffer-create image-dired-display-image-buffer))) + (setq image-dired-saved-window-configuration + (current-window-configuration)) + (dired dir) + (delete-other-windows) + (when (not arg) + (split-window-right) + (setq truncate-lines t) + (save-excursion + (other-window 1) + (pop-to-buffer-same-window buf) + (select-window (split-window-below)) + (pop-to-buffer-same-window buf2) + (other-window -2))))) + +(defun image-dired-restore-window-configuration () + "Restore window configuration. +Restore any changes to the window configuration made by calling +`image-dired-dired-with-window-configuration'." + (interactive nil image-dired-thumbnail-mode) + (if image-dired-saved-window-configuration + (set-window-configuration image-dired-saved-window-configuration) + (message "No saved window configuration"))) + +(defun image-dired--line-up-with-method () + "Line up thumbnails according to `image-dired-line-up-method'." + (cond ((eq 'dynamic image-dired-line-up-method) + (image-dired-line-up-dynamic)) + ((eq 'fixed image-dired-line-up-method) + (image-dired-line-up)) + ((eq 'interactive image-dired-line-up-method) + (image-dired-line-up-interactive)) + ((eq 'none image-dired-line-up-method) + nil) + (t + (image-dired-line-up-dynamic)))) + +;;;###autoload +(defun image-dired-display-thumbs (&optional arg append do-not-pop) + "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'. +If a thumbnail image does not exist for a file, it is created on the +fly. With prefix argument ARG, display only thumbnail for file at +point (this is useful if you have marked some files but want to show +another one). + +Recommended usage is to split the current frame horizontally so that +you have the Dired buffer in the left window and the +`image-dired-thumbnail-buffer' buffer in the right window. + +With optional argument APPEND, append thumbnail to thumbnail buffer +instead of erasing it first. + +Optional argument DO-NOT-POP controls if `pop-to-buffer' should be +used or not. If non-nil, use `display-buffer' instead of +`pop-to-buffer'. This is used from functions like +`image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' where we do not want the +thumbnail buffer to be selected." + (interactive "P") + (setq image-dired--generate-thumbs-start (current-time)) + (let ((buf (image-dired-create-thumbnail-buffer)) + thumb-name files dired-buf) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (setq dired-buf (current-buffer)) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (if (not append) + (erase-buffer) + (goto-char (point-max))) + (dolist (curr-file files) + (setq thumb-name (image-dired-thumb-name curr-file)) + (when (not (file-exists-p thumb-name)) + (image-dired-create-thumb curr-file thumb-name)) + (image-dired-insert-thumbnail thumb-name curr-file dired-buf))) + (if do-not-pop + (display-buffer buf) + (pop-to-buffer buf)) + (image-dired--line-up-with-method)))) + +;;;###autoload +(defun image-dired-show-all-from-dir (dir) + "Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation." + (interactive "DImage-Dired: ") + (dired dir) + (dired-mark-files-regexp (image-file-name-regexp)) + (let ((files (dired-get-marked-files nil nil nil t))) + (cond ((and (null (cdr files))) + (message "No image files in directory")) + ((or (not image-dired-show-all-from-dir-max-files) + (<= (length (cdr files)) image-dired-show-all-from-dir-max-files) + (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files) + (y-or-n-p + (format + "Directory contains more than %d image files. Proceed?" + image-dired-show-all-from-dir-max-files)))) + (image-dired-display-thumbs) + (pop-to-buffer image-dired-thumbnail-buffer) + (setq default-directory dir) + (image-dired-unmark-all-marks)) + (t (message "Image-Dired canceled"))))) + +;;;###autoload +(defalias 'image-dired 'image-dired-show-all-from-dir) + + +;;; Tags + +(defun image-dired-sane-db-file () + "Check if `image-dired-db-file' exists. +If not, try to create it (including any parent directories). +Signal error if there are problems creating it." + (or (file-exists-p image-dired-db-file) + (let (dir buf) + (unless (file-directory-p (setq dir (file-name-directory + image-dired-db-file))) + (with-file-modes #o700 + (make-directory dir t))) + (with-current-buffer (setq buf (create-file-buffer + image-dired-db-file)) + (with-file-modes #o600 + (write-file image-dired-db-file))) + (kill-buffer buf) + (file-exists-p image-dired-db-file)) + (error "Could not create %s" image-dired-db-file))) + +(defvar image-dired-tag-history nil "Variable holding the tag history.") + +(defun image-dired-write-tags (file-tags) + "Write file tags to database. +Write each file and tag in FILE-TAGS to the database. +FILE-TAGS is an alist in the following form: + ((FILE . TAG) ... )" + (image-dired-sane-db-file) + (let (end file tag) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-tags) + (setq file (car elt) + tag (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + (when (not (search-forward (format ";%s" tag) end t)) + (end-of-line) + (insert (format ";%s" tag)))) + (goto-char (point-max)) + (insert (format "%s;%s\n" file tag)))) + (save-buffer)))) + +(defun image-dired-remove-tag (files tag) + "For all FILES, remove TAG from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (let (end) + (unless (listp files) + (if (stringp files) + (setq files (list files)) + (error "Files must be a string or a list of strings!"))) + (dolist (file files) + (goto-char (point-min)) + (when (search-forward-regexp (format "^%s;" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward-regexp + (format "\\(;%s\\)\\($\\|;\\)" tag) end t) + (delete-region (match-beginning 1) (match-end 1)) + ;; Check if file should still be in the database. If + ;; it has no tags or comments, it will be removed. + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (not (search-forward ";" end t)) + (kill-line 1)))))) + (save-buffer))) + +(defun image-dired-list-tags (file) + "Read all tags for image FILE from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end (tags "")) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (if (search-forward ";" end t) + (if (search-forward "comment:" end t) + (if (search-forward ";" end t) + (setq tags (buffer-substring (point) end))) + (setq tags (buffer-substring (point) end))))) + (split-string tags ";")))) + +;;;###autoload +(defun image-dired-tag-files (arg) + "Tag marked file(s) in Dired. With prefix ARG, tag file at point." + (interactive "P") + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-write-tags + (mapcar + (lambda (x) + (cons x tag)) + files)))) + +(defun image-dired-tag-thumbnail () + "Tag current or marked thumbnails." + (interactive) + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-write-tags + (list (cons (image-dired-original-file-name) tag))) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + +;;;###autoload +(defun image-dired-delete-tag (arg) + "Remove tag for selected file(s). +With prefix argument ARG, remove tag from file at point." + (interactive "P") + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-remove-tag files tag))) + +(defun image-dired-tag-thumbnail-remove () + "Remove tag from current or marked thumbnails." + (interactive) + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-remove-tag (image-dired-original-file-name) tag) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + + +;;; Thumbnail mode (cont.) + +(defun image-dired-original-file-name () + "Get original file name for thumbnail or display image at point." + (get-text-property (point) 'original-file-name)) + +(defun image-dired-file-name-at-point () + "Get abbreviated file name for thumbnail or display image at point." + (let ((f (image-dired-original-file-name))) + (when f + (abbreviate-file-name f)))) + +(defun image-dired-associated-dired-buffer () + "Get associated Dired buffer at point." + (get-text-property (point) 'associated-dired-buffer)) + +(defun image-dired-get-buffer-window (buf) + "Return window where buffer BUF is." + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)) + nil t)) + +(defun image-dired-track-original-file () + "Track the original file in the associated Dired buffer. +See documentation for `image-dired-toggle-movement-tracking'. +Interactive use only useful if `image-dired-track-movement' is nil." + (interactive) + (let* ((dired-buf (image-dired-associated-dired-buffer)) + (file-name (image-dired-original-file-name)) + (window (image-dired-get-buffer-window dired-buf))) + (and (buffer-live-p dired-buf) file-name + (with-current-buffer dired-buf + (if (not (dired-goto-file file-name)) + (message "Could not track file") + (if window (set-window-point window (point)))))))) + +(defun image-dired-toggle-movement-tracking () + "Turn on and off `image-dired-track-movement'. +Tracking of the movements between thumbnail and Dired buffer so that +they are \"mirrored\" in the dired buffer. When this is on, moving +around in the thumbnail or dired buffer will find the matching +position in the other buffer." + (interactive) + (setq image-dired-track-movement (not image-dired-track-movement)) + (message "Movement tracking %s" (if image-dired-track-movement "on" "off"))) + +(defun image-dired-track-thumbnail () + "Track current Dired file's thumb in `image-dired-thumbnail-buffer'. +This is almost the same as what `image-dired-track-original-file' does, +but the other way around." + (let ((file (dired-get-filename)) + prop-val found window) + (when (get-buffer image-dired-thumbnail-buffer) + (with-current-buffer image-dired-thumbnail-buffer + (goto-char (point-min)) + (while (and (not (eobp)) + (not found)) + (if (and (setq prop-val + (get-text-property (point) 'original-file-name)) + (string= prop-val file)) + (setq found t)) + (if (not found) + (forward-char 1))) + (when found + (if (setq window (image-dired-thumbnail-window)) + (set-window-point window (point))) + (image-dired-update-header-line)))))) + +(defun image-dired-dired-next-line (&optional arg) + "Call `dired-next-line', then track thumbnail. +This can safely replace `dired-next-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-next-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired-dired-previous-line (&optional arg) + "Call `dired-previous-line', then track thumbnail. +This can safely replace `dired-previous-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-previous-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired--display-thumb-properties-fun () + (let ((old-buf (current-buffer)) + (old-point (point))) + (lambda () + (when (and (equal (current-buffer) old-buf) + (= (point) old-point)) + (ignore-errors + (image-dired-update-header-line)))))) + +(defun image-dired-forward-image (&optional arg wrap-around) + "Move to next image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move backwards. +On reaching end or beginning of buffer, stop and show a message. + +If optional argument WRAP-AROUND is non-nil, wrap around: if +point is on the last image, move to the last one and vice versa." + (interactive "p") + (setq arg (or arg 1)) + (let (pos) + (dotimes (_ (abs arg)) + (if (and (not (if (> arg 0) (eobp) (bobp))) + (save-excursion + (forward-char (if (> arg 0) 1 -1)) + (while (and (not (if (> arg 0) (eobp) (bobp))) + (not (image-dired-image-at-point-p))) + (forward-char (if (> arg 0) 1 -1))) + (setq pos (point)) + (image-dired-image-at-point-p))) + (progn (goto-char pos) + (image-dired-update-header-line)) + (if wrap-around + (progn (goto-char (if (> arg 0) + (point-min) + ;; There are two spaces after the last image. + (- (point-max) 2))) + (image-dired-update-header-line)) + (message "At %s image" (if (> arg 0) "last" "first")) + (run-at-time 1 nil (image-dired--display-thumb-properties-fun)))))) + (when image-dired-track-movement + (image-dired-track-original-file))) + +(defun image-dired-backward-image (&optional arg) + "Move to previous image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move forward. +On reaching end or beginning of buffer, stop and show a message." + (interactive "p") + (image-dired-forward-image (- (or arg 1)))) + +(defun image-dired-next-line () + "Move to next line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line 1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next thumbnail. + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + +(defun image-dired-previous-line () + "Move to previous line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line -1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next + ;; thumbnail. This should only happen if the user deleted a + ;; thumbnail and did not refresh, so it is not very common. But we + ;; can handle it in a good manner, so why not? + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-beginning-of-buffer () + "Move to the first image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-min)) + (while (and (not (image-at-point-p)) + (not (eobp))) + (forward-char 1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-end-of-buffer () + "Move to the last image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-max)) + (while (and (not (image-at-point-p)) + (not (bobp))) + (forward-char -1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-format-properties-string (buf file props comment) + "Format display properties. +BUF is the associated Dired buffer, FILE is the original image file +name, PROPS is a stringified list of tags and COMMENT is the image file's +comment." + (format-spec + image-dired-display-properties-format + (list + (cons ?b (or buf "")) + (cons ?f file) + (cons ?t (or props "")) + (cons ?c (or comment ""))))) + +(defun image-dired-update-header-line () + "Update image information in the header line." + (when (and (not (eobp)) + (memq major-mode '(image-dired-thumbnail-mode + image-dired-display-image-mode))) + (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) + (dired-buf (buffer-name (image-dired-associated-dired-buffer))) + (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (comment (get-text-property (point) 'comment)) + (message-log-max nil)) + (if file-name + (setq header-line-format + (image-dired-format-properties-string + dired-buf + file-name + props + comment)))))) + +(defun image-dired-dired-file-marked-p (&optional marker) + "In Dired, return t if file on current line is marked. +If optional argument MARKER is non-nil, it is a character to look +for. The default is to look for `dired-marker-char'." + (setq marker (or marker dired-marker-char)) + (save-excursion + (beginning-of-line) + (and (looking-at dired-re-mark) + (= (aref (match-string 0) 0) marker)))) + +(defun image-dired-dired-file-flagged-p () + "In Dired, return t if file on current line is flagged for deletion." + (image-dired-dired-file-marked-p dired-del-marker)) + +(defmacro image-dired--with-thumbnail-buffer (&rest body) + (declare (indent defun) (debug t)) + `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (if-let ((win (get-buffer-window buf))) + (with-selected-window win + ,@body) + ,@body)) + (user-error "No such buffer: %s" image-dired-thumbnail-buffer))) + +(defmacro image-dired--on-file-in-dired-buffer (&rest body) + "Run BODY with point on file at point in Dired buffer. +Should be called from commands in `image-dired-thumbnail-mode'." + (declare (indent defun) (debug t)) + `(let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + ,@body + (image-dired-thumb-update-marks)))))) + +(defmacro image-dired--do-mark-command (maybe-next &rest body) + "Helper macro for the mark, unmark and flag commands. +Run BODY in Dired buffer. +If optional argument MAYBE-NEXT is non-nil, show next image +according to `image-dired-marking-shows-next'." + (declare (indent defun) (debug t)) + `(image-dired--with-thumbnail-buffer + (image-dired--on-file-in-dired-buffer + ,@body) + ,(when maybe-next + '(if image-dired-marking-shows-next + (image-dired-display-next-thumbnail-original) + (image-dired-next-line))))) + +(defun image-dired-mark-thumb-original-file () + "Mark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-mark 1))) + +(defun image-dired-unmark-thumb-original-file () + "Unmark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-unmark 1))) + +(defun image-dired-flag-thumb-original-file () + "Flag original image file for deletion in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-flag-file-deletion 1))) + +(defun image-dired-toggle-mark-thumb-original-file () + "Toggle mark on original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1)))) + +(defun image-dired-unmark-all-marks () + "Remove all marks from all files in associated Dired buffer. +Also update the marks in the thumbnail buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (dired-unmark-all-marks)) + (image-dired--with-thumbnail-buffer + (image-dired-thumb-update-marks))) + +(defun image-dired-jump-original-dired-buffer () + "Jump to the Dired buffer associated with the current image file. +You probably want to use this together with +`image-dired-track-original-file'." + (interactive nil image-dired-thumbnail-mode) + (let ((buf (image-dired-associated-dired-buffer)) + window frame) + (setq window (image-dired-get-buffer-window buf)) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Associated dired buffer not visible")))) + +;;;###autoload +(defun image-dired-jump-thumbnail-buffer () + "Jump to thumbnail buffer." + (interactive) + (let ((window (image-dired-thumbnail-window)) + frame) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Thumbnail buffer not visible")))) + +(defvar image-dired-thumbnail-mode-line-up-map + (let ((map (make-sparse-keymap))) + ;; map it to "g" so that the user can press it more quickly + (define-key map "g" #'image-dired-line-up-dynamic) + ;; "f" for "fixed" number of thumbs per row + (define-key map "f" #'image-dired-line-up) + ;; "i" for "interactive" + (define-key map "i" #'image-dired-line-up-interactive) + map) + "Keymap for line-up commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-tag-map + (let ((map (make-sparse-keymap))) + ;; map it to "t" so that the user can press it more quickly + (define-key map "t" #'image-dired-tag-thumbnail) + ;; "r" for "remove" + (define-key map "r" #'image-dired-tag-thumbnail-remove) + map) + "Keymap for tag commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) + + (define-key map "<" #'image-dired-beginning-of-buffer) + (define-key map ">" #'image-dired-end-of-buffer) + (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) + (define-key map (kbd "M->") #'image-dired-end-of-buffer) + + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) + + ;; add line-up map + (define-key map "g" image-dired-thumbnail-mode-line-up-map) + ;; add tag map + (define-key map "t" image-dired-thumbnail-mode-tag-map) + + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) + + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) + + (define-key map "D" #'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) + + ;; Mouse + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail) + ;; Seems I must first set C-down-mouse-1 to undefined, or else it + ;; will trigger the buffer menu. If I try to instead bind + ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message + ;; about C-mouse-1 not being defined afterwards. Annoying, but I + ;; probably do not completely understand mouse events. + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) + map) + "Keymap for `image-dired-thumbnail-mode'.") + +(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map + "Menu for `image-dired-thumbnail-mode'." + '("Image-Dired" + ["Display image" image-dired-display-thumbnail-original-image] + ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] + "---" + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] + "---" + ["Rotate original right" image-dired-rotate-original-right] + ["Rotate original left" image-dired-rotate-original-left] + "---" + ["Comment thumbnail" image-dired-comment-thumbnail] + ["Tag current or marked thumbnails" image-dired-tag-thumbnail] + ["Remove tag from current or marked thumbnails" + image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] + "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) + ["Quit" quit-window])) + +(defvar image-dired-display-image-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "n" #'image-dired-display-next-thumbnail-original) + (define-key map "p" #'image-dired-display-previous-thumbnail-original) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + ;; Disable keybindings from `image-mode-map' that doesn't make sense here. + (define-key map "o" nil) ; image-save + map) + "Keymap for `image-dired-display-image-mode'.") + +(define-derived-mode image-dired-thumbnail-mode + special-mode "image-dired-thumbnail" + "Browse and manipulate thumbnail images using Dired. +Use `image-dired-minor-mode' to get a nice setup." + :interactive nil + (buffer-disable-undo) + (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) + (setq-local window-resize-pixelwise t) + (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record) + ;; Use approximately as much vertical spacing as horizontal. + (setq-local line-spacing (frame-char-width))) + + +;;; Display image mode + +(define-derived-mode image-dired-display-image-mode + image-mode "image-dired-image-display" + "Mode for displaying and manipulating original image. +Resized or in full-size." + :interactive nil + (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t)) + +(defvar image-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + ;; (set-keymap-parent map dired-mode-map) + ;; Hijack previous and next line movement. Let C-p and C-b be + ;; though... + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) + map) + "Keymap for `image-dired-minor-mode'.") + +(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map + "Menu for `image-dired-minor-mode'." + '("Image-dired" + ["Display thumb for next file" image-dired-next-line-and-display] + ["Display thumb for previous file" image-dired-previous-line-and-display] + ["Mark and display next" image-dired-mark-and-display-next] + "---" + ["Create thumbnails for marked files" image-dired-create-thumbs] + "---" + ["Display thumbnails append" image-dired-display-thumbs-append] + ["Display this thumbnail" image-dired-display-thumb] + ["Display image" image-dired-dired-display-image] + ["Display in external viewer" image-dired-dired-display-external] + "---" + ["Toggle display properties" image-dired-toggle-dired-display-properties + :style toggle + :selected image-dired-dired-disp-props] + ["Toggle append browsing" image-dired-toggle-append-browsing + :style toggle + :selected image-dired-append-when-browsing] + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] + ["Mark tagged files" image-dired-mark-tagged-files] + ["Comment files" image-dired-dired-comment-files] + ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + +;;;###autoload +(define-minor-mode image-dired-minor-mode + "Setup easy-to-use keybindings for the commands to be used in Dired mode. +Note that n, p and and will be hijacked and bound to +`image-dired-dired-next-line' and `image-dired-dired-previous-line'." + :keymap image-dired-minor-mode-map) + +(declare-function clear-image-cache "image.c" (&optional filter)) + +(defun image-dired-create-thumbs (&optional arg) + "Create thumbnail images for all marked files in Dired. +With prefix argument ARG, create thumbnails even if they already exist +\(i.e. use this to refresh your thumbnails)." + (interactive "P") + (let (thumb-name) + (dolist (curr-file (dired-get-marked-files)) + (setq thumb-name (image-dired-thumb-name curr-file)) + ;; If the user overrides the exist check, we must clear the + ;; image cache so that if the user wants to display the + ;; thumbnail, it is not fetched from cache. + (when arg + (clear-image-cache (expand-file-name thumb-name))) + (when (or (not (file-exists-p thumb-name)) + arg) + (image-dired-create-thumb curr-file thumb-name))))) + + +;;; Slideshow + +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") + +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") + +(defvar image-dired--slideshow-initial nil) + +(defun image-dired-slideshow-step () + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) + (image-dired-slideshow-stop))) + +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow, waiting `image-dired-slideshow-delay' between images. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (not arg) + image-dired-slideshow-delay + (if (> arg 0) + arg + (string-to-number + (let ((delay (number-to-string image-dired-slideshow-delay))) + (read-string + (format-prompt "Delay, in seconds. Decimals are accepted" delay)) + delay)))))) + (setq image-dired--slideshow-timer + (run-with-timer + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) + +(defun image-dired-slideshow-stop () + "Cancel slideshow." + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) + + +;;; Thumbnail mode (cont. 3) + +(defun image-dired-delete-char () + "Remove current thumbnail from thumbnail buffer and line up." + (interactive nil image-dired-thumbnail-mode) + (let ((inhibit-read-only t)) + (delete-char 1) + (when (= (following-char) ?\s) + (delete-char 1)))) + +;;;###autoload +(defun image-dired-display-thumbs-append () + "Append thumbnails to `image-dired-thumbnail-buffer'." + (interactive) + (image-dired-display-thumbs nil t t)) + +;;;###autoload +(defun image-dired-display-thumb () + "Shorthand for `image-dired-display-thumbs' with prefix argument." + (interactive) + (image-dired-display-thumbs t nil t)) + +(defun image-dired-line-up () + "Line up thumbnails according to `image-dired-thumbs-per-row'. +See also `image-dired-line-up-dynamic'." + (interactive) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1)) + (while (not (eobp)) + (forward-char) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1))) + (goto-char (point-min)) + (let ((seen 0) + (thumb-prev-pos 0) + (thumb-width-chars + (ceiling (/ (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width)) + (float (frame-char-width)))))) + (while (not (eobp)) + (forward-char) + (if (= image-dired-thumbs-per-row 1) + (insert "\n") + (cl-incf thumb-prev-pos thumb-width-chars) + (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos))) + (cl-incf seen) + (when (and (= seen (- image-dired-thumbs-per-row 1)) + (not (eobp))) + (forward-char) + (insert "\n") + (setq seen 0) + (setq thumb-prev-pos 0))))) + (goto-char (point-min)))) + +(defun image-dired-line-up-dynamic () + "Line up thumbnails images dynamically. +Calculate how many thumbnails fit." + (interactive) + (let* ((char-width (frame-char-width)) + (width (image-dired-window-width-pixels (image-dired-thumbnail-window))) + (image-dired-thumbs-per-row + (/ width + (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width) + char-width)))) + (image-dired-line-up))) + +(defun image-dired-line-up-interactive () + "Line up thumbnails interactively. +Ask user how many thumbnails should be displayed per row." + (interactive) + (let ((image-dired-thumbs-per-row + (string-to-number (read-string "How many thumbs per row: ")))) + (if (not (> image-dired-thumbs-per-row 0)) + (message "Number must be greater than 0") + (image-dired-line-up)))) + +(defun image-dired-thumbnail-display-external () + "Display original image for thumbnail at point using external viewer." + (interactive) + (let ((file (image-dired-original-file-name))) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (start-process "image-dired-thumb-external" nil + image-dired-external-viewer file))))) + +;;;###autoload +(defun image-dired-dired-display-external () + "Display file at point using an external viewer." + (interactive) + (let ((file (dired-get-filename))) + (start-process "image-dired-external" nil + image-dired-external-viewer file))) + +(defun image-dired-window-width-pixels (window) + "Calculate WINDOW width in pixels." + (* (window-width window) (frame-char-width))) + +(defun image-dired-display-window () + "Return window where `image-dired-display-image-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer)) + nil t)) + +(defun image-dired-thumbnail-window () + "Return window where `image-dired-thumbnail-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer)) + nil t)) + +(defun image-dired-associated-dired-buffer-window () + "Return window where associated Dired buffer is visible." + (let (buf) + (if (image-dired-image-at-point-p) + (progn + (setq buf (image-dired-associated-dired-buffer)) + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)))) + (error "No thumbnail image at point")))) + +(defun image-dired-display-image (file &optional _ignored) + "Display image FILE in image buffer. +Use this when you want to display the image, in a new window. +The window will use `image-dired-display-image-mode' which is +based on `image-mode'." + (declare (advertised-calling-convention (file) "29.1")) + (setq file (expand-file-name file)) + (when (not (file-exists-p file)) + (error "No such file: %s" file)) + (let ((buf (get-buffer image-dired-display-image-buffer)) + (cur-win (selected-window))) + (when buf + (kill-buffer buf)) + (when-let ((buf (find-file-noselect file nil t))) + (pop-to-buffer buf) + (rename-buffer image-dired-display-image-buffer) + (image-dired-display-image-mode) + (select-window cur-win)))) + +(defun image-dired-display-thumbnail-original-image (&optional arg) + "Display current thumbnail's original image in display buffer. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (let ((file (image-dired-original-file-name))) + (if (not (string-equal major-mode "image-dired-thumbnail-mode")) + (message "Not in image-dired-thumbnail-mode") + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (image-dired-display-image file arg)))))) + + +;;;###autoload +(defun image-dired-dired-display-image (&optional arg) + "Display current image file. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (image-dired-display-image (dired-get-filename) arg)) + +(defun image-dired-image-at-point-p () + "Return non-nil if there is an `image-dired' thumbnail at point." + (get-text-property (point) 'image-dired-thumbnail)) + +(defun image-dired-refresh-thumb () + "Force creation of new image for current thumbnail." + (interactive nil image-dired-thumbnail-mode) + (let* ((file (image-dired-original-file-name)) + (thumb (expand-file-name (image-dired-thumb-name file)))) + (clear-image-cache (expand-file-name thumb)) + (image-dired-create-thumb file thumb))) + +(defun image-dired-rotate-original (degrees) + "Rotate original image DEGREES degrees." + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-original-program) + (if (not (image-dired-image-at-point-p)) + (message "No image at point") + (let* ((file (image-dired-original-file-name)) + (spec + (list + (cons ?d degrees) + (cons ?o (expand-file-name file)) + (cons ?t image-dired-temp-rotate-image-file)))) + (unless (eq 'jpeg (image-type file)) + (user-error "Only JPEG images can be rotated")) + (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program + nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-original-options)))) + (error "Could not rotate image") + (image-dired-display-image image-dired-temp-rotate-image-file) + (if (or (and image-dired-rotate-original-ask-before-overwrite + (y-or-n-p + "Rotate to temp file OK. Overwrite original image? ")) + (not image-dired-rotate-original-ask-before-overwrite)) + (progn + (copy-file image-dired-temp-rotate-image-file file t) + (image-dired-refresh-thumb)) + (image-dired-display-image file)))))) + +(defun image-dired-rotate-original-left () + "Rotate original image left (counter clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "270")) + +(defun image-dired-rotate-original-right () + "Rotate original image right (clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "90")) + + +;;; EXIF support + +(defun image-dired-get-exif-file-name (file) + "Use the image's EXIF information to return a unique file name. +The file name should be unique as long as you do not take more than +one picture per second. The original file name is suffixed at the end +for traceability. The format of the returned file name is +YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from +`image-dired-copy-with-exif-file-name'." + (let (data no-exif-data-found) + (if (not (eq 'jpeg (image-type (expand-file-name file)))) + (setq no-exif-data-found t + data (format-time-string + "%Y:%m:%d %H:%M:%S" + (file-attribute-modification-time + (file-attributes (expand-file-name file))))) + (setq data (exif-field 'date-time (exif-parse-file + (expand-file-name file))))) + (while (string-match "[ :]" data) + (setq data (replace-match "_" nil nil data))) + (format "%s%s%s" data + (if no-exif-data-found + "_noexif_" + "_") + (file-name-nondirectory file)))) + +(defun image-dired-thumbnail-set-image-description () + "Set the ImageDescription EXIF tag for the original image. +If the image already has a value for this tag, it is used as the +default value at the prompt." + (interactive) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-original-file-name)) + (old-value (or (exif-field 'description (exif-parse-file file)) ""))) + (if (eq 0 + (image-dired-set-exif-data file "ImageDescription" + (read-string "Value of ImageDescription: " + old-value))) + (message "Successfully wrote ImageDescription tag") + (error "Could not write ImageDescription tag"))))) + +(defun image-dired-set-exif-data (file tag-name tag-value) + "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE." + (image-dired--check-executable-exists + 'image-dired-cmd-write-exif-data-program) + (let ((spec + (list + (cons ?f (expand-file-name file)) + (cons ?t tag-name) + (cons ?v tag-value)))) + (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-write-exif-data-options)))) + +(defun image-dired-copy-with-exif-file-name () + "Copy file with unique name to main image directory. +Copy current or all marked files in Dired to a new file in your +main image directory, using a file name generated by +`image-dired-get-exif-file-name'. A typical usage for this if when +copying images from a digital camera into the image directory. + + Typically, you would open up the folder with the incoming +digital images, mark the files to be copied, and execute this +function. The result is a couple of new files in +`image-dired-main-image-directory' called +2005_05_08_12_52_00_dscn0319.jpg, +2005_05_08_14_27_45_dscn0320.jpg etc." + (interactive) + (let (new-name + (files (dired-get-marked-files))) + (mapc + (lambda (curr-file) + (setq new-name + (format "%s/%s" + (file-name-as-directory + (expand-file-name image-dired-main-image-directory)) + (image-dired-get-exif-file-name curr-file))) + (message "Copying %s to %s" curr-file new-name) + (copy-file curr-file new-name)) + files))) + +;;; Thumbnail mode (cont.) + +(defun image-dired-display-next-thumbnail-original (&optional arg) + "Move to the next image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--with-thumbnail-buffer + (image-dired-forward-image arg t) + (image-dired-display-thumbnail-original-image))) + +(defun image-dired-display-previous-thumbnail-original (arg) + "Move to the previous image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired-display-next-thumbnail-original (- arg))) + + +;;; Image Comments + +(defun image-dired-write-comments (file-comments) + "Write file comments to database. +Write file comments to one or more files. +FILE-COMMENTS is an alist on the following form: + ((FILE . COMMENT) ... )" + (image-dired-sane-db-file) + (let (end comment-beg-pos comment-end-pos file comment) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-comments) + (setq file (car elt) + comment (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + ;; Delete old comment, if any + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (match-beginning 0)) + ;; Any tags after the comment? + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + ;; Delete comment tag and comment + (delete-region comment-beg-pos comment-end-pos)) + ;; Insert new comment + (beginning-of-line) + (unless (search-forward ";" end t) + (end-of-line) + (insert ";")) + (insert (format "comment:%s;" comment))) + ;; File does not exist in database - add it. + (goto-char (point-max)) + (insert (format "%s;comment:%s\n" file comment)))) + (save-buffer)))) + +(defun image-dired-update-property (prop value) + "Update text property PROP with value VALUE at point." + (let ((inhibit-read-only t)) + (put-text-property + (point) (1+ (point)) + prop + value))) + +;;;###autoload +(defun image-dired-dired-comment-files () + "Add comment to current or marked files in Dired." + (interactive) + (let ((comment (image-dired-read-comment))) + (image-dired-write-comments + (mapcar + (lambda (curr-file) + (cons curr-file comment)) + (dired-get-marked-files))))) + +(defun image-dired-comment-thumbnail () + "Add comment to current thumbnail in thumbnail buffer." + (interactive) + (let* ((file (image-dired-original-file-name)) + (comment (image-dired-read-comment file))) + (image-dired-write-comments (list (cons file comment))) + (image-dired-update-property 'comment comment)) + (image-dired-update-header-line)) + +(defun image-dired-read-comment (&optional file) + "Read comment for an image. +Optionally use old comment from FILE as initial value." + (let ((comment + (read-string + "Comment: " + (if file (image-dired-get-comment file))))) + comment)) + +(defun image-dired-get-comment (file) + "Get comment for file FILE." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end comment-beg-pos comment-end-pos comment) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (point)) + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + (setq comment (buffer-substring + comment-beg-pos comment-end-pos)))) + comment))) + +;;;###autoload +(defun image-dired-mark-tagged-files (regexp) + "Use REGEXP to mark files with matching tag. +A `tag' is a keyword, a piece of meta data, associated with an +image file and stored in image-dired's database file. This command +lets you input a regexp and this will be matched against all tags +on all image files in the database file. The files that have a +matching tag will be marked in the Dired buffer." + (interactive "sMark tagged files (regexp): ") + (image-dired-sane-db-file) + (let ((hits 0) + files) + (image-dired--with-db-file + ;; Collect matches + (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t) + (let ((file (match-string 1)) + (tags (split-string (match-string 2) ";"))) + (when (seq-find (lambda (tag) + (string-match-p regexp tag)) + tags) + (push file files))))) + ;; Mark files + (dolist (curr-file files) + ;; I tried using `dired-mark-files-regexp' but it was waaaay to + ;; slow. Don't bother about hits found in other directories + ;; than the current one. + (when (string= (file-name-as-directory + (expand-file-name default-directory)) + (file-name-as-directory + (file-name-directory curr-file))) + (setq curr-file (file-name-nondirectory curr-file)) + (goto-char (point-min)) + (when (search-forward-regexp (format "\\s %s$" curr-file) nil t) + (setq hits (+ hits 1)) + (dired-mark 1)))) + (message "%d files with matching tag marked" hits))) + + + +;;; Mouse support + +(defun image-dired-mouse-display-image (event) + "Use mouse EVENT, call `image-dired-display-image' to display image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (let ((file (image-dired-original-file-name))) + (when file + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-display-image file)))) + +(defun image-dired-mouse-select-thumbnail (event) + "Use mouse EVENT to select thumbnail image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + + +;;; Dired marks and tags + +(defun image-dired-thumb-file-marked-p (&optional flagged) + "Check if file is marked in associated Dired buffer. +If optional argument FLAGGED is non-nil, check if file is flagged +for deletion instead." + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (when (and dired-buf file-name) + (with-current-buffer dired-buf + (save-excursion + (when (dired-goto-file file-name) + (if flagged + (image-dired-dired-file-flagged-p) + (image-dired-dired-file-marked-p)))))))) + +(defun image-dired-thumb-file-flagged-p () + "Check if file is flagged for deletion in associated Dired buffer." + (image-dired-thumb-file-marked-p t)) + +(defun image-dired-delete-marked () + "Delete current or marked thumbnails and associated images." + (interactive) + (image-dired--with-marked + (image-dired-delete-char) + (unless (bobp) + (backward-char))) + (image-dired--line-up-with-method) + (with-current-buffer (image-dired-associated-dired-buffer) + (dired-do-delete))) + +(defun image-dired-thumb-update-marks () + "Update the marks in the thumbnail buffer." + (when image-dired-thumb-visible-marks + (with-current-buffer image-dired-thumbnail-buffer + (save-mark-and-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (while (not (eobp)) + (with-silent-modifications + (cond ((image-dired-thumb-file-marked-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-mark)) + ((image-dired-thumb-file-flagged-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-flagged)) + (t (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))))) + (forward-char))))))) + +(defun image-dired-mouse-toggle-mark-1 () + "Toggle Dired mark for current thumbnail. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-toggle-mark-thumb-original-file)) + +(defun image-dired-mouse-toggle-mark (event) + "Use mouse EVENT to toggle Dired mark for thumbnail. +Toggle marks of all thumbnails in region, if it's active. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (interactive "e") + (if (use-region-p) + (let ((end (region-end))) + (save-excursion + (goto-char (region-beginning)) + (while (<= (point) end) + (when (image-dired-image-at-point-p) + (image-dired-mouse-toggle-mark-1)) + (forward-char)))) + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (image-dired-mouse-toggle-mark-1)) + (image-dired-thumb-update-marks)) + +(defun image-dired-dired-display-properties () + "Display properties for Dired file in the echo area." + (interactive) + (let* ((file (dired-get-filename)) + (file-name (file-name-nondirectory file)) + (dired-buf (buffer-name (current-buffer))) + (props (mapconcat #'identity (image-dired-list-tags file) ", ")) + (comment (image-dired-get-comment file)) + (message-log-max nil)) + (if file-name + (message "%s" + (image-dired-format-properties-string + dired-buf + file-name + props + comment))))) + + + +;;; Gallery support + +;; TODO: +;; * Support gallery creation when using per-directory thumbnail +;; storage. +;; * Enhanced gallery creation with basic CSS-support and pagination +;; of tag pages with many pictures. + +(defgroup image-dired-gallery nil + "Image-Dired support for generating a HTML gallery." + :prefix "image-dired-" + :group 'image-dired + :version "29.1") + +(defcustom image-dired-gallery-dir + (expand-file-name ".image-dired_gallery" image-dired-dir) + "Directory to store generated gallery html pages. +The name of this directory needs to be \"shared\" to the public +so that it can access the index.html page that image-dired creates." + :type 'directory) + +(defcustom image-dired-gallery-image-root-url + "https://example.org/image-diredpics" + "URL where the full size images are to be found on your web server. +Note that this URL has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-thumb-image-root-url + "https://example.org/image-diredthumbs" + "URL where the thumbnail images are to be found on your web server. +Note that URL path has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-hidden-tags + (list "private" "hidden" "pending") + "List of \"hidden\" tags. +Used by `image-dired-gallery-generate' to leave out \"hidden\" images." + :type '(repeat string)) + +(defvar image-dired-tag-file-list nil + "List to store tag-file structure.") + +(defvar image-dired-file-tag-list nil + "List to store file-tag structure.") + +(defvar image-dired-file-comment-list nil + "List to store file comments.") + +(defun image-dired--add-to-tag-file-lists (tag file) + "Helper function used from `image-dired--create-gallery-lists'. + +Add TAG to FILE in one list and FILE to TAG in the other. + +Lisp structures look like the following: + +image-dired-file-tag-list: + + ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...) + (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...) + ...) + +image-dired-tag-file-list: + + ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...) + (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...) + ...)" + ;; Add tag to file list + (let (curr) + (if image-dired-file-tag-list + (if (setq curr (assoc file image-dired-file-tag-list)) + (setcdr curr (cons tag (cdr curr))) + (setcdr image-dired-file-tag-list + (cons (list file tag) (cdr image-dired-file-tag-list)))) + (setq image-dired-file-tag-list (list (list file tag)))) + ;; Add file to tag list + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired--add-to-file-comment-list (file comment) + "Helper function used from `image-dired--create-gallery-lists'. + +For FILE, add COMMENT to list. + +Lisp structure looks like the following: + +image-dired-file-comment-list: + + ((\"filename1\" . \"comment1\") + (\"filename2\" . \"comment2\") + ...)" + (if image-dired-file-comment-list + (if (not (assoc file image-dired-file-comment-list)) + (setcdr image-dired-file-comment-list + (cons (cons file comment) + (cdr image-dired-file-comment-list)))) + (setq image-dired-file-comment-list (list (cons file comment))))) + +(defun image-dired--create-gallery-lists () + "Create temporary lists used by `image-dired-gallery-generate'." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end beg file row-tags) + (setq image-dired-tag-file-list nil) + (setq image-dired-file-tag-list nil) + (setq image-dired-file-comment-list nil) + (goto-char (point-min)) + (while (search-forward-regexp "^." nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (setq beg (point)) + (unless (search-forward ";" end nil) + (error "Something is really wrong, check format of database")) + (setq row-tags (split-string + (buffer-substring beg end) ";")) + (setq file (car row-tags)) + (dolist (x (cdr row-tags)) + (if (not (string-match "^comment:\\(.*\\)" x)) + (image-dired--add-to-tag-file-lists x file) + (image-dired--add-to-file-comment-list file (match-string 1 x))))))) + ;; Sort tag-file list + (setq image-dired-tag-file-list + (sort image-dired-tag-file-list + (lambda (x y) + (string< (car x) (car y)))))) + +(defun image-dired--hidden-p (file) + "Return t if image FILE has a \"hidden\" tag." + (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list)) + if (member tag image-dired-gallery-hidden-tags) return t)) + +(defun image-dired-gallery-generate () + "Generate gallery pages. +First we create a couple of Lisp structures from the database to make +it easier to generate, then HTML-files are created in +`image-dired-gallery-dir'." + (interactive) + (if (eq 'per-directory image-dired-thumbnail-storage) + (error "Currently, gallery generation is not supported \ +when using per-directory thumbnail file storage")) + (image-dired--create-gallery-lists) + (let ((tags image-dired-tag-file-list) + (index-file (format "%s/index.html" image-dired-gallery-dir)) + count tag tag-file + comment file-tags tag-link tag-link-list) + ;; Make sure gallery root exist + (if (file-exists-p image-dired-gallery-dir) + (if (not (file-directory-p image-dired-gallery-dir)) + (error "Variable image-dired-gallery-dir is not a directory")) + ;; FIXME: Should we set umask to 077 here, as we do for thumbnails? + (make-directory image-dired-gallery-dir)) + ;; Open index file + (with-temp-file index-file + (if (file-exists-p index-file) + (insert-file-contents index-file)) + (insert "\n") + (insert " \n") + (insert "

Image-Dired Gallery

\n") + (insert (format "

\n Gallery generated %s\n

\n" + (current-time-string))) + (insert "

Tag index

\n") + (setq count 1) + ;; Pre-generate list of all tag links + (dolist (curr tags) + (setq tag (car curr)) + (when (not (member tag image-dired-gallery-hidden-tags)) + (setq tag-link (format "%s" count tag)) + (if tag-link-list + (setq tag-link-list + (append tag-link-list (list (cons tag tag-link)))) + (setq tag-link-list (list (cons tag tag-link)))) + (setq count (1+ count)))) + (setq count 1) + ;; Main loop where we generated thumbnail pages per tag + (dolist (curr tags) + (setq tag (car curr)) + ;; Don't display hidden tags + (when (not (member tag image-dired-gallery-hidden-tags)) + ;; Insert link to tag page in index + (insert (format " %s
\n" (cdr (assoc tag tag-link-list)))) + ;; Open per-tag file + (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count)) + (with-temp-file tag-file + (if (file-exists-p tag-file) + (insert-file-contents tag-file)) + (erase-buffer) + (insert "\n") + (insert " \n") + (insert "

Index

\n") + (insert (format "

Images with tag "%s"

" tag)) + ;; Main loop for files per tag page + (dolist (file (cdr curr)) + (unless (image-dired-hidden-p file) + ;; Insert thumbnail with link to full image + (insert + (format "\n" + image-dired-gallery-image-root-url + (file-name-nondirectory file) + image-dired-gallery-thumb-image-root-url + (file-name-nondirectory (image-dired-thumb-name file)) file)) + ;; Insert comment, if any + (if (setq comment (cdr (assoc file image-dired-file-comment-list))) + (insert (format "
\n%s
\n" comment)) + (insert "
\n")) + ;; Insert links to other tags, if any + (when (> (length + (setq file-tags (assoc file image-dired-file-tag-list))) 2) + (insert "[ ") + (dolist (extra-tag file-tags) + ;; Only insert if not file name or the main tag + (if (and (not (equal extra-tag tag)) + (not (equal extra-tag file))) + (insert + (format "%s " (cdr (assoc extra-tag tag-link-list)))))) + (insert "]
\n")))) + (insert "

Index

\n") + (insert " \n") + (insert "\n")) + (setq count (1+ count)))) + (insert " \n") + (insert "")))) + + +;;; Tag support + +(defvar image-dired-widget-list nil + "List to keep track of meta data in edit buffer.") + +(declare-function widget-forward "wid-edit" (arg)) + +;;;###autoload +(defun image-dired-dired-edit-comment-and-tags () + "Edit comment and tags of current or marked image files. +Edit comment and tags for all marked image files in an +easy-to-use form." + (interactive) + (setq image-dired-widget-list nil) + ;; Setup buffer. + (let ((files (dired-get-marked-files))) + (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*") + (kill-all-local-variables) + (let ((inhibit-read-only t)) + (erase-buffer)) + (remove-overlays) + ;; Some help for the user. + (widget-insert +"\nEdit comments and tags for each image. Separate multiple tags +with a comma. Move forward between fields using TAB or RET. +Move to the previous field using backtab (S-TAB). Save by +activating the Save button at the bottom of the form or cancel +the operation by activating the Cancel button.\n\n") + ;; Here comes all images and a comment and tag field for each + ;; image. + (let (thumb-file img comment-widget tag-widget) + + (dolist (file files) + + (setq thumb-file (image-dired-thumb-name file) + img (create-image thumb-file)) + + (insert-image img) + (widget-insert "\n\nComment: ") + (setq comment-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (image-dired-get-comment file) ""))) + (widget-insert "\nTags: ") + (setq tag-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (mapconcat + #'identity + (image-dired-list-tags file) + ",") ""))) + ;; Save information in all widgets so that we can use it when + ;; the user saves the form. + (setq image-dired-widget-list + (append image-dired-widget-list + (list (list file comment-widget tag-widget)))) + (widget-insert "\n\n"))) + + ;; Footer with Save and Cancel button. + (widget-insert "\n") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (image-dired-save-information-from-widgets) + (bury-buffer) + (message "Done")) + "Save") + (widget-insert " ") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (bury-buffer) + (message "Operation canceled")) + "Cancel") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + ;; Jump to the first widget. + (widget-forward 1))) + +(defun image-dired-save-information-from-widgets () + "Save information found in `image-dired-widget-list'. +Use the information in `image-dired-widget-list' to save comments and +tags to their respective image file. Internal function used by +`image-dired-dired-edit-comment-and-tags'." + (let (file comment tag-string tag-list lst) + (image-dired-write-comments + (mapcar + (lambda (widget) + (setq file (car widget) + comment (widget-value (cadr widget))) + (cons file comment)) + image-dired-widget-list)) + (image-dired-write-tags + (dolist (widget image-dired-widget-list lst) + (setq file (car widget) + tag-string (widget-value (car (cddr widget))) + tag-list (split-string tag-string ",")) + (dolist (tag tag-list) + (push (cons file tag) lst)))))) + + +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun image-dired-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (file-name-nondirectory + (directory-file-name + (file-name-directory (image-dired-original-file-name))))) + +(defun image-dired-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(image-dired-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(file-name-directory (image-dired-original-file-name))) + (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name))) + (handler . image-dired-bookmark-jump))) + +;;;###autoload +(defun image-dired-bookmark-jump (bookmark) + "Default bookmark handler for Image-Dired buffers." + ;; User already cached thumbnails, so disable any checking. + (let ((image-dired-show-all-from-dir-max-files nil)) + (image-dired (bookmark-prop-get bookmark 'location)) + ;; TODO: Go to the bookmarked file, if it exists. + ;; (bookmark-prop-get bookmark 'image-dired-file) + (goto-char (point-min)))) + +(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired") + +;;; Obsolete + +;;;###autoload +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +;;;###autoload +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings + #'image-dired-minor-mode "26.1") + +(defcustom image-dired-temp-image-file + (expand-file-name ".image-dired_temp" image-dired-dir) + "Name of temporary image file used by various commands." + :type 'file) +(make-obsolete-variable 'image-dired-temp-image-file + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-program + (if (executable-find "gm") "gm" "convert") + "Executable used to create temporary image. +Used together with `image-dired-cmd-create-temp-image-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-create-temp-image-program + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) + "Options of command used to create temporary image for display window. +Used together with `image-dired-cmd-create-temp-image-program', +Available format specifiers are: %w and %h which are replaced by +the calculated max size for width and height in the image display window, +%f which is replaced by the file name of the original image and %t which +is replaced by the file name of the temporary file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-create-temp-image-options + "no longer used." "29.1") + +(defcustom image-dired-display-window-width-correction 1 + "Number to be used to correct image display window width. +Change if the default (1) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-width-correction + "no longer used." "29.1") + +(defcustom image-dired-display-window-height-correction 0 + "Number to be used to correct image display window height. +Change if the default (0) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-height-correction + "no longer used." "29.1") + +(defun image-dired-display-window-width (window) + "Return width, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-width-pixels window) + image-dired-display-window-width-correction)) + +(defun image-dired-display-window-height (window) + "Return height, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-height-pixels window) + image-dired-display-window-height-correction)) + +(defun image-dired-window-height-pixels (window) + "Calculate WINDOW height in pixels." + (declare (obsolete nil "29.1")) + ;; Note: The mode-line consumes one line + (* (- (window-height window) 1) (frame-char-height))) + +(defcustom image-dired-cmd-read-exif-data-program "exiftool" + "Program used to read EXIF data to image. +Used together with `image-dired-cmd-read-exif-data-options'." + :type 'file) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-program + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f") + "Arguments of command used to read EXIF data. +Used with `image-dired-cmd-read-exif-data-program'. +Available format specifiers are: %f which is replaced +by the image file name and %t which is replaced by the tag name." + :version "26.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-options + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defun image-dired-get-exif-data (file tag-name) + "From FILE, return EXIF tag TAG-NAME." + (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-read-exif-data-program) + (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) + (spec (list (cons ?f file) (cons ?t tag-name))) + tag-value) + (with-current-buffer buf + (delete-region (point-min) (point-max)) + (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program + nil t nil + (mapcar + (lambda (arg) (format-spec arg spec)) + image-dired-cmd-read-exif-data-options)) + 0)) + (error "Could not get EXIF tag") + (goto-char (point-min)) + ;; Clean buffer from newlines and carriage returns before + ;; getting final info + (while (search-forward-regexp "[\n\r]" nil t) + (replace-match "" nil t)) + (setq tag-value (buffer-substring (point-min) (point-max))))) + tag-value)) + +(defcustom image-dired-cmd-rotate-thumbnail-program + (if (executable-find "gm") "gm" "mogrify") + "Executable used to rotate thumbnail. +Used together with `image-dired-cmd-rotate-thumbnail-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1") + +(defcustom image-dired-cmd-rotate-thumbnail-options + (let ((opts '("-rotate" "%d" "%t"))) + (if (executable-find "gm") (cons "mogrify" opts) opts)) + "Arguments of command used to rotate thumbnail image. +Used with `image-dired-cmd-rotate-thumbnail-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or 270 +\(for 90 degrees right and left), %t which is replaced by the file name +of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") + +(defun image-dired-rotate-thumbnail (degrees) + "Rotate thumbnail DEGREES degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-thumbnail-program) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) + (thumb (expand-file-name file)) + (spec (list (cons ?d degrees) (cons ?t thumb)))) + (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-thumbnail-options)) + (clear-image-cache thumb)))) + +(defun image-dired-rotate-thumbnail-left () + "Rotate thumbnail left (counter clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "270"))) + +(defun image-dired-rotate-thumbnail-right () + "Rotate thumbnail counter right (clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "90"))) + +(defun image-dired-modify-mark-on-thumb-original-file (command) + "Modify mark in Dired buffer. +COMMAND is one of `mark' for marking file in Dired, `unmark' for +unmarking file in Dired or `flag' for flagging file for delete in +Dired." + (declare (obsolete image-dired--on-file-in-dired-buffer "29.1")) + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (message "%s" file-name) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) + +(defun image-dired-display-current-image-full () + "Display current image in full size." + (declare (obsolete image-transform-original "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file) + (with-current-buffer image-dired-display-image-buffer + (image-transform-original))) + (error "No original file name at point")))) + +(defun image-dired-display-current-image-sized () + "Display current image in sized to fit window dimensions." + (declare (obsolete image-mode-fit-frame "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file)) + (error "No original file name at point")))) + +(defun image-dired-add-to-tag-file-list (tag file) + "Add relation between TAG and FILE." + (declare (obsolete nil "29.1")) + (let (curr) + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired-display-thumb-properties () + "Display thumbnail properties in the echo area." + (declare (obsolete image-dired-update-header-line "29.1")) + (image-dired-update-header-line)) + +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + +(define-obsolete-function-alias 'image-dired-create-display-image-buffer + #'ignore "29.1") +(define-obsolete-function-alias 'image-dired-create-gallery-lists + #'image-dired--create-gallery-lists "29.1") +(define-obsolete-function-alias 'image-dired-add-to-file-comment-list + #'image-dired--add-to-file-comment-list "29.1") +(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists + #'image-dired--add-to-tag-file-lists "29.1") +(define-obsolete-function-alias 'image-dired-hidden-p + #'image-dired--hidden-p "29.1") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;; TEST-SECTION ;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defvar image-dired-dir-max-size 12300000) + +;; (defun image-dired-test-clean-old-files () +;; "Clean `image-dired-dir' from old thumbnail files. +;; \"Oldness\" measured using last access time. If the total size of all +;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size', +;; old files are deleted until the max size is reached." +;; (let* ((files +;; (sort +;; (mapcar +;; (lambda (f) +;; (let ((fattribs (file-attributes f))) +;; `(,(file-attribute-access-time fattribs) +;; ,(file-attribute-size fattribs) ,f))) +;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$")) +;; ;; Sort function. Compare time between two files. +;; (lambda (l1 l2) +;; (time-less-p (car l1) (car l2))))) +;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files)))) +;; (while (> dirsize image-dired-dir-max-size) +;; (y-or-n-p +;; (format "Size of thumbnail directory: %d, delete old file %s? " +;; dirsize (cadr (cdar files)))) +;; (delete-file (cadr (cdar files))) +;; (setq dirsize (- dirsize (car (cdar files)))) +;; (setq files (cdr files))))) + +(provide 'image-dired) + +;;; image-dired.el ends here diff --git a/lisp/image/image-dired.el b/lisp/image/image-dired.el new file mode 100644 index 00000000000..9f12354111c --- /dev/null +++ b/lisp/image/image-dired.el @@ -0,0 +1,3080 @@ +;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- + +;; Copyright (C) 2005-2022 Free Software Foundation, Inc. + +;; Version: 0.4.11 +;; Keywords: multimedia +;; Author: Mathias Dahl + +;; 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 . + +;;; Commentary: + +;; BACKGROUND +;; ========== +;; +;; I needed a program to browse, organize and tag my pictures. I got +;; tired of the old gallery program I used as it did not allow +;; multi-file operations easily. Also, it put things out of my +;; control. Image viewing programs I tested did not allow multi-file +;; operations or did not do what I wanted it to. +;; +;; So, I got the idea to use the wonderful functionality of Emacs and +;; `dired' to do it. It would allow me to do almost anything I wanted, +;; which is basically just to browse all my pictures in an easy way, +;; letting me manipulate and tag them in various ways. `dired' already +;; provide all the file handling and navigation facilities; I only +;; needed to add some functions to display the images. +;; +;; I briefly tried out thumbs.el, and although it seemed more +;; powerful than this package, it did not work the way I wanted to. It +;; was too slow to create thumbnails of all files in a directory (I +;; currently keep all my 2000+ images in the same directory) and +;; browsing the thumbnail buffer was slow too. image-dired.el will not +;; create thumbnails until they are needed and the browsing is done +;; quickly and easily in Dired. I copied a great deal of ideas and +;; code from there though... :) +;; +;; `image-dired' stores the thumbnail files in `image-dired-dir' +;; using the file name format ORIGNAME.thumb.ORIGEXT. For example +;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for +;; now just a plain text file with the following format: +;; +;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN +;; +;; +;; PREREQUISITES +;; ============= +;; +;; * The GraphicsMagick or ImageMagick package; Image-Dired uses +;; whichever is available. +;; +;; A) For GraphicsMagick, `gm' is used. +;; Find it here: http://www.graphicsmagick.org/ +;; +;; B) For ImageMagick, `convert' and `mogrify' are used. +;; Find it here: https://www.imagemagick.org. +;; +;; * For non-lossy rotation of JPEG images, the JpegTRAN program is +;; needed. +;; +;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is +;; needed. It can be found here: https://exiftool.org/. This +;; function is, among other things, used for writing comments to +;; image files using `image-dired-thumbnail-set-image-description'. +;; +;; +;; USAGE +;; ===== +;; +;; This information has been moved to the manual. Type `C-h r' to open +;; the Emacs manual and go to the node Thumbnails by typing `g +;; Image-Dired RET'. +;; +;; Quickstart: M-x image-dired RET DIRNAME RET +;; +;; where DIRNAME is a directory containing image files. +;; +;; LIMITATIONS +;; =========== +;; +;; * Supports all image formats that Emacs and convert supports, but +;; the thumbnails are hard-coded to JPEG or PNG format. It uses +;; JPEG by default, but can optionally follow the Thumbnail Managing +;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user +;; option `image-dired-thumbnail-storage'. +;; +;; * WARNING: The "database" format used might be changed so keep a +;; backup of `image-dired-db-file' when testing new versions. +;; +;; TODO +;; ==== +;; +;; * Investigate if it is possible to also write the tags to the image +;; files. +;; +;; * From thumbs.el: Add an option for clean-up/max-size functionality +;; for thumbnail directory. +;; +;; * From thumbs.el: Add setroot function. +;; +;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out +;; which is best, saving old batch just before inserting new, or +;; saving the current batch in the ring when inserting it. Adding +;; it probably needs rewriting `image-dired-display-thumbs' to be more general. +;; +;; * Find some way of toggling on and off really nice keybindings in +;; Dired (for example, using C-n or instead of C-S-n). +;; Richard suggested that we could keep C-t as prefix for +;; image-dired commands as it is currently not used in Dired. He +;; also suggested that `dired-next-line' and `dired-previous-line' +;; figure out if image-dired is enabled in the current buffer and, +;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line', +;; respectively. Update: This is partly done; some bindings have +;; now been added to Dired. +;; +;; * In some way keep track of buffers and windows and stuff so that +;; it works as the user expects. +;; +;; * More/better documentation. + +;;; Code: + +(require 'dired) +(require 'exif) +(require 'image-mode) +(require 'widget) +(require 'xdg) + +(eval-when-compile + (require 'cl-lib) + (require 'wid-edit)) + + +;;; Customizable variables + +(defgroup image-dired nil + "Use Dired to browse your images as thumbnails, and more." + :prefix "image-dired-" + :link '(info-link "(emacs) Image-Dired") + :group 'multimedia) + +(defcustom image-dired-dir (locate-user-emacs-file "image-dired/") + "Directory where thumbnail images are stored. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; they will be +saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See +`image-dired-thumbnail-storage'." + :type 'directory) + +(defcustom image-dired-thumbnail-storage 'use-image-dired-dir + "How `image-dired' stores thumbnail files. +There are two ways that Image-Dired can store and generate +thumbnails. If you set this variable to one of the two following +values, they will be stored in the JPEG format: + +- `use-image-dired-dir' means that the thumbnails are stored in a + central directory. + +- `per-directory' means that each thumbnail is stored in a + subdirectory called \".image-dired\" in the same directory + where the image file is. + +It can also use the \"Thumbnail Managing Standard\", which allows +sharing of thumbnails across different programs. Thumbnails will +be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in +`image-dired-dir'. Thumbnails are saved in the PNG format, and +can be one of the following sizes: + +- `standard' means use thumbnails sized 128x128. +- `standard-large' means use thumbnails sized 256x256. +- `standard-x-large' means use thumbnails sized 512x512. +- `standard-xx-large' means use thumbnails sized 1024x1024. + +For more information on the Thumbnail Managing Standard, see: +https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html" + :type '(choice :tag "How to store thumbnail files" + (const :tag "Use image-dired-dir" use-image-dired-dir) + (const :tag "Thumbnail Managing Standard (normal 128x128)" + standard) + (const :tag "Thumbnail Managing Standard (large 256x256)" + standard-large) + (const :tag "Thumbnail Managing Standard (larger 512x512)" + standard-x-large) + (const :tag "Thumbnail Managing Standard (extra large 1024x1024)" + standard-xx-large) + (const :tag "Per-directory" per-directory)) + :version "29.1") + +(defconst image-dired--thumbnail-standard-sizes + '( standard standard-large + standard-x-large standard-xx-large) + "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.") + +(defcustom image-dired-db-file + (expand-file-name ".image-dired_db" image-dired-dir) + "Database file where file names and their associated tags are stored." + :type 'file) + +(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'." + :type 'file + :version "29.1") + +(defcustom image-dired-cmd-create-thumbnail-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-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'. +Available format specifiers are: %w which is replaced by +`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height', +%f which is replaced by the file name of the original image and %t +which is replaced by the file name of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-pngnq-program + ;; Prefer pngquant to pngnq-s9 as it is faster on my machine. + ;; The project also seems more active than the alternatives. + ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq. + ;; The pngnq project seems dead (?) since 2011 or so. + (or (executable-find "pngquant") + (executable-find "pngnq-s9") + (executable-find "pngnq")) + "The 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" + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngnq-options + (if (executable-find "pngquant") + '("--ext" "-nq8.png" "%t") ; same extension as "pngnq" + '("-f" "%t")) + "Arguments to pass `image-dired-cmd-pngnq-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options'." + :type '(repeat (string :tag "Argument")) + :version "29.1") + +(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush") + "The file name of the `pngcrush' program. +It optimizes the compression of PNG images. Also it adds PNG textual chunks +with the information required by the Thumbnail Managing Standard." + :type '(choice (const :tag "Not Set" nil) file)) + +(defcustom image-dired-cmd-pngcrush-options + `("-q" + "-text" "b" "Description" "Thumbnail of file://%f" + "-text" "b" "Software" ,(emacs-version) + ;; "-text b \"Thumb::Image::Height\" \"%oh\" " + ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" " + ;; "-text b \"Thumb::Image::Width\" \"%ow\" " + "-text" "b" "Thumb::MTime" "%m" + ;; "-text b \"Thumb::Size\" \"%b\" " + "-text" "b" "Thumb::URI" "file://%f" + "%q" "%t") + "Arguments for `image-dired-cmd-pngcrush-program'. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %q for a +temporary file name (typically generated by pnqnq)." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-optipng-program (executable-find "optipng") + "The 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'. +Available format specifiers are described in +`image-dired-cmd-create-thumbnail-options'." + :version "26.1" + :type '(repeat (string :tag "Argument")) + :link '(url-link "man:optipng(1)")) + +(defcustom image-dired-cmd-create-standard-thumbnail-options + (append '("-size" "%wx%h" "%f[0]") + (unless (or image-dired-cmd-pngcrush-program + image-dired-cmd-pngnq-program) + (list + "-set" "Thumb::MTime" "%m" + "-set" "Thumb::URI" "file://%f" + "-set" "Description" "Thumbnail of file://%f" + "-set" "Software" (emacs-version))) + '("-thumbnail" "%wx%h>" "png:%t")) + "Options for creating thumbnails according to the Thumbnail Managing Standard. +Available format specifiers are the same as in +`image-dired-cmd-create-thumbnail-options', with %m for file modification time." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-cmd-rotate-original-program + "jpegtran" + "Executable used to rotate original image. +Used together with `image-dired-cmd-rotate-original-options'." + :type 'file) + +(defcustom image-dired-cmd-rotate-original-options + '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o") + "Arguments of command used to rotate original image. +Used with `image-dired-cmd-rotate-original-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or +270 \(for 90 degrees right and left), %o which is replaced by the +original image file name and %t which is replaced by +`image-dired-temp-image-file'." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-temp-rotate-image-file + (expand-file-name ".image-dired_rotate_temp" image-dired-dir) + "Temporary file for rotate operations." + :type 'file) + +(defcustom image-dired-rotate-original-ask-before-overwrite t + "Confirm overwrite of original file after rotate operation. +If non-nil, ask user for confirmation before overwriting the +original file with `image-dired-temp-rotate-image-file'." + :type 'boolean) + +(defcustom image-dired-cmd-write-exif-data-program + "exiftool" + "Program used to write EXIF data to image. +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. +Used with `image-dired-cmd-write-exif-data-program'. +Available format specifiers are: %f which is replaced by +the image file name, %t which is replaced by the tag name and %v +which is replaced by the tag value." + :version "26.1" + :type '(repeat (string :tag "Argument"))) + +(defcustom image-dired-thumb-size + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t 100)) + "Size of thumbnails, in pixels. +This is the default size for both `image-dired-thumb-width' +and `image-dired-thumb-height'. + +The value of this option will be ignored if Image-Dired is +customized to use the Thumbnail Managing Standard; the standard +sizes will be used instead. See `image-dired-thumbnail-storage'." + :type 'integer) + +(defcustom image-dired-thumb-width image-dired-thumb-size + "Width of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-height image-dired-thumb-size + "Height of thumbnails, in pixels." + :type 'integer) + +(defcustom image-dired-thumb-relief 2 + "Size of button-like border around thumbnails." + :type 'integer) + +(defcustom image-dired-thumb-margin 2 + "Size of the margin around thumbnails. +This is where you see the cursor." + :type 'integer) + +(defcustom image-dired-thumb-visible-marks t + "Make marks and flags visible in thumbnail buffer. +If non-nil, apply the `image-dired-thumb-mark' face to marked +images and `image-dired-thumb-flagged' to images flagged for +deletion." + :type 'boolean + :version "28.1") + +(defface image-dired-thumb-mark + '((((class color) (min-colors 16)) :background "DarkOrange") + (((class color)) :foreground "yellow")) + "Face for marked images in thumbnail buffer." + :version "29.1") + +(defface image-dired-thumb-flagged + '((((class color) (min-colors 88) (background light)) :background "Red3") + (((class color) (min-colors 88) (background dark)) :background "Pink") + (((class color) (min-colors 16) (background light)) :background "Red3") + (((class color) (min-colors 16) (background dark)) :background "Pink") + (((class color) (min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for images flagged for deletion in thumbnail buffer." + :version "29.1") + +(defcustom image-dired-line-up-method 'dynamic + "Default method for line-up of thumbnails in thumbnail buffer. +Used by `image-dired-display-thumbs' and other functions that needs +to line-up thumbnails. Dynamic means to use the available width of +the window containing the thumbnail buffer, Fixed means to use +`image-dired-thumbs-per-row', Interactive is for asking the user, +and No line-up means that no automatic line-up will be done." + :type '(choice :tag "Default line-up method" + (const :tag "Dynamic" dynamic) + (const :tag "Fixed" fixed) + (const :tag "Interactive" interactive) + (const :tag "No line-up" none))) + +(defcustom image-dired-thumbs-per-row 3 + "Number of thumbnails to display per row in thumb buffer." + :type 'integer) + +(defcustom image-dired-track-movement t + "The current state of the tracking and mirroring. +For more information, see the documentation for +`image-dired-toggle-movement-tracking'." + :type 'boolean) + +(defcustom image-dired-append-when-browsing nil + "Append thumbnails in thumbnail buffer when browsing. +If non-nil, using `image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' will leave a trail of thumbnail +images in the thumbnail buffer. If you enable this and want to clean +the thumbnail buffer because it is filled with too many thumbnails, +just call `image-dired-display-thumb' to display only the image at point. +This value can be toggled using `image-dired-toggle-append-browsing'." + :type 'boolean) + +(defcustom image-dired-dired-disp-props t + "If non-nil, display properties for Dired file when browsing. +Used by `image-dired-next-line-and-display', +`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'. +If the database file is large, this can slow down image browsing in +Dired and you might want to turn it off." + :type 'boolean) + +(defcustom image-dired-display-properties-format "%b: %f (%t): %c" + "Display format for thumbnail properties. +%b is replaced with associated Dired buffer name, %f with file +name (without path) of original image file, %t with the list of +tags and %c with the comment." + :type 'string) + +(defcustom image-dired-external-viewer + ;; TODO: Use mailcap, dired-guess-shell-alist-default, + ;; dired-view-command-alist. + (cond ((executable-find "display")) + ((executable-find "xli")) + ((executable-find "qiv") "qiv -t") + ((executable-find "feh") "feh")) + "Name of external viewer. +Including parameters. Used when displaying original image from +`image-dired-thumbnail-mode'." + :version "28.1" + :type '(choice string + (const :tag "Not Set" nil))) + +(defcustom image-dired-main-image-directory + (or (xdg-user-dir "PICTURES") "~/pics/") + "Name of main image directory, if any. +Used by `image-dired-copy-with-exif-file-name'." + :type 'string + :version "29.1") + +(defcustom image-dired-show-all-from-dir-max-files 500 + "Maximum number of files in directory before prompting. + +If there are more image files than this in a selected directory, +the `image-dired-show-all-from-dir' command will ask for +confirmation before creating the thumbnail buffer. If this +variable is nil, it will never ask." + :type '(choice integer + (const :tag "Disable warning" nil)) + :version "29.1") + +(defcustom image-dired-marking-shows-next t + "If non-nil, marking, unmarking or flagging an image shows the next image. + +This affects the following commands: +\\ + `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file]) + `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file]) + `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])" + :type 'boolean + :version "29.1") + + +;;; Util functions + +(defvar image-dired-debug nil + "Non-nil means enable debug messages.") + +(defun image-dired-debug-message (&rest args) + "Display debug message ARGS when `image-dired-debug' is non-nil." + (when image-dired-debug + (apply #'message args))) + +(defmacro image-dired--with-db-file (&rest body) + "Run BODY in a temp buffer containing `image-dired-db-file'. +Return the last form in BODY." + (declare (indent 0) (debug t)) + `(with-temp-buffer + (if (file-exists-p image-dired-db-file) + (insert-file-contents image-dired-db-file)) + ,@body)) + +(defun image-dired-dir () + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." + (let ((image-dired-dir (file-name-as-directory + (expand-file-name image-dired-dir)))) + (unless (file-directory-p image-dired-dir) + (with-file-modes #o700 + (make-directory image-dired-dir t)) + (message "Thumbnail directory created: %s" image-dired-dir)) + image-dired-dir)) + +(defun image-dired-insert-image (file type relief margin) + "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point." + (let ((i `(image :type ,type + :file ,file + :relief ,relief + :margin ,margin))) + (insert-image i))) + +(defun image-dired-get-thumbnail-image (file) + "Return the image descriptor for a thumbnail of image file FILE." + (unless (string-match-p (image-file-name-regexp) file) + (error "%s is not a valid image file" file)) + (let* ((thumb-file (image-dired-thumb-name file)) + (thumb-attr (file-attributes thumb-file))) + (when (or (not thumb-attr) + (time-less-p (file-attribute-modification-time thumb-attr) + (file-attribute-modification-time + (file-attributes file)))) + (image-dired-create-thumb file thumb-file)) + (create-image thumb-file))) + +(defun image-dired-insert-thumbnail (file original-file-name + associated-dired-buffer) + "Insert thumbnail image FILE. +Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." + (let (beg end) + (setq beg (point)) + (image-dired-insert-image + file + ;; Thumbnails are created asynchronously, so we might not yet + ;; have a file. But if it exists, it might have been cached from + ;; before and we should use it instead of our current settings. + (or (and (file-exists-p file) + (image-type-from-file-header file)) + (and (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + 'png) + 'jpeg) + image-dired-thumb-relief + image-dired-thumb-margin) + (setq end (point)) + (add-text-properties + beg end + (list 'image-dired-thumbnail t + 'original-file-name original-file-name + 'associated-dired-buffer associated-dired-buffer + 'tags (image-dired-list-tags original-file-name) + 'mouse-face 'highlight + 'comment (image-dired-get-comment original-file-name))))) + +(defun image-dired-thumb-name (file) + "Return absolute file name for thumbnail FILE. +Depending on the value of `image-dired-thumbnail-storage', the +file name of the thumbnail will vary: +- For `use-image-dired-dir', make a SHA1-hash of the image file's + directory name and add that to make the thumbnail file name + unique. +- For `per-directory' storage, just add a subdirectory. +- For `standard' storage, produce the file name according to the + Thumbnail Managing Standard. Among other things, an MD5-hash + of the image file's directory name will be added to the + filename. +See also `image-dired-thumbnail-storage'." + (cond ((memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + (let ((thumbdir (cl-case image-dired-thumbnail-storage + (standard "thumbnails/normal") + (standard-large "thumbnails/large") + (standard-x-large "thumbnails/x-large") + (standard-xx-large "thumbnails/xx-large")))) + (expand-file-name + ;; MD5 is mandated by the Thumbnail Managing Standard. + (concat (md5 (concat "file://" (expand-file-name file))) ".png") + (expand-file-name thumbdir (xdg-cache-home))))) + ((eq 'use-image-dired-dir image-dired-thumbnail-storage) + (let* ((f (expand-file-name file)) + (hash + (md5 (file-name-as-directory (file-name-directory f))))) + (format "%s%s%s.thumb.%s" + (file-name-as-directory (expand-file-name (image-dired-dir))) + (file-name-base f) + (if hash (concat "_" hash) "") + (file-name-extension f)))) + ((eq 'per-directory image-dired-thumbnail-storage) + (let ((f (expand-file-name file))) + (format "%s.image-dired/%s.thumb.%s" + (file-name-directory f) + (file-name-base f) + (file-name-extension f)))))) + +(defun image-dired--check-executable-exists (executable) + (unless (executable-find (symbol-value executable)) + (error "Executable %S not found" executable))) + + +;;; Creating thumbnails + +(defun image-dired-thumb-size (dimension) + "Return thumb size depending on `image-dired-thumbnail-storage'. +DIMENSION should be either the symbol `width' or `height'." + (cond + ((eq 'standard image-dired-thumbnail-storage) 128) + ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) + (t (cl-ecase dimension + (width image-dired-thumb-width) + (height image-dired-thumb-height))))) + +(defvar image-dired--generate-thumbs-start nil + "Time when `display-thumbs' was called.") + +(defvar image-dired-queue nil + "List of items in the queue. +Each item has the form (ORIGINAL-FILE TARGET-FILE).") + +(defvar image-dired-queue-active-jobs 0 + "Number of active jobs in `image-dired-queue'.") + +(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2))) + "Maximum number of concurrent jobs permitted for generating images. +Increase at 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 `image-clear-cache' +and remove the cached thumbnail files between each trial run.") + +(defun image-dired-pngnq-thumb (spec) + "Quantize thumbnail described by format SPEC with pngnq(1)." + (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) + (lambda (process status) + (if (and (eq (process-status process) 'exit) + (zerop (process-exit-status process))) + ;; Pass off to pngcrush, or just rename the + ;; THUMB-nq8.png file back to THUMB.png + (if (and image-dired-cmd-pngcrush-program + (executable-find image-dired-cmd-pngcrush-program)) + (image-dired-pngcrush-thumb spec) + (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)) + +(defun image-dired-pngcrush-thumb (spec) + "Optimize thumbnail described by format SPEC with pngcrush(1)." + ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist. + ;; pngcrush needs an infile and outfile, so we just copy THUMB to + ;; THUMB-nq8.png and use the latter as a temp file. + (when (not image-dired-cmd-pngnq-program) + (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)) + +(defun image-dired-optipng-thumb (spec) + "Optimize thumbnail described by format SPEC with optipng(1)." + (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)) + +(defun image-dired-create-thumb-1 (original-file thumbnail-file) + "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE." + (image-dired--check-executable-exists + 'image-dired-cmd-create-thumbnail-program) + (let* ((width (int-to-string (image-dired-thumb-size 'width))) + (height (int-to-string (image-dired-thumb-size 'height))) + (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 + (list + (cons ?w width) + (cons ?h height) + (cons ?m modif-time) + (cons ?f original-file) + (cons ?q thumbnail-nq8-file) + (cons ?t thumbnail-file))) + (thumbnail-dir (file-name-directory thumbnail-file)) + process) + (when (not (file-exists-p thumbnail-dir)) + (with-file-modes #o700 + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) + + ;; Thumbnail file creation processes begin here and are marshaled + ;; in a queue by `image-dired-create-thumb'. + (setq process + (apply #'start-process "image-dired-create-thumbnail" nil + image-dired-cmd-create-thumbnail-program + (mapcar + (lambda (arg) (format-spec arg spec)) + (if (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + image-dired-cmd-create-standard-thumbnail-options + image-dired-cmd-create-thumbnail-options)))) + + (setf (process-sentinel process) + (lambda (process status) + ;; Trigger next in queue once a thumbnail has been created + (cl-decf image-dired-queue-active-jobs) + (image-dired-thumb-queue-run) + (when (= image-dired-queue-active-jobs 0) + (image-dired-debug-message + (format-time-string + "Generated thumbnails in %s.%3N seconds" + (time-subtract nil + image-dired--generate-thumbs-start)))) + (if (not (and (eq (process-status process) 'exit) + (zerop (process-exit-status process)))) + (message "Thumb could not be created for %s: %s" + (abbreviate-file-name original-file) + (string-replace "\n" "" status)) + (set-file-modes thumbnail-file #o600) + (clear-image-cache thumbnail-file) + ;; 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) + (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))))))) + process)) + +(defun image-dired-thumb-queue-run () + "Run a queued job if one exists and not too many jobs are running. +Queued items live in `image-dired-queue'." + (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)))) + +(defun image-dired-create-thumb (original-file thumbnail-file) + "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'. +The new file will be named THUMBNAIL-FILE." + (setq image-dired-queue + (nconc image-dired-queue + (list (list original-file thumbnail-file)))) + (run-at-time 0 nil #'image-dired-thumb-queue-run)) + +(defmacro image-dired--with-marked (&rest body) + "Eval BODY with point on each marked thumbnail. +If no marked file could be found, execute BODY on the current +thumbnail." + `(with-current-buffer image-dired-thumbnail-buffer + (let (found) + (save-mark-and-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (image-dired-thumb-file-marked-p) + (setq found t) + ,@body) + (forward-char))) + (unless found + ,@body)))) + +;;;###autoload +(defun image-dired-dired-toggle-marked-thumbs (&optional arg) + "Toggle thumbnails in front of file names in the Dired buffer. +If no marked file could be found, insert or hide thumbnails on the +current line. ARG, if non-nil, specifies the files to use instead +of the marked files. If ARG is an integer, use the next ARG (or +previous -ARG, if ARG<0) files." + (interactive "P") + (dired-map-over-marks + (let ((image-pos (dired-move-to-filename)) + (image-file (dired-get-filename nil t)) + thumb-file + overlay) + (when (and image-file + (string-match-p (image-file-name-regexp) image-file)) + (setq thumb-file (image-dired-get-thumbnail-image image-file)) + ;; If image is not already added, then add it. + (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'thumb-file) return ov))) + (if thumb-ov + (delete-overlay thumb-ov) + (put-image thumb-file image-pos) + (setq overlay + (cl-loop for ov in (overlays-in (point) (1+ (point))) + if (overlay-get ov 'put-image) return ov)) + (overlay-put overlay 'image-file image-file) + (overlay-put overlay 'thumb-file thumb-file))))) + arg ; Show or hide image on ARG next files. + 'show-progress) ; Update dired display after each image is updated. + (add-hook 'dired-after-readin-hook + 'image-dired-dired-after-readin-hook nil t)) + +(defun image-dired-dired-after-readin-hook () + "Relocate existing thumbnail overlays in Dired buffer after reverting. +Move them to their corresponding files if they still exist. +Otherwise, delete overlays." + (mapc (lambda (overlay) + (when (overlay-get overlay 'put-image) + (let* ((image-file (overlay-get overlay 'image-file)) + (image-pos (dired-goto-file image-file))) + (if image-pos + (move-overlay overlay image-pos image-pos) + (delete-overlay overlay))))) + (overlays-in (point-min) (point-max)))) + +(defun image-dired-next-line-and-display () + "Move to next Dired line and display thumbnail image." + (interactive) + (dired-next-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-previous-line-and-display () + "Move to previous Dired line and display thumbnail image." + (interactive) + (dired-previous-line 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-append-browsing () + "Toggle `image-dired-append-when-browsing'." + (interactive) + (setq image-dired-append-when-browsing + (not image-dired-append-when-browsing)) + (message "Append browsing %s" + (if image-dired-append-when-browsing + "on" + "off"))) + +(defun image-dired-mark-and-display-next () + "Mark current file in Dired and display next thumbnail image." + (interactive) + (dired-mark 1) + (image-dired-display-thumbs + t (or image-dired-append-when-browsing nil) t) + (if image-dired-dired-disp-props + (image-dired-dired-display-properties))) + +(defun image-dired-toggle-dired-display-properties () + "Toggle `image-dired-dired-disp-props'." + (interactive) + (setq image-dired-dired-disp-props + (not image-dired-dired-disp-props)) + (message "Dired display properties %s" + (if image-dired-dired-disp-props + "on" + "off"))) + +(defvar image-dired-thumbnail-buffer "*image-dired*" + "Image-Dired's thumbnail buffer.") + +(defun image-dired-create-thumbnail-buffer () + "Create thumb buffer and set `image-dired-thumbnail-mode'." + (let ((buf (get-buffer-create image-dired-thumbnail-buffer))) + (with-current-buffer buf + (setq buffer-read-only t) + (if (not (eq major-mode 'image-dired-thumbnail-mode)) + (image-dired-thumbnail-mode))) + buf)) + +(defvar image-dired-display-image-buffer "*image-dired-display-image*" + "Where larger versions of the images are display.") + +(defvar image-dired-saved-window-configuration nil + "Saved window configuration.") + +;;;###autoload +(defun image-dired-dired-with-window-configuration (dir &optional arg) + "Open directory DIR and create a default window configuration. + +Convenience command that: + + - Opens Dired in folder DIR + - Splits windows in most useful (?) way + - Sets `truncate-lines' to t + +After the command has finished, you would typically mark some +image files in Dired and type +\\[image-dired-display-thumbs] (`image-dired-display-thumbs'). + +If called with prefix argument ARG, skip splitting of windows. + +The current window configuration is saved and can be restored by +calling `image-dired-restore-window-configuration'." + (interactive "DDirectory: \nP") + (let ((buf (image-dired-create-thumbnail-buffer)) + (buf2 (get-buffer-create image-dired-display-image-buffer))) + (setq image-dired-saved-window-configuration + (current-window-configuration)) + (dired dir) + (delete-other-windows) + (when (not arg) + (split-window-right) + (setq truncate-lines t) + (save-excursion + (other-window 1) + (pop-to-buffer-same-window buf) + (select-window (split-window-below)) + (pop-to-buffer-same-window buf2) + (other-window -2))))) + +(defun image-dired-restore-window-configuration () + "Restore window configuration. +Restore any changes to the window configuration made by calling +`image-dired-dired-with-window-configuration'." + (interactive nil image-dired-thumbnail-mode) + (if image-dired-saved-window-configuration + (set-window-configuration image-dired-saved-window-configuration) + (message "No saved window configuration"))) + +(defun image-dired--line-up-with-method () + "Line up thumbnails according to `image-dired-line-up-method'." + (cond ((eq 'dynamic image-dired-line-up-method) + (image-dired-line-up-dynamic)) + ((eq 'fixed image-dired-line-up-method) + (image-dired-line-up)) + ((eq 'interactive image-dired-line-up-method) + (image-dired-line-up-interactive)) + ((eq 'none image-dired-line-up-method) + nil) + (t + (image-dired-line-up-dynamic)))) + +;;;###autoload +(defun image-dired-display-thumbs (&optional arg append do-not-pop) + "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'. +If a thumbnail image does not exist for a file, it is created on the +fly. With prefix argument ARG, display only thumbnail for file at +point (this is useful if you have marked some files but want to show +another one). + +Recommended usage is to split the current frame horizontally so that +you have the Dired buffer in the left window and the +`image-dired-thumbnail-buffer' buffer in the right window. + +With optional argument APPEND, append thumbnail to thumbnail buffer +instead of erasing it first. + +Optional argument DO-NOT-POP controls if `pop-to-buffer' should be +used or not. If non-nil, use `display-buffer' instead of +`pop-to-buffer'. This is used from functions like +`image-dired-next-line-and-display' and +`image-dired-previous-line-and-display' where we do not want the +thumbnail buffer to be selected." + (interactive "P") + (setq image-dired--generate-thumbs-start (current-time)) + (let ((buf (image-dired-create-thumbnail-buffer)) + thumb-name files dired-buf) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (setq dired-buf (current-buffer)) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (if (not append) + (erase-buffer) + (goto-char (point-max))) + (dolist (curr-file files) + (setq thumb-name (image-dired-thumb-name curr-file)) + (when (not (file-exists-p thumb-name)) + (image-dired-create-thumb curr-file thumb-name)) + (image-dired-insert-thumbnail thumb-name curr-file dired-buf))) + (if do-not-pop + (display-buffer buf) + (pop-to-buffer buf)) + (image-dired--line-up-with-method)))) + +;;;###autoload +(defun image-dired-show-all-from-dir (dir) + "Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation." + (interactive "DImage-Dired: ") + (dired dir) + (dired-mark-files-regexp (image-file-name-regexp)) + (let ((files (dired-get-marked-files nil nil nil t))) + (cond ((and (null (cdr files))) + (message "No image files in directory")) + ((or (not image-dired-show-all-from-dir-max-files) + (<= (length (cdr files)) image-dired-show-all-from-dir-max-files) + (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files) + (y-or-n-p + (format + "Directory contains more than %d image files. Proceed?" + image-dired-show-all-from-dir-max-files)))) + (image-dired-display-thumbs) + (pop-to-buffer image-dired-thumbnail-buffer) + (setq default-directory dir) + (image-dired-unmark-all-marks)) + (t (message "Image-Dired canceled"))))) + +;;;###autoload +(defalias 'image-dired 'image-dired-show-all-from-dir) + + +;;; Tags + +(defun image-dired-sane-db-file () + "Check if `image-dired-db-file' exists. +If not, try to create it (including any parent directories). +Signal error if there are problems creating it." + (or (file-exists-p image-dired-db-file) + (let (dir buf) + (unless (file-directory-p (setq dir (file-name-directory + image-dired-db-file))) + (with-file-modes #o700 + (make-directory dir t))) + (with-current-buffer (setq buf (create-file-buffer + image-dired-db-file)) + (with-file-modes #o600 + (write-file image-dired-db-file))) + (kill-buffer buf) + (file-exists-p image-dired-db-file)) + (error "Could not create %s" image-dired-db-file))) + +(defvar image-dired-tag-history nil "Variable holding the tag history.") + +(defun image-dired-write-tags (file-tags) + "Write file tags to database. +Write each file and tag in FILE-TAGS to the database. +FILE-TAGS is an alist in the following form: + ((FILE . TAG) ... )" + (image-dired-sane-db-file) + (let (end file tag) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-tags) + (setq file (car elt) + tag (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + (when (not (search-forward (format ";%s" tag) end t)) + (end-of-line) + (insert (format ";%s" tag)))) + (goto-char (point-max)) + (insert (format "%s;%s\n" file tag)))) + (save-buffer)))) + +(defun image-dired-remove-tag (files tag) + "For all FILES, remove TAG from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (let (end) + (unless (listp files) + (if (stringp files) + (setq files (list files)) + (error "Files must be a string or a list of strings!"))) + (dolist (file files) + (goto-char (point-min)) + (when (search-forward-regexp (format "^%s;" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward-regexp + (format "\\(;%s\\)\\($\\|;\\)" tag) end t) + (delete-region (match-beginning 1) (match-end 1)) + ;; Check if file should still be in the database. If + ;; it has no tags or comments, it will be removed. + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (not (search-forward ";" end t)) + (kill-line 1)))))) + (save-buffer))) + +(defun image-dired-list-tags (file) + "Read all tags for image FILE from the image database." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end (tags "")) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (if (search-forward ";" end t) + (if (search-forward "comment:" end t) + (if (search-forward ";" end t) + (setq tags (buffer-substring (point) end))) + (setq tags (buffer-substring (point) end))))) + (split-string tags ";")))) + +;;;###autoload +(defun image-dired-tag-files (arg) + "Tag marked file(s) in Dired. With prefix ARG, tag file at point." + (interactive "P") + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-write-tags + (mapcar + (lambda (x) + (cons x tag)) + files)))) + +(defun image-dired-tag-thumbnail () + "Tag current or marked thumbnails." + (interactive) + (let ((tag (completing-read + "Tags to add (separate tags with a semicolon): " + image-dired-tag-history nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-write-tags + (list (cons (image-dired-original-file-name) tag))) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + +;;;###autoload +(defun image-dired-delete-tag (arg) + "Remove tag for selected file(s). +With prefix argument ARG, remove tag from file at point." + (interactive "P") + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history)) + files) + (if arg + (setq files (list (dired-get-filename))) + (setq files (dired-get-marked-files))) + (image-dired-remove-tag files tag))) + +(defun image-dired-tag-thumbnail-remove () + "Remove tag from current or marked thumbnails." + (interactive) + (let ((tag (completing-read "Tag to remove: " image-dired-tag-history + nil nil nil 'image-dired-tag-history))) + (image-dired--with-marked + (image-dired-remove-tag (image-dired-original-file-name) tag) + (image-dired-update-property + 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + + +;;; Thumbnail mode (cont.) + +(defun image-dired-original-file-name () + "Get original file name for thumbnail or display image at point." + (get-text-property (point) 'original-file-name)) + +(defun image-dired-file-name-at-point () + "Get abbreviated file name for thumbnail or display image at point." + (let ((f (image-dired-original-file-name))) + (when f + (abbreviate-file-name f)))) + +(defun image-dired-associated-dired-buffer () + "Get associated Dired buffer at point." + (get-text-property (point) 'associated-dired-buffer)) + +(defun image-dired-get-buffer-window (buf) + "Return window where buffer BUF is." + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)) + nil t)) + +(defun image-dired-track-original-file () + "Track the original file in the associated Dired buffer. +See documentation for `image-dired-toggle-movement-tracking'. +Interactive use only useful if `image-dired-track-movement' is nil." + (interactive) + (let* ((dired-buf (image-dired-associated-dired-buffer)) + (file-name (image-dired-original-file-name)) + (window (image-dired-get-buffer-window dired-buf))) + (and (buffer-live-p dired-buf) file-name + (with-current-buffer dired-buf + (if (not (dired-goto-file file-name)) + (message "Could not track file") + (if window (set-window-point window (point)))))))) + +(defun image-dired-toggle-movement-tracking () + "Turn on and off `image-dired-track-movement'. +Tracking of the movements between thumbnail and Dired buffer so that +they are \"mirrored\" in the dired buffer. When this is on, moving +around in the thumbnail or dired buffer will find the matching +position in the other buffer." + (interactive) + (setq image-dired-track-movement (not image-dired-track-movement)) + (message "Movement tracking %s" (if image-dired-track-movement "on" "off"))) + +(defun image-dired-track-thumbnail () + "Track current Dired file's thumb in `image-dired-thumbnail-buffer'. +This is almost the same as what `image-dired-track-original-file' does, +but the other way around." + (let ((file (dired-get-filename)) + prop-val found window) + (when (get-buffer image-dired-thumbnail-buffer) + (with-current-buffer image-dired-thumbnail-buffer + (goto-char (point-min)) + (while (and (not (eobp)) + (not found)) + (if (and (setq prop-val + (get-text-property (point) 'original-file-name)) + (string= prop-val file)) + (setq found t)) + (if (not found) + (forward-char 1))) + (when found + (if (setq window (image-dired-thumbnail-window)) + (set-window-point window (point))) + (image-dired-update-header-line)))))) + +(defun image-dired-dired-next-line (&optional arg) + "Call `dired-next-line', then track thumbnail. +This can safely replace `dired-next-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-next-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired-dired-previous-line (&optional arg) + "Call `dired-previous-line', then track thumbnail. +This can safely replace `dired-previous-line'. +With prefix argument, move ARG lines." + (interactive "P") + (dired-previous-line (or arg 1)) + (if image-dired-track-movement + (image-dired-track-thumbnail))) + +(defun image-dired--display-thumb-properties-fun () + (let ((old-buf (current-buffer)) + (old-point (point))) + (lambda () + (when (and (equal (current-buffer) old-buf) + (= (point) old-point)) + (ignore-errors + (image-dired-update-header-line)))))) + +(defun image-dired-forward-image (&optional arg wrap-around) + "Move to next image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move backwards. +On reaching end or beginning of buffer, stop and show a message. + +If optional argument WRAP-AROUND is non-nil, wrap around: if +point is on the last image, move to the last one and vice versa." + (interactive "p") + (setq arg (or arg 1)) + (let (pos) + (dotimes (_ (abs arg)) + (if (and (not (if (> arg 0) (eobp) (bobp))) + (save-excursion + (forward-char (if (> arg 0) 1 -1)) + (while (and (not (if (> arg 0) (eobp) (bobp))) + (not (image-dired-image-at-point-p))) + (forward-char (if (> arg 0) 1 -1))) + (setq pos (point)) + (image-dired-image-at-point-p))) + (progn (goto-char pos) + (image-dired-update-header-line)) + (if wrap-around + (progn (goto-char (if (> arg 0) + (point-min) + ;; There are two spaces after the last image. + (- (point-max) 2))) + (image-dired-update-header-line)) + (message "At %s image" (if (> arg 0) "last" "first")) + (run-at-time 1 nil (image-dired--display-thumb-properties-fun)))))) + (when image-dired-track-movement + (image-dired-track-original-file))) + +(defun image-dired-backward-image (&optional arg) + "Move to previous image and display properties. +Optional prefix ARG says how many images to move; the default is +one image. Negative means move forward. +On reaching end or beginning of buffer, stop and show a message." + (interactive "p") + (image-dired-forward-image (- (or arg 1)))) + +(defun image-dired-next-line () + "Move to next line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line 1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next thumbnail. + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + +(defun image-dired-previous-line () + "Move to previous line and display properties." + (interactive nil image-dired-thumbnail-mode) + (let ((goal-column (current-column))) + (forward-line -1) + (move-to-column goal-column)) + ;; If we end up in an empty spot, back up to the next + ;; thumbnail. This should only happen if the user deleted a + ;; thumbnail and did not refresh, so it is not very common. But we + ;; can handle it in a good manner, so why not? + (if (not (image-dired-image-at-point-p)) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-beginning-of-buffer () + "Move to the first image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-min)) + (while (and (not (image-at-point-p)) + (not (eobp))) + (forward-char 1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-end-of-buffer () + "Move to the last image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-max)) + (while (and (not (image-at-point-p)) + (not (bobp))) + (forward-char -1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-format-properties-string (buf file props comment) + "Format display properties. +BUF is the associated Dired buffer, FILE is the original image file +name, PROPS is a stringified list of tags and COMMENT is the image file's +comment." + (format-spec + image-dired-display-properties-format + (list + (cons ?b (or buf "")) + (cons ?f file) + (cons ?t (or props "")) + (cons ?c (or comment ""))))) + +(defun image-dired-update-header-line () + "Update image information in the header line." + (when (and (not (eobp)) + (memq major-mode '(image-dired-thumbnail-mode + image-dired-display-image-mode))) + (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) + (dired-buf (buffer-name (image-dired-associated-dired-buffer))) + (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (comment (get-text-property (point) 'comment)) + (message-log-max nil)) + (if file-name + (setq header-line-format + (image-dired-format-properties-string + dired-buf + file-name + props + comment)))))) + +(defun image-dired-dired-file-marked-p (&optional marker) + "In Dired, return t if file on current line is marked. +If optional argument MARKER is non-nil, it is a character to look +for. The default is to look for `dired-marker-char'." + (setq marker (or marker dired-marker-char)) + (save-excursion + (beginning-of-line) + (and (looking-at dired-re-mark) + (= (aref (match-string 0) 0) marker)))) + +(defun image-dired-dired-file-flagged-p () + "In Dired, return t if file on current line is flagged for deletion." + (image-dired-dired-file-marked-p dired-del-marker)) + +(defmacro image-dired--with-thumbnail-buffer (&rest body) + (declare (indent defun) (debug t)) + `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (if-let ((win (get-buffer-window buf))) + (with-selected-window win + ,@body) + ,@body)) + (user-error "No such buffer: %s" image-dired-thumbnail-buffer))) + +(defmacro image-dired--on-file-in-dired-buffer (&rest body) + "Run BODY with point on file at point in Dired buffer. +Should be called from commands in `image-dired-thumbnail-mode'." + (declare (indent defun) (debug t)) + `(let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + ,@body + (image-dired-thumb-update-marks)))))) + +(defmacro image-dired--do-mark-command (maybe-next &rest body) + "Helper macro for the mark, unmark and flag commands. +Run BODY in Dired buffer. +If optional argument MAYBE-NEXT is non-nil, show next image +according to `image-dired-marking-shows-next'." + (declare (indent defun) (debug t)) + `(image-dired--with-thumbnail-buffer + (image-dired--on-file-in-dired-buffer + ,@body) + ,(when maybe-next + '(if image-dired-marking-shows-next + (image-dired-display-next-thumbnail-original) + (image-dired-next-line))))) + +(defun image-dired-mark-thumb-original-file () + "Mark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-mark 1))) + +(defun image-dired-unmark-thumb-original-file () + "Unmark original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-unmark 1))) + +(defun image-dired-flag-thumb-original-file () + "Flag original image file for deletion in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-flag-file-deletion 1))) + +(defun image-dired-toggle-mark-thumb-original-file () + "Toggle mark on original image file in associated Dired buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1)))) + +(defun image-dired-unmark-all-marks () + "Remove all marks from all files in associated Dired buffer. +Also update the marks in the thumbnail buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (dired-unmark-all-marks)) + (image-dired--with-thumbnail-buffer + (image-dired-thumb-update-marks))) + +(defun image-dired-jump-original-dired-buffer () + "Jump to the Dired buffer associated with the current image file. +You probably want to use this together with +`image-dired-track-original-file'." + (interactive nil image-dired-thumbnail-mode) + (let ((buf (image-dired-associated-dired-buffer)) + window frame) + (setq window (image-dired-get-buffer-window buf)) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Associated dired buffer not visible")))) + +;;;###autoload +(defun image-dired-jump-thumbnail-buffer () + "Jump to thumbnail buffer." + (interactive) + (let ((window (image-dired-thumbnail-window)) + frame) + (if window + (progn + (if (not (equal (selected-frame) (setq frame (window-frame window)))) + (select-frame-set-input-focus frame)) + (select-window window)) + (message "Thumbnail buffer not visible")))) + +(defvar image-dired-thumbnail-mode-line-up-map + (let ((map (make-sparse-keymap))) + ;; map it to "g" so that the user can press it more quickly + (define-key map "g" #'image-dired-line-up-dynamic) + ;; "f" for "fixed" number of thumbs per row + (define-key map "f" #'image-dired-line-up) + ;; "i" for "interactive" + (define-key map "i" #'image-dired-line-up-interactive) + map) + "Keymap for line-up commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-tag-map + (let ((map (make-sparse-keymap))) + ;; map it to "t" so that the user can press it more quickly + (define-key map "t" #'image-dired-tag-thumbnail) + ;; "r" for "remove" + (define-key map "r" #'image-dired-tag-thumbnail-remove) + map) + "Keymap for tag commands in `image-dired-thumbnail-mode'.") + +(defvar image-dired-thumbnail-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) + + (define-key map "<" #'image-dired-beginning-of-buffer) + (define-key map ">" #'image-dired-end-of-buffer) + (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) + (define-key map (kbd "M->") #'image-dired-end-of-buffer) + + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) + + ;; add line-up map + (define-key map "g" image-dired-thumbnail-mode-line-up-map) + ;; add tag map + (define-key map "t" image-dired-thumbnail-mode-tag-map) + + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) + + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) + + (define-key map "D" #'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) + + ;; Mouse + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail) + ;; Seems I must first set C-down-mouse-1 to undefined, or else it + ;; will trigger the buffer menu. If I try to instead bind + ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message + ;; about C-mouse-1 not being defined afterwards. Annoying, but I + ;; probably do not completely understand mouse events. + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) + map) + "Keymap for `image-dired-thumbnail-mode'.") + +(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map + "Menu for `image-dired-thumbnail-mode'." + '("Image-Dired" + ["Display image" image-dired-display-thumbnail-original-image] + ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] + "---" + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] + "---" + ["Rotate original right" image-dired-rotate-original-right] + ["Rotate original left" image-dired-rotate-original-left] + "---" + ["Comment thumbnail" image-dired-comment-thumbnail] + ["Tag current or marked thumbnails" image-dired-tag-thumbnail] + ["Remove tag from current or marked thumbnails" + image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] + "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) + ["Quit" quit-window])) + +(defvar image-dired-display-image-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "n" #'image-dired-display-next-thumbnail-original) + (define-key map "p" #'image-dired-display-previous-thumbnail-original) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + ;; Disable keybindings from `image-mode-map' that doesn't make sense here. + (define-key map "o" nil) ; image-save + map) + "Keymap for `image-dired-display-image-mode'.") + +(define-derived-mode image-dired-thumbnail-mode + special-mode "image-dired-thumbnail" + "Browse and manipulate thumbnail images using Dired. +Use `image-dired-minor-mode' to get a nice setup." + :interactive nil + (buffer-disable-undo) + (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) + (setq-local window-resize-pixelwise t) + (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record) + ;; Use approximately as much vertical spacing as horizontal. + (setq-local line-spacing (frame-char-width))) + + +;;; Display image mode + +(define-derived-mode image-dired-display-image-mode + image-mode "image-dired-image-display" + "Mode for displaying and manipulating original image. +Resized or in full-size." + :interactive nil + (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t)) + +(defvar image-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + ;; (set-keymap-parent map dired-mode-map) + ;; Hijack previous and next line movement. Let C-p and C-b be + ;; though... + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) + map) + "Keymap for `image-dired-minor-mode'.") + +(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map + "Menu for `image-dired-minor-mode'." + '("Image-dired" + ["Display thumb for next file" image-dired-next-line-and-display] + ["Display thumb for previous file" image-dired-previous-line-and-display] + ["Mark and display next" image-dired-mark-and-display-next] + "---" + ["Create thumbnails for marked files" image-dired-create-thumbs] + "---" + ["Display thumbnails append" image-dired-display-thumbs-append] + ["Display this thumbnail" image-dired-display-thumb] + ["Display image" image-dired-dired-display-image] + ["Display in external viewer" image-dired-dired-display-external] + "---" + ["Toggle display properties" image-dired-toggle-dired-display-properties + :style toggle + :selected image-dired-dired-disp-props] + ["Toggle append browsing" image-dired-toggle-append-browsing + :style toggle + :selected image-dired-append-when-browsing] + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] + ["Mark tagged files" image-dired-mark-tagged-files] + ["Comment files" image-dired-dired-comment-files] + ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + +;;;###autoload +(define-minor-mode image-dired-minor-mode + "Setup easy-to-use keybindings for the commands to be used in Dired mode. +Note that n, p and and will be hijacked and bound to +`image-dired-dired-next-line' and `image-dired-dired-previous-line'." + :keymap image-dired-minor-mode-map) + +(declare-function clear-image-cache "image.c" (&optional filter)) + +(defun image-dired-create-thumbs (&optional arg) + "Create thumbnail images for all marked files in Dired. +With prefix argument ARG, create thumbnails even if they already exist +\(i.e. use this to refresh your thumbnails)." + (interactive "P") + (let (thumb-name) + (dolist (curr-file (dired-get-marked-files)) + (setq thumb-name (image-dired-thumb-name curr-file)) + ;; If the user overrides the exist check, we must clear the + ;; image cache so that if the user wants to display the + ;; thumbnail, it is not fetched from cache. + (when arg + (clear-image-cache (expand-file-name thumb-name))) + (when (or (not (file-exists-p thumb-name)) + arg) + (image-dired-create-thumb curr-file thumb-name))))) + + +;;; Slideshow + +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") + +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") + +(defvar image-dired--slideshow-initial nil) + +(defun image-dired-slideshow-step () + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) + (image-dired-slideshow-stop))) + +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow, waiting `image-dired-slideshow-delay' between images. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (not arg) + image-dired-slideshow-delay + (if (> arg 0) + arg + (string-to-number + (let ((delay (number-to-string image-dired-slideshow-delay))) + (read-string + (format-prompt "Delay, in seconds. Decimals are accepted" delay)) + delay)))))) + (setq image-dired--slideshow-timer + (run-with-timer + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) + +(defun image-dired-slideshow-stop () + "Cancel slideshow." + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) + + +;;; Thumbnail mode (cont. 3) + +(defun image-dired-delete-char () + "Remove current thumbnail from thumbnail buffer and line up." + (interactive nil image-dired-thumbnail-mode) + (let ((inhibit-read-only t)) + (delete-char 1) + (when (= (following-char) ?\s) + (delete-char 1)))) + +;;;###autoload +(defun image-dired-display-thumbs-append () + "Append thumbnails to `image-dired-thumbnail-buffer'." + (interactive) + (image-dired-display-thumbs nil t t)) + +;;;###autoload +(defun image-dired-display-thumb () + "Shorthand for `image-dired-display-thumbs' with prefix argument." + (interactive) + (image-dired-display-thumbs t nil t)) + +(defun image-dired-line-up () + "Line up thumbnails according to `image-dired-thumbs-per-row'. +See also `image-dired-line-up-dynamic'." + (interactive) + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1)) + (while (not (eobp)) + (forward-char) + (while (and (not (image-dired-image-at-point-p)) + (not (eobp))) + (delete-char 1))) + (goto-char (point-min)) + (let ((seen 0) + (thumb-prev-pos 0) + (thumb-width-chars + (ceiling (/ (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width)) + (float (frame-char-width)))))) + (while (not (eobp)) + (forward-char) + (if (= image-dired-thumbs-per-row 1) + (insert "\n") + (cl-incf thumb-prev-pos thumb-width-chars) + (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos))) + (cl-incf seen) + (when (and (= seen (- image-dired-thumbs-per-row 1)) + (not (eobp))) + (forward-char) + (insert "\n") + (setq seen 0) + (setq thumb-prev-pos 0))))) + (goto-char (point-min)))) + +(defun image-dired-line-up-dynamic () + "Line up thumbnails images dynamically. +Calculate how many thumbnails fit." + (interactive) + (let* ((char-width (frame-char-width)) + (width (image-dired-window-width-pixels (image-dired-thumbnail-window))) + (image-dired-thumbs-per-row + (/ width + (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width) + char-width)))) + (image-dired-line-up))) + +(defun image-dired-line-up-interactive () + "Line up thumbnails interactively. +Ask user how many thumbnails should be displayed per row." + (interactive) + (let ((image-dired-thumbs-per-row + (string-to-number (read-string "How many thumbs per row: ")))) + (if (not (> image-dired-thumbs-per-row 0)) + (message "Number must be greater than 0") + (image-dired-line-up)))) + +(defun image-dired-thumbnail-display-external () + "Display original image for thumbnail at point using external viewer." + (interactive) + (let ((file (image-dired-original-file-name))) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (start-process "image-dired-thumb-external" nil + image-dired-external-viewer file))))) + +;;;###autoload +(defun image-dired-dired-display-external () + "Display file at point using an external viewer." + (interactive) + (let ((file (dired-get-filename))) + (start-process "image-dired-external" nil + image-dired-external-viewer file))) + +(defun image-dired-window-width-pixels (window) + "Calculate WINDOW width in pixels." + (* (window-width window) (frame-char-width))) + +(defun image-dired-display-window () + "Return window where `image-dired-display-image-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer)) + nil t)) + +(defun image-dired-thumbnail-window () + "Return window where `image-dired-thumbnail-buffer' is visible." + (get-window-with-predicate + (lambda (window) + (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer)) + nil t)) + +(defun image-dired-associated-dired-buffer-window () + "Return window where associated Dired buffer is visible." + (let (buf) + (if (image-dired-image-at-point-p) + (progn + (setq buf (image-dired-associated-dired-buffer)) + (get-window-with-predicate + (lambda (window) + (equal (window-buffer window) buf)))) + (error "No thumbnail image at point")))) + +(defun image-dired-display-image (file &optional _ignored) + "Display image FILE in image buffer. +Use this when you want to display the image, in a new window. +The window will use `image-dired-display-image-mode' which is +based on `image-mode'." + (declare (advertised-calling-convention (file) "29.1")) + (setq file (expand-file-name file)) + (when (not (file-exists-p file)) + (error "No such file: %s" file)) + (let ((buf (get-buffer image-dired-display-image-buffer)) + (cur-win (selected-window))) + (when buf + (kill-buffer buf)) + (when-let ((buf (find-file-noselect file nil t))) + (pop-to-buffer buf) + (rename-buffer image-dired-display-image-buffer) + (image-dired-display-image-mode) + (select-window cur-win)))) + +(defun image-dired-display-thumbnail-original-image (&optional arg) + "Display current thumbnail's original image in display buffer. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (let ((file (image-dired-original-file-name))) + (if (not (string-equal major-mode "image-dired-thumbnail-mode")) + (message "Not in image-dired-thumbnail-mode") + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (if (not file) + (message "No original file name found") + (image-dired-display-image file arg)))))) + + +;;;###autoload +(defun image-dired-dired-display-image (&optional arg) + "Display current image file. +See documentation for `image-dired-display-image' for more information. +With prefix argument ARG, display image in its original size." + (interactive "P") + (image-dired-display-image (dired-get-filename) arg)) + +(defun image-dired-image-at-point-p () + "Return non-nil if there is an `image-dired' thumbnail at point." + (get-text-property (point) 'image-dired-thumbnail)) + +(defun image-dired-refresh-thumb () + "Force creation of new image for current thumbnail." + (interactive nil image-dired-thumbnail-mode) + (let* ((file (image-dired-original-file-name)) + (thumb (expand-file-name (image-dired-thumb-name file)))) + (clear-image-cache (expand-file-name thumb)) + (image-dired-create-thumb file thumb))) + +(defun image-dired-rotate-original (degrees) + "Rotate original image DEGREES degrees." + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-original-program) + (if (not (image-dired-image-at-point-p)) + (message "No image at point") + (let* ((file (image-dired-original-file-name)) + (spec + (list + (cons ?d degrees) + (cons ?o (expand-file-name file)) + (cons ?t image-dired-temp-rotate-image-file)))) + (unless (eq 'jpeg (image-type file)) + (user-error "Only JPEG images can be rotated")) + (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program + nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-original-options)))) + (error "Could not rotate image") + (image-dired-display-image image-dired-temp-rotate-image-file) + (if (or (and image-dired-rotate-original-ask-before-overwrite + (y-or-n-p + "Rotate to temp file OK. Overwrite original image? ")) + (not image-dired-rotate-original-ask-before-overwrite)) + (progn + (copy-file image-dired-temp-rotate-image-file file t) + (image-dired-refresh-thumb)) + (image-dired-display-image file)))))) + +(defun image-dired-rotate-original-left () + "Rotate original image left (counter clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "270")) + +(defun image-dired-rotate-original-right () + "Rotate original image right (clockwise) 90 degrees. +The result of the rotation is displayed in the image display area +and a confirmation is needed before the original image files is +overwritten. This confirmation can be turned off using +`image-dired-rotate-original-ask-before-overwrite'." + (interactive) + (image-dired-rotate-original "90")) + + +;;; EXIF support + +(defun image-dired-get-exif-file-name (file) + "Use the image's EXIF information to return a unique file name. +The file name should be unique as long as you do not take more than +one picture per second. The original file name is suffixed at the end +for traceability. The format of the returned file name is +YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from +`image-dired-copy-with-exif-file-name'." + (let (data no-exif-data-found) + (if (not (eq 'jpeg (image-type (expand-file-name file)))) + (setq no-exif-data-found t + data (format-time-string + "%Y:%m:%d %H:%M:%S" + (file-attribute-modification-time + (file-attributes (expand-file-name file))))) + (setq data (exif-field 'date-time (exif-parse-file + (expand-file-name file))))) + (while (string-match "[ :]" data) + (setq data (replace-match "_" nil nil data))) + (format "%s%s%s" data + (if no-exif-data-found + "_noexif_" + "_") + (file-name-nondirectory file)))) + +(defun image-dired-thumbnail-set-image-description () + "Set the ImageDescription EXIF tag for the original image. +If the image already has a value for this tag, it is used as the +default value at the prompt." + (interactive) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-original-file-name)) + (old-value (or (exif-field 'description (exif-parse-file file)) ""))) + (if (eq 0 + (image-dired-set-exif-data file "ImageDescription" + (read-string "Value of ImageDescription: " + old-value))) + (message "Successfully wrote ImageDescription tag") + (error "Could not write ImageDescription tag"))))) + +(defun image-dired-set-exif-data (file tag-name tag-value) + "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE." + (image-dired--check-executable-exists + 'image-dired-cmd-write-exif-data-program) + (let ((spec + (list + (cons ?f (expand-file-name file)) + (cons ?t tag-name) + (cons ?v tag-value)))) + (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-write-exif-data-options)))) + +(defun image-dired-copy-with-exif-file-name () + "Copy file with unique name to main image directory. +Copy current or all marked files in Dired to a new file in your +main image directory, using a file name generated by +`image-dired-get-exif-file-name'. A typical usage for this if when +copying images from a digital camera into the image directory. + + Typically, you would open up the folder with the incoming +digital images, mark the files to be copied, and execute this +function. The result is a couple of new files in +`image-dired-main-image-directory' called +2005_05_08_12_52_00_dscn0319.jpg, +2005_05_08_14_27_45_dscn0320.jpg etc." + (interactive) + (let (new-name + (files (dired-get-marked-files))) + (mapc + (lambda (curr-file) + (setq new-name + (format "%s/%s" + (file-name-as-directory + (expand-file-name image-dired-main-image-directory)) + (image-dired-get-exif-file-name curr-file))) + (message "Copying %s to %s" curr-file new-name) + (copy-file curr-file new-name)) + files))) + +;;; Thumbnail mode (cont.) + +(defun image-dired-display-next-thumbnail-original (&optional arg) + "Move to the next image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--with-thumbnail-buffer + (image-dired-forward-image arg t) + (image-dired-display-thumbnail-original-image))) + +(defun image-dired-display-previous-thumbnail-original (arg) + "Move to the previous image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired-display-next-thumbnail-original (- arg))) + + +;;; Image Comments + +(defun image-dired-write-comments (file-comments) + "Write file comments to database. +Write file comments to one or more files. +FILE-COMMENTS is an alist on the following form: + ((FILE . COMMENT) ... )" + (image-dired-sane-db-file) + (let (end comment-beg-pos comment-end-pos file comment) + (image-dired--with-db-file + (setq buffer-file-name image-dired-db-file) + (dolist (elt file-comments) + (setq file (car elt) + comment (cdr elt)) + (goto-char (point-min)) + (if (search-forward-regexp (format "^%s.*$" file) nil t) + (progn + (setq end (point)) + (beginning-of-line) + ;; Delete old comment, if any + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (match-beginning 0)) + ;; Any tags after the comment? + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + ;; Delete comment tag and comment + (delete-region comment-beg-pos comment-end-pos)) + ;; Insert new comment + (beginning-of-line) + (unless (search-forward ";" end t) + (end-of-line) + (insert ";")) + (insert (format "comment:%s;" comment))) + ;; File does not exist in database - add it. + (goto-char (point-max)) + (insert (format "%s;comment:%s\n" file comment)))) + (save-buffer)))) + +(defun image-dired-update-property (prop value) + "Update text property PROP with value VALUE at point." + (let ((inhibit-read-only t)) + (put-text-property + (point) (1+ (point)) + prop + value))) + +;;;###autoload +(defun image-dired-dired-comment-files () + "Add comment to current or marked files in Dired." + (interactive) + (let ((comment (image-dired-read-comment))) + (image-dired-write-comments + (mapcar + (lambda (curr-file) + (cons curr-file comment)) + (dired-get-marked-files))))) + +(defun image-dired-comment-thumbnail () + "Add comment to current thumbnail in thumbnail buffer." + (interactive) + (let* ((file (image-dired-original-file-name)) + (comment (image-dired-read-comment file))) + (image-dired-write-comments (list (cons file comment))) + (image-dired-update-property 'comment comment)) + (image-dired-update-header-line)) + +(defun image-dired-read-comment (&optional file) + "Read comment for an image. +Optionally use old comment from FILE as initial value." + (let ((comment + (read-string + "Comment: " + (if file (image-dired-get-comment file))))) + comment)) + +(defun image-dired-get-comment (file) + "Get comment for file FILE." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end comment-beg-pos comment-end-pos comment) + (when (search-forward-regexp (format "^%s" file) nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (when (search-forward ";comment:" end t) + (setq comment-beg-pos (point)) + (if (search-forward ";" end t) + (setq comment-end-pos (- (point) 1)) + (setq comment-end-pos end)) + (setq comment (buffer-substring + comment-beg-pos comment-end-pos)))) + comment))) + +;;;###autoload +(defun image-dired-mark-tagged-files (regexp) + "Use REGEXP to mark files with matching tag. +A `tag' is a keyword, a piece of meta data, associated with an +image file and stored in image-dired's database file. This command +lets you input a regexp and this will be matched against all tags +on all image files in the database file. The files that have a +matching tag will be marked in the Dired buffer." + (interactive "sMark tagged files (regexp): ") + (image-dired-sane-db-file) + (let ((hits 0) + files) + (image-dired--with-db-file + ;; Collect matches + (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t) + (let ((file (match-string 1)) + (tags (split-string (match-string 2) ";"))) + (when (seq-find (lambda (tag) + (string-match-p regexp tag)) + tags) + (push file files))))) + ;; Mark files + (dolist (curr-file files) + ;; I tried using `dired-mark-files-regexp' but it was waaaay to + ;; slow. Don't bother about hits found in other directories + ;; than the current one. + (when (string= (file-name-as-directory + (expand-file-name default-directory)) + (file-name-as-directory + (file-name-directory curr-file))) + (setq curr-file (file-name-nondirectory curr-file)) + (goto-char (point-min)) + (when (search-forward-regexp (format "\\s %s$" curr-file) nil t) + (setq hits (+ hits 1)) + (dired-mark 1)))) + (message "%d files with matching tag marked" hits))) + + + +;;; Mouse support + +(defun image-dired-mouse-display-image (event) + "Use mouse EVENT, call `image-dired-display-image' to display image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (let ((file (image-dired-original-file-name))) + (when file + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-display-image file)))) + +(defun image-dired-mouse-select-thumbnail (event) + "Use mouse EVENT to select thumbnail image. +Track this in associated Dired buffer if `image-dired-track-movement' is +non-nil." + (interactive "e") + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) + (if image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + + + +;;; Dired marks and tags + +(defun image-dired-thumb-file-marked-p (&optional flagged) + "Check if file is marked in associated Dired buffer. +If optional argument FLAGGED is non-nil, check if file is flagged +for deletion instead." + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (when (and dired-buf file-name) + (with-current-buffer dired-buf + (save-excursion + (when (dired-goto-file file-name) + (if flagged + (image-dired-dired-file-flagged-p) + (image-dired-dired-file-marked-p)))))))) + +(defun image-dired-thumb-file-flagged-p () + "Check if file is flagged for deletion in associated Dired buffer." + (image-dired-thumb-file-marked-p t)) + +(defun image-dired-delete-marked () + "Delete current or marked thumbnails and associated images." + (interactive) + (image-dired--with-marked + (image-dired-delete-char) + (unless (bobp) + (backward-char))) + (image-dired--line-up-with-method) + (with-current-buffer (image-dired-associated-dired-buffer) + (dired-do-delete))) + +(defun image-dired-thumb-update-marks () + "Update the marks in the thumbnail buffer." + (when image-dired-thumb-visible-marks + (with-current-buffer image-dired-thumbnail-buffer + (save-mark-and-excursion + (goto-char (point-min)) + (let ((inhibit-read-only t)) + (while (not (eobp)) + (with-silent-modifications + (cond ((image-dired-thumb-file-marked-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-mark)) + ((image-dired-thumb-file-flagged-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-flagged)) + (t (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))))) + (forward-char))))))) + +(defun image-dired-mouse-toggle-mark-1 () + "Toggle Dired mark for current thumbnail. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-toggle-mark-thumb-original-file)) + +(defun image-dired-mouse-toggle-mark (event) + "Use mouse EVENT to toggle Dired mark for thumbnail. +Toggle marks of all thumbnails in region, if it's active. +Track this in associated Dired buffer if +`image-dired-track-movement' is non-nil." + (interactive "e") + (if (use-region-p) + (let ((end (region-end))) + (save-excursion + (goto-char (region-beginning)) + (while (<= (point) end) + (when (image-dired-image-at-point-p) + (image-dired-mouse-toggle-mark-1)) + (forward-char)))) + (mouse-set-point event) + (goto-char (posn-point (event-end event))) + (image-dired-mouse-toggle-mark-1)) + (image-dired-thumb-update-marks)) + +(defun image-dired-dired-display-properties () + "Display properties for Dired file in the echo area." + (interactive) + (let* ((file (dired-get-filename)) + (file-name (file-name-nondirectory file)) + (dired-buf (buffer-name (current-buffer))) + (props (mapconcat #'identity (image-dired-list-tags file) ", ")) + (comment (image-dired-get-comment file)) + (message-log-max nil)) + (if file-name + (message "%s" + (image-dired-format-properties-string + dired-buf + file-name + props + comment))))) + + + +;;; Gallery support + +;; TODO: +;; * Support gallery creation when using per-directory thumbnail +;; storage. +;; * Enhanced gallery creation with basic CSS-support and pagination +;; of tag pages with many pictures. + +(defgroup image-dired-gallery nil + "Image-Dired support for generating a HTML gallery." + :prefix "image-dired-" + :group 'image-dired + :version "29.1") + +(defcustom image-dired-gallery-dir + (expand-file-name ".image-dired_gallery" image-dired-dir) + "Directory to store generated gallery html pages. +The name of this directory needs to be \"shared\" to the public +so that it can access the index.html page that image-dired creates." + :type 'directory) + +(defcustom image-dired-gallery-image-root-url + "https://example.org/image-diredpics" + "URL where the full size images are to be found on your web server. +Note that this URL has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-thumb-image-root-url + "https://example.org/image-diredthumbs" + "URL where the thumbnail images are to be found on your web server. +Note that URL path has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-hidden-tags + (list "private" "hidden" "pending") + "List of \"hidden\" tags. +Used by `image-dired-gallery-generate' to leave out \"hidden\" images." + :type '(repeat string)) + +(defvar image-dired-tag-file-list nil + "List to store tag-file structure.") + +(defvar image-dired-file-tag-list nil + "List to store file-tag structure.") + +(defvar image-dired-file-comment-list nil + "List to store file comments.") + +(defun image-dired--add-to-tag-file-lists (tag file) + "Helper function used from `image-dired--create-gallery-lists'. + +Add TAG to FILE in one list and FILE to TAG in the other. + +Lisp structures look like the following: + +image-dired-file-tag-list: + + ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...) + (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...) + ...) + +image-dired-tag-file-list: + + ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...) + (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...) + ...)" + ;; Add tag to file list + (let (curr) + (if image-dired-file-tag-list + (if (setq curr (assoc file image-dired-file-tag-list)) + (setcdr curr (cons tag (cdr curr))) + (setcdr image-dired-file-tag-list + (cons (list file tag) (cdr image-dired-file-tag-list)))) + (setq image-dired-file-tag-list (list (list file tag)))) + ;; Add file to tag list + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired--add-to-file-comment-list (file comment) + "Helper function used from `image-dired--create-gallery-lists'. + +For FILE, add COMMENT to list. + +Lisp structure looks like the following: + +image-dired-file-comment-list: + + ((\"filename1\" . \"comment1\") + (\"filename2\" . \"comment2\") + ...)" + (if image-dired-file-comment-list + (if (not (assoc file image-dired-file-comment-list)) + (setcdr image-dired-file-comment-list + (cons (cons file comment) + (cdr image-dired-file-comment-list)))) + (setq image-dired-file-comment-list (list (cons file comment))))) + +(defun image-dired--create-gallery-lists () + "Create temporary lists used by `image-dired-gallery-generate'." + (image-dired-sane-db-file) + (image-dired--with-db-file + (let (end beg file row-tags) + (setq image-dired-tag-file-list nil) + (setq image-dired-file-tag-list nil) + (setq image-dired-file-comment-list nil) + (goto-char (point-min)) + (while (search-forward-regexp "^." nil t) + (end-of-line) + (setq end (point)) + (beginning-of-line) + (setq beg (point)) + (unless (search-forward ";" end nil) + (error "Something is really wrong, check format of database")) + (setq row-tags (split-string + (buffer-substring beg end) ";")) + (setq file (car row-tags)) + (dolist (x (cdr row-tags)) + (if (not (string-match "^comment:\\(.*\\)" x)) + (image-dired--add-to-tag-file-lists x file) + (image-dired--add-to-file-comment-list file (match-string 1 x))))))) + ;; Sort tag-file list + (setq image-dired-tag-file-list + (sort image-dired-tag-file-list + (lambda (x y) + (string< (car x) (car y)))))) + +(defun image-dired--hidden-p (file) + "Return t if image FILE has a \"hidden\" tag." + (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list)) + if (member tag image-dired-gallery-hidden-tags) return t)) + +(defun image-dired-gallery-generate () + "Generate gallery pages. +First we create a couple of Lisp structures from the database to make +it easier to generate, then HTML-files are created in +`image-dired-gallery-dir'." + (interactive) + (if (eq 'per-directory image-dired-thumbnail-storage) + (error "Currently, gallery generation is not supported \ +when using per-directory thumbnail file storage")) + (image-dired--create-gallery-lists) + (let ((tags image-dired-tag-file-list) + (index-file (format "%s/index.html" image-dired-gallery-dir)) + count tag tag-file + comment file-tags tag-link tag-link-list) + ;; Make sure gallery root exist + (if (file-exists-p image-dired-gallery-dir) + (if (not (file-directory-p image-dired-gallery-dir)) + (error "Variable image-dired-gallery-dir is not a directory")) + ;; FIXME: Should we set umask to 077 here, as we do for thumbnails? + (make-directory image-dired-gallery-dir)) + ;; Open index file + (with-temp-file index-file + (if (file-exists-p index-file) + (insert-file-contents index-file)) + (insert "\n") + (insert " \n") + (insert "

Image-Dired Gallery

\n") + (insert (format "

\n Gallery generated %s\n

\n" + (current-time-string))) + (insert "

Tag index

\n") + (setq count 1) + ;; Pre-generate list of all tag links + (dolist (curr tags) + (setq tag (car curr)) + (when (not (member tag image-dired-gallery-hidden-tags)) + (setq tag-link (format "%s" count tag)) + (if tag-link-list + (setq tag-link-list + (append tag-link-list (list (cons tag tag-link)))) + (setq tag-link-list (list (cons tag tag-link)))) + (setq count (1+ count)))) + (setq count 1) + ;; Main loop where we generated thumbnail pages per tag + (dolist (curr tags) + (setq tag (car curr)) + ;; Don't display hidden tags + (when (not (member tag image-dired-gallery-hidden-tags)) + ;; Insert link to tag page in index + (insert (format " %s
\n" (cdr (assoc tag tag-link-list)))) + ;; Open per-tag file + (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count)) + (with-temp-file tag-file + (if (file-exists-p tag-file) + (insert-file-contents tag-file)) + (erase-buffer) + (insert "\n") + (insert " \n") + (insert "

Index

\n") + (insert (format "

Images with tag "%s"

" tag)) + ;; Main loop for files per tag page + (dolist (file (cdr curr)) + (unless (image-dired-hidden-p file) + ;; Insert thumbnail with link to full image + (insert + (format "\n" + image-dired-gallery-image-root-url + (file-name-nondirectory file) + image-dired-gallery-thumb-image-root-url + (file-name-nondirectory (image-dired-thumb-name file)) file)) + ;; Insert comment, if any + (if (setq comment (cdr (assoc file image-dired-file-comment-list))) + (insert (format "
\n%s
\n" comment)) + (insert "
\n")) + ;; Insert links to other tags, if any + (when (> (length + (setq file-tags (assoc file image-dired-file-tag-list))) 2) + (insert "[ ") + (dolist (extra-tag file-tags) + ;; Only insert if not file name or the main tag + (if (and (not (equal extra-tag tag)) + (not (equal extra-tag file))) + (insert + (format "%s " (cdr (assoc extra-tag tag-link-list)))))) + (insert "]
\n")))) + (insert "

Index

\n") + (insert " \n") + (insert "\n")) + (setq count (1+ count)))) + (insert " \n") + (insert "")))) + + +;;; Tag support + +(defvar image-dired-widget-list nil + "List to keep track of meta data in edit buffer.") + +(declare-function widget-forward "wid-edit" (arg)) + +;;;###autoload +(defun image-dired-dired-edit-comment-and-tags () + "Edit comment and tags of current or marked image files. +Edit comment and tags for all marked image files in an +easy-to-use form." + (interactive) + (setq image-dired-widget-list nil) + ;; Setup buffer. + (let ((files (dired-get-marked-files))) + (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*") + (kill-all-local-variables) + (let ((inhibit-read-only t)) + (erase-buffer)) + (remove-overlays) + ;; Some help for the user. + (widget-insert +"\nEdit comments and tags for each image. Separate multiple tags +with a comma. Move forward between fields using TAB or RET. +Move to the previous field using backtab (S-TAB). Save by +activating the Save button at the bottom of the form or cancel +the operation by activating the Cancel button.\n\n") + ;; Here comes all images and a comment and tag field for each + ;; image. + (let (thumb-file img comment-widget tag-widget) + + (dolist (file files) + + (setq thumb-file (image-dired-thumb-name file) + img (create-image thumb-file)) + + (insert-image img) + (widget-insert "\n\nComment: ") + (setq comment-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (image-dired-get-comment file) ""))) + (widget-insert "\nTags: ") + (setq tag-widget + (widget-create 'editable-field + :size 60 + :format "%v " + :value (or (mapconcat + #'identity + (image-dired-list-tags file) + ",") ""))) + ;; Save information in all widgets so that we can use it when + ;; the user saves the form. + (setq image-dired-widget-list + (append image-dired-widget-list + (list (list file comment-widget tag-widget)))) + (widget-insert "\n\n"))) + + ;; Footer with Save and Cancel button. + (widget-insert "\n") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (image-dired-save-information-from-widgets) + (bury-buffer) + (message "Done")) + "Save") + (widget-insert " ") + (widget-create 'push-button + :notify + (lambda (&rest _ignore) + (bury-buffer) + (message "Operation canceled")) + "Cancel") + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + ;; Jump to the first widget. + (widget-forward 1))) + +(defun image-dired-save-information-from-widgets () + "Save information found in `image-dired-widget-list'. +Use the information in `image-dired-widget-list' to save comments and +tags to their respective image file. Internal function used by +`image-dired-dired-edit-comment-and-tags'." + (let (file comment tag-string tag-list lst) + (image-dired-write-comments + (mapcar + (lambda (widget) + (setq file (car widget) + comment (widget-value (cadr widget))) + (cons file comment)) + image-dired-widget-list)) + (image-dired-write-tags + (dolist (widget image-dired-widget-list lst) + (setq file (car widget) + tag-string (widget-value (car (cddr widget))) + tag-list (split-string tag-string ",")) + (dolist (tag tag-list) + (push (cons file tag) lst)))))) + + +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun image-dired-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (file-name-nondirectory + (directory-file-name + (file-name-directory (image-dired-original-file-name))))) + +(defun image-dired-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(image-dired-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(file-name-directory (image-dired-original-file-name))) + (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name))) + (handler . image-dired-bookmark-jump))) + +;;;###autoload +(defun image-dired-bookmark-jump (bookmark) + "Default bookmark handler for Image-Dired buffers." + ;; User already cached thumbnails, so disable any checking. + (let ((image-dired-show-all-from-dir-max-files nil)) + (image-dired (bookmark-prop-get bookmark 'location)) + ;; TODO: Go to the bookmarked file, if it exists. + ;; (bookmark-prop-get bookmark 'image-dired-file) + (goto-char (point-min)))) + +(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired") + +;;; Obsolete + +;;;###autoload +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +;;;###autoload +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings + #'image-dired-minor-mode "26.1") + +(defcustom image-dired-temp-image-file + (expand-file-name ".image-dired_temp" image-dired-dir) + "Name of temporary image file used by various commands." + :type 'file) +(make-obsolete-variable 'image-dired-temp-image-file + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-program + (if (executable-find "gm") "gm" "convert") + "Executable used to create temporary image. +Used together with `image-dired-cmd-create-temp-image-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-create-temp-image-program + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) + "Options of command used to create temporary image for display window. +Used together with `image-dired-cmd-create-temp-image-program', +Available format specifiers are: %w and %h which are replaced by +the calculated max size for width and height in the image display window, +%f which is replaced by the file name of the original image and %t which +is replaced by the file name of the temporary file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-create-temp-image-options + "no longer used." "29.1") + +(defcustom image-dired-display-window-width-correction 1 + "Number to be used to correct image display window width. +Change if the default (1) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-width-correction + "no longer used." "29.1") + +(defcustom image-dired-display-window-height-correction 0 + "Number to be used to correct image display window height. +Change if the default (0) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-height-correction + "no longer used." "29.1") + +(defun image-dired-display-window-width (window) + "Return width, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-width-pixels window) + image-dired-display-window-width-correction)) + +(defun image-dired-display-window-height (window) + "Return height, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-height-pixels window) + image-dired-display-window-height-correction)) + +(defun image-dired-window-height-pixels (window) + "Calculate WINDOW height in pixels." + (declare (obsolete nil "29.1")) + ;; Note: The mode-line consumes one line + (* (- (window-height window) 1) (frame-char-height))) + +(defcustom image-dired-cmd-read-exif-data-program "exiftool" + "Program used to read EXIF data to image. +Used together with `image-dired-cmd-read-exif-data-options'." + :type 'file) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-program + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f") + "Arguments of command used to read EXIF data. +Used with `image-dired-cmd-read-exif-data-program'. +Available format specifiers are: %f which is replaced +by the image file name and %t which is replaced by the tag name." + :version "26.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-options + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defun image-dired-get-exif-data (file tag-name) + "From FILE, return EXIF tag TAG-NAME." + (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-read-exif-data-program) + (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) + (spec (list (cons ?f file) (cons ?t tag-name))) + tag-value) + (with-current-buffer buf + (delete-region (point-min) (point-max)) + (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program + nil t nil + (mapcar + (lambda (arg) (format-spec arg spec)) + image-dired-cmd-read-exif-data-options)) + 0)) + (error "Could not get EXIF tag") + (goto-char (point-min)) + ;; Clean buffer from newlines and carriage returns before + ;; getting final info + (while (search-forward-regexp "[\n\r]" nil t) + (replace-match "" nil t)) + (setq tag-value (buffer-substring (point-min) (point-max))))) + tag-value)) + +(defcustom image-dired-cmd-rotate-thumbnail-program + (if (executable-find "gm") "gm" "mogrify") + "Executable used to rotate thumbnail. +Used together with `image-dired-cmd-rotate-thumbnail-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1") + +(defcustom image-dired-cmd-rotate-thumbnail-options + (let ((opts '("-rotate" "%d" "%t"))) + (if (executable-find "gm") (cons "mogrify" opts) opts)) + "Arguments of command used to rotate thumbnail image. +Used with `image-dired-cmd-rotate-thumbnail-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or 270 +\(for 90 degrees right and left), %t which is replaced by the file name +of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") + +(defun image-dired-rotate-thumbnail (degrees) + "Rotate thumbnail DEGREES degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-thumbnail-program) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) + (thumb (expand-file-name file)) + (spec (list (cons ?d degrees) (cons ?t thumb)))) + (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-thumbnail-options)) + (clear-image-cache thumb)))) + +(defun image-dired-rotate-thumbnail-left () + "Rotate thumbnail left (counter clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "270"))) + +(defun image-dired-rotate-thumbnail-right () + "Rotate thumbnail counter right (clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "90"))) + +(defun image-dired-modify-mark-on-thumb-original-file (command) + "Modify mark in Dired buffer. +COMMAND is one of `mark' for marking file in Dired, `unmark' for +unmarking file in Dired or `flag' for flagging file for delete in +Dired." + (declare (obsolete image-dired--on-file-in-dired-buffer "29.1")) + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point") + (with-current-buffer dired-buf + (message "%s" file-name) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) + +(defun image-dired-display-current-image-full () + "Display current image in full size." + (declare (obsolete image-transform-original "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file) + (with-current-buffer image-dired-display-image-buffer + (image-transform-original))) + (error "No original file name at point")))) + +(defun image-dired-display-current-image-sized () + "Display current image in sized to fit window dimensions." + (declare (obsolete image-mode-fit-frame "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file)) + (error "No original file name at point")))) + +(defun image-dired-add-to-tag-file-list (tag file) + "Add relation between TAG and FILE." + (declare (obsolete nil "29.1")) + (let (curr) + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired-display-thumb-properties () + "Display thumbnail properties in the echo area." + (declare (obsolete image-dired-update-header-line "29.1")) + (image-dired-update-header-line)) + +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + +(define-obsolete-function-alias 'image-dired-create-display-image-buffer + #'ignore "29.1") +(define-obsolete-function-alias 'image-dired-create-gallery-lists + #'image-dired--create-gallery-lists "29.1") +(define-obsolete-function-alias 'image-dired-add-to-file-comment-list + #'image-dired--add-to-file-comment-list "29.1") +(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists + #'image-dired--add-to-tag-file-lists "29.1") +(define-obsolete-function-alias 'image-dired-hidden-p + #'image-dired--hidden-p "29.1") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;; TEST-SECTION ;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (defvar image-dired-dir-max-size 12300000) + +;; (defun image-dired-test-clean-old-files () +;; "Clean `image-dired-dir' from old thumbnail files. +;; \"Oldness\" measured using last access time. If the total size of all +;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size', +;; old files are deleted until the max size is reached." +;; (let* ((files +;; (sort +;; (mapcar +;; (lambda (f) +;; (let ((fattribs (file-attributes f))) +;; `(,(file-attribute-access-time fattribs) +;; ,(file-attribute-size fattribs) ,f))) +;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$")) +;; ;; Sort function. Compare time between two files. +;; (lambda (l1 l2) +;; (time-less-p (car l1) (car l2))))) +;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files)))) +;; (while (> dirsize image-dired-dir-max-size) +;; (y-or-n-p +;; (format "Size of thumbnail directory: %d, delete old file %s? " +;; dirsize (cadr (cdar files)))) +;; (delete-file (cadr (cdar files))) +;; (setq dirsize (- dirsize (car (cdar files)))) +;; (setq files (cdr files))))) + +(provide 'image-dired) + +;;; image-dired.el ends here diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image/image-dired-tests.el similarity index 100% rename from test/lisp/image-dired-tests.el rename to test/lisp/image/image-dired-tests.el -- 2.39.2