aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Kangas2022-08-19 20:41:11 +0200
committerStefan Kangas2022-09-03 10:23:37 +0200
commit0504f39259f0afb0bfeb73b294f523d20b20091c (patch)
treec8c03f67ac0589bd230c568d59ab407d1e1b6e2c
parente13509468b7cc733c3511310d999554e6bcda708 (diff)
downloademacs-0504f39259f0afb0bfeb73b294f523d20b20091c.tar.gz
emacs-0504f39259f0afb0bfeb73b294f523d20b20091c.zip
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.
-rw-r--r--lisp/image/image-dired-dired.el (renamed from lisp/image-dired.el)0
-rw-r--r--lisp/image/image-dired-external.el3080
-rw-r--r--lisp/image/image-dired-tags.el3080
-rw-r--r--lisp/image/image-dired-util.el3080
-rw-r--r--lisp/image/image-dired.el3080
-rw-r--r--test/lisp/image/image-dired-tests.el (renamed from test/lisp/image-dired-tests.el)0
6 files changed, 12320 insertions, 0 deletions
diff --git a/lisp/image-dired.el b/lisp/image/image-dired-dired.el
index 9f12354111c..9f12354111c 100644
--- a/lisp/image-dired.el
+++ b/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 @@
1;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*-
2
3;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
4
5;; Version: 0.4.11
6;; Keywords: multimedia
7;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; BACKGROUND
27;; ==========
28;;
29;; I needed a program to browse, organize and tag my pictures. I got
30;; tired of the old gallery program I used as it did not allow
31;; multi-file operations easily. Also, it put things out of my
32;; control. Image viewing programs I tested did not allow multi-file
33;; operations or did not do what I wanted it to.
34;;
35;; So, I got the idea to use the wonderful functionality of Emacs and
36;; `dired' to do it. It would allow me to do almost anything I wanted,
37;; which is basically just to browse all my pictures in an easy way,
38;; letting me manipulate and tag them in various ways. `dired' already
39;; provide all the file handling and navigation facilities; I only
40;; needed to add some functions to display the images.
41;;
42;; I briefly tried out thumbs.el, and although it seemed more
43;; powerful than this package, it did not work the way I wanted to. It
44;; was too slow to create thumbnails of all files in a directory (I
45;; currently keep all my 2000+ images in the same directory) and
46;; browsing the thumbnail buffer was slow too. image-dired.el will not
47;; create thumbnails until they are needed and the browsing is done
48;; quickly and easily in Dired. I copied a great deal of ideas and
49;; code from there though... :)
50;;
51;; `image-dired' stores the thumbnail files in `image-dired-dir'
52;; using the file name format ORIGNAME.thumb.ORIGEXT. For example
53;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for
54;; now just a plain text file with the following format:
55;;
56;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN
57;;
58;;
59;; PREREQUISITES
60;; =============
61;;
62;; * The GraphicsMagick or ImageMagick package; Image-Dired uses
63;; whichever is available.
64;;
65;; A) For GraphicsMagick, `gm' is used.
66;; Find it here: http://www.graphicsmagick.org/
67;;
68;; B) For ImageMagick, `convert' and `mogrify' are used.
69;; Find it here: https://www.imagemagick.org.
70;;
71;; * For non-lossy rotation of JPEG images, the JpegTRAN program is
72;; needed.
73;;
74;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is
75;; needed. It can be found here: https://exiftool.org/. This
76;; function is, among other things, used for writing comments to
77;; image files using `image-dired-thumbnail-set-image-description'.
78;;
79;;
80;; USAGE
81;; =====
82;;
83;; This information has been moved to the manual. Type `C-h r' to open
84;; the Emacs manual and go to the node Thumbnails by typing `g
85;; Image-Dired RET'.
86;;
87;; Quickstart: M-x image-dired RET DIRNAME RET
88;;
89;; where DIRNAME is a directory containing image files.
90;;
91;; LIMITATIONS
92;; ===========
93;;
94;; * Supports all image formats that Emacs and convert supports, but
95;; the thumbnails are hard-coded to JPEG or PNG format. It uses
96;; JPEG by default, but can optionally follow the Thumbnail Managing
97;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user
98;; option `image-dired-thumbnail-storage'.
99;;
100;; * WARNING: The "database" format used might be changed so keep a
101;; backup of `image-dired-db-file' when testing new versions.
102;;
103;; TODO
104;; ====
105;;
106;; * Investigate if it is possible to also write the tags to the image
107;; files.
108;;
109;; * From thumbs.el: Add an option for clean-up/max-size functionality
110;; for thumbnail directory.
111;;
112;; * From thumbs.el: Add setroot function.
113;;
114;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out
115;; which is best, saving old batch just before inserting new, or
116;; saving the current batch in the ring when inserting it. Adding
117;; it probably needs rewriting `image-dired-display-thumbs' to be more general.
118;;
119;; * Find some way of toggling on and off really nice keybindings in
120;; Dired (for example, using C-n or <down> instead of C-S-n).
121;; Richard suggested that we could keep C-t as prefix for
122;; image-dired commands as it is currently not used in Dired. He
123;; also suggested that `dired-next-line' and `dired-previous-line'
124;; figure out if image-dired is enabled in the current buffer and,
125;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line',
126;; respectively. Update: This is partly done; some bindings have
127;; now been added to Dired.
128;;
129;; * In some way keep track of buffers and windows and stuff so that
130;; it works as the user expects.
131;;
132;; * More/better documentation.
133
134;;; Code:
135
136(require 'dired)
137(require 'exif)
138(require 'image-mode)
139(require 'widget)
140(require 'xdg)
141
142(eval-when-compile
143 (require 'cl-lib)
144 (require 'wid-edit))
145
146
147;;; Customizable variables
148
149(defgroup image-dired nil
150 "Use Dired to browse your images as thumbnails, and more."
151 :prefix "image-dired-"
152 :link '(info-link "(emacs) Image-Dired")
153 :group 'multimedia)
154
155(defcustom image-dired-dir (locate-user-emacs-file "image-dired/")
156 "Directory where thumbnail images are stored.
157
158The value of this option will be ignored if Image-Dired is
159customized to use the Thumbnail Managing Standard; they will be
160saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See
161`image-dired-thumbnail-storage'."
162 :type 'directory)
163
164(defcustom image-dired-thumbnail-storage 'use-image-dired-dir
165 "How `image-dired' stores thumbnail files.
166There are two ways that Image-Dired can store and generate
167thumbnails. If you set this variable to one of the two following
168values, they will be stored in the JPEG format:
169
170- `use-image-dired-dir' means that the thumbnails are stored in a
171 central directory.
172
173- `per-directory' means that each thumbnail is stored in a
174 subdirectory called \".image-dired\" in the same directory
175 where the image file is.
176
177It can also use the \"Thumbnail Managing Standard\", which allows
178sharing of thumbnails across different programs. Thumbnails will
179be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in
180`image-dired-dir'. Thumbnails are saved in the PNG format, and
181can be one of the following sizes:
182
183- `standard' means use thumbnails sized 128x128.
184- `standard-large' means use thumbnails sized 256x256.
185- `standard-x-large' means use thumbnails sized 512x512.
186- `standard-xx-large' means use thumbnails sized 1024x1024.
187
188For more information on the Thumbnail Managing Standard, see:
189https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html"
190 :type '(choice :tag "How to store thumbnail files"
191 (const :tag "Use image-dired-dir" use-image-dired-dir)
192 (const :tag "Thumbnail Managing Standard (normal 128x128)"
193 standard)
194 (const :tag "Thumbnail Managing Standard (large 256x256)"
195 standard-large)
196 (const :tag "Thumbnail Managing Standard (larger 512x512)"
197 standard-x-large)
198 (const :tag "Thumbnail Managing Standard (extra large 1024x1024)"
199 standard-xx-large)
200 (const :tag "Per-directory" per-directory))
201 :version "29.1")
202
203(defconst image-dired--thumbnail-standard-sizes
204 '( standard standard-large
205 standard-x-large standard-xx-large)
206 "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
207
208(defcustom image-dired-db-file
209 (expand-file-name ".image-dired_db" image-dired-dir)
210 "Database file where file names and their associated tags are stored."
211 :type 'file)
212
213(defcustom image-dired-cmd-create-thumbnail-program
214 (if (executable-find "gm") "gm" "convert")
215 "Executable used to create thumbnail.
216Used together with `image-dired-cmd-create-thumbnail-options'."
217 :type 'file
218 :version "29.1")
219
220(defcustom image-dired-cmd-create-thumbnail-options
221 (let ((opts '("-size" "%wx%h" "%f[0]"
222 "-resize" "%wx%h>"
223 "-strip" "jpeg:%t")))
224 (if (executable-find "gm") (cons "convert" opts) opts))
225 "Options of command used to create thumbnail image.
226Used with `image-dired-cmd-create-thumbnail-program'.
227Available format specifiers are: %w which is replaced by
228`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
229%f which is replaced by the file name of the original image and %t
230which is replaced by the file name of the thumbnail file."
231 :version "29.1"
232 :type '(repeat (string :tag "Argument")))
233
234(defcustom image-dired-cmd-pngnq-program
235 ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
236 ;; The project also seems more active than the alternatives.
237 ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
238 ;; The pngnq project seems dead (?) since 2011 or so.
239 (or (executable-find "pngquant")
240 (executable-find "pngnq-s9")
241 (executable-find "pngnq"))
242 "The file name of the `pngquant' or `pngnq' program.
243It quantizes colors of PNG images down to 256 colors or fewer
244using the NeuQuant algorithm."
245 :version "29.1"
246 :type '(choice (const :tag "Not Set" nil) file))
247
248(defcustom image-dired-cmd-pngnq-options
249 (if (executable-find "pngquant")
250 '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
251 '("-f" "%t"))
252 "Arguments to pass `image-dired-cmd-pngnq-program'.
253Available format specifiers are the same as in
254`image-dired-cmd-create-thumbnail-options'."
255 :type '(repeat (string :tag "Argument"))
256 :version "29.1")
257
258(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
259 "The file name of the `pngcrush' program.
260It optimizes the compression of PNG images. Also it adds PNG textual chunks
261with the information required by the Thumbnail Managing Standard."
262 :type '(choice (const :tag "Not Set" nil) file))
263
264(defcustom image-dired-cmd-pngcrush-options
265 `("-q"
266 "-text" "b" "Description" "Thumbnail of file://%f"
267 "-text" "b" "Software" ,(emacs-version)
268 ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
269 ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
270 ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
271 "-text" "b" "Thumb::MTime" "%m"
272 ;; "-text b \"Thumb::Size\" \"%b\" "
273 "-text" "b" "Thumb::URI" "file://%f"
274 "%q" "%t")
275 "Arguments for `image-dired-cmd-pngcrush-program'.
276Available format specifiers are the same as in
277`image-dired-cmd-create-thumbnail-options', with %q for a
278temporary file name (typically generated by pnqnq)."
279 :version "26.1"
280 :type '(repeat (string :tag "Argument")))
281
282(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
283 "The file name of the `optipng' program."
284 :version "26.1"
285 :type '(choice (const :tag "Not Set" nil) file))
286
287(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
288 "Arguments passed to `image-dired-cmd-optipng-program'.
289Available format specifiers are described in
290`image-dired-cmd-create-thumbnail-options'."
291 :version "26.1"
292 :type '(repeat (string :tag "Argument"))
293 :link '(url-link "man:optipng(1)"))
294
295(defcustom image-dired-cmd-create-standard-thumbnail-options
296 (append '("-size" "%wx%h" "%f[0]")
297 (unless (or image-dired-cmd-pngcrush-program
298 image-dired-cmd-pngnq-program)
299 (list
300 "-set" "Thumb::MTime" "%m"
301 "-set" "Thumb::URI" "file://%f"
302 "-set" "Description" "Thumbnail of file://%f"
303 "-set" "Software" (emacs-version)))
304 '("-thumbnail" "%wx%h>" "png:%t"))
305 "Options for creating thumbnails according to the Thumbnail Managing Standard.
306Available format specifiers are the same as in
307`image-dired-cmd-create-thumbnail-options', with %m for file modification time."
308 :version "26.1"
309 :type '(repeat (string :tag "Argument")))
310
311(defcustom image-dired-cmd-rotate-original-program
312 "jpegtran"
313 "Executable used to rotate original image.
314Used together with `image-dired-cmd-rotate-original-options'."
315 :type 'file)
316
317(defcustom image-dired-cmd-rotate-original-options
318 '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
319 "Arguments of command used to rotate original image.
320Used with `image-dired-cmd-rotate-original-program'.
321Available format specifiers are: %d which is replaced by the
322number of (positive) degrees to rotate the image, normally 90 or
323270 \(for 90 degrees right and left), %o which is replaced by the
324original image file name and %t which is replaced by
325`image-dired-temp-image-file'."
326 :version "26.1"
327 :type '(repeat (string :tag "Argument")))
328
329(defcustom image-dired-temp-rotate-image-file
330 (expand-file-name ".image-dired_rotate_temp" image-dired-dir)
331 "Temporary file for rotate operations."
332 :type 'file)
333
334(defcustom image-dired-rotate-original-ask-before-overwrite t
335 "Confirm overwrite of original file after rotate operation.
336If non-nil, ask user for confirmation before overwriting the
337original file with `image-dired-temp-rotate-image-file'."
338 :type 'boolean)
339
340(defcustom image-dired-cmd-write-exif-data-program
341 "exiftool"
342 "Program used to write EXIF data to image.
343Used together with `image-dired-cmd-write-exif-data-options'."
344 :type 'file)
345
346(defcustom image-dired-cmd-write-exif-data-options
347 '("-%t=%v" "%f")
348 "Arguments of command used to write EXIF data.
349Used with `image-dired-cmd-write-exif-data-program'.
350Available format specifiers are: %f which is replaced by
351the image file name, %t which is replaced by the tag name and %v
352which is replaced by the tag value."
353 :version "26.1"
354 :type '(repeat (string :tag "Argument")))
355
356(defcustom image-dired-thumb-size
357 (cond
358 ((eq 'standard image-dired-thumbnail-storage) 128)
359 ((eq 'standard-large image-dired-thumbnail-storage) 256)
360 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
361 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
362 (t 100))
363 "Size of thumbnails, in pixels.
364This is the default size for both `image-dired-thumb-width'
365and `image-dired-thumb-height'.
366
367The value of this option will be ignored if Image-Dired is
368customized to use the Thumbnail Managing Standard; the standard
369sizes will be used instead. See `image-dired-thumbnail-storage'."
370 :type 'integer)
371
372(defcustom image-dired-thumb-width image-dired-thumb-size
373 "Width of thumbnails, in pixels."
374 :type 'integer)
375
376(defcustom image-dired-thumb-height image-dired-thumb-size
377 "Height of thumbnails, in pixels."
378 :type 'integer)
379
380(defcustom image-dired-thumb-relief 2
381 "Size of button-like border around thumbnails."
382 :type 'integer)
383
384(defcustom image-dired-thumb-margin 2
385 "Size of the margin around thumbnails.
386This is where you see the cursor."
387 :type 'integer)
388
389(defcustom image-dired-thumb-visible-marks t
390 "Make marks and flags visible in thumbnail buffer.
391If non-nil, apply the `image-dired-thumb-mark' face to marked
392images and `image-dired-thumb-flagged' to images flagged for
393deletion."
394 :type 'boolean
395 :version "28.1")
396
397(defface image-dired-thumb-mark
398 '((((class color) (min-colors 16)) :background "DarkOrange")
399 (((class color)) :foreground "yellow"))
400 "Face for marked images in thumbnail buffer."
401 :version "29.1")
402
403(defface image-dired-thumb-flagged
404 '((((class color) (min-colors 88) (background light)) :background "Red3")
405 (((class color) (min-colors 88) (background dark)) :background "Pink")
406 (((class color) (min-colors 16) (background light)) :background "Red3")
407 (((class color) (min-colors 16) (background dark)) :background "Pink")
408 (((class color) (min-colors 8)) :background "red")
409 (t :inverse-video t))
410 "Face for images flagged for deletion in thumbnail buffer."
411 :version "29.1")
412
413(defcustom image-dired-line-up-method 'dynamic
414 "Default method for line-up of thumbnails in thumbnail buffer.
415Used by `image-dired-display-thumbs' and other functions that needs
416to line-up thumbnails. Dynamic means to use the available width of
417the window containing the thumbnail buffer, Fixed means to use
418`image-dired-thumbs-per-row', Interactive is for asking the user,
419and No line-up means that no automatic line-up will be done."
420 :type '(choice :tag "Default line-up method"
421 (const :tag "Dynamic" dynamic)
422 (const :tag "Fixed" fixed)
423 (const :tag "Interactive" interactive)
424 (const :tag "No line-up" none)))
425
426(defcustom image-dired-thumbs-per-row 3
427 "Number of thumbnails to display per row in thumb buffer."
428 :type 'integer)
429
430(defcustom image-dired-track-movement t
431 "The current state of the tracking and mirroring.
432For more information, see the documentation for
433`image-dired-toggle-movement-tracking'."
434 :type 'boolean)
435
436(defcustom image-dired-append-when-browsing nil
437 "Append thumbnails in thumbnail buffer when browsing.
438If non-nil, using `image-dired-next-line-and-display' and
439`image-dired-previous-line-and-display' will leave a trail of thumbnail
440images in the thumbnail buffer. If you enable this and want to clean
441the thumbnail buffer because it is filled with too many thumbnails,
442just call `image-dired-display-thumb' to display only the image at point.
443This value can be toggled using `image-dired-toggle-append-browsing'."
444 :type 'boolean)
445
446(defcustom image-dired-dired-disp-props t
447 "If non-nil, display properties for Dired file when browsing.
448Used by `image-dired-next-line-and-display',
449`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'.
450If the database file is large, this can slow down image browsing in
451Dired and you might want to turn it off."
452 :type 'boolean)
453
454(defcustom image-dired-display-properties-format "%b: %f (%t): %c"
455 "Display format for thumbnail properties.
456%b is replaced with associated Dired buffer name, %f with file
457name (without path) of original image file, %t with the list of
458tags and %c with the comment."
459 :type 'string)
460
461(defcustom image-dired-external-viewer
462 ;; TODO: Use mailcap, dired-guess-shell-alist-default,
463 ;; dired-view-command-alist.
464 (cond ((executable-find "display"))
465 ((executable-find "xli"))
466 ((executable-find "qiv") "qiv -t")
467 ((executable-find "feh") "feh"))
468 "Name of external viewer.
469Including parameters. Used when displaying original image from
470`image-dired-thumbnail-mode'."
471 :version "28.1"
472 :type '(choice string
473 (const :tag "Not Set" nil)))
474
475(defcustom image-dired-main-image-directory
476 (or (xdg-user-dir "PICTURES") "~/pics/")
477 "Name of main image directory, if any.
478Used by `image-dired-copy-with-exif-file-name'."
479 :type 'string
480 :version "29.1")
481
482(defcustom image-dired-show-all-from-dir-max-files 500
483 "Maximum number of files in directory before prompting.
484
485If there are more image files than this in a selected directory,
486the `image-dired-show-all-from-dir' command will ask for
487confirmation before creating the thumbnail buffer. If this
488variable is nil, it will never ask."
489 :type '(choice integer
490 (const :tag "Disable warning" nil))
491 :version "29.1")
492
493(defcustom image-dired-marking-shows-next t
494 "If non-nil, marking, unmarking or flagging an image shows the next image.
495
496This affects the following commands:
497\\<image-dired-thumbnail-mode-map>
498 `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file])
499 `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file])
500 `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])"
501 :type 'boolean
502 :version "29.1")
503
504
505;;; Util functions
506
507(defvar image-dired-debug nil
508 "Non-nil means enable debug messages.")
509
510(defun image-dired-debug-message (&rest args)
511 "Display debug message ARGS when `image-dired-debug' is non-nil."
512 (when image-dired-debug
513 (apply #'message args)))
514
515(defmacro image-dired--with-db-file (&rest body)
516 "Run BODY in a temp buffer containing `image-dired-db-file'.
517Return the last form in BODY."
518 (declare (indent 0) (debug t))
519 `(with-temp-buffer
520 (if (file-exists-p image-dired-db-file)
521 (insert-file-contents image-dired-db-file))
522 ,@body))
523
524(defun image-dired-dir ()
525 "Return the current thumbnail directory (from variable `image-dired-dir').
526Create the thumbnail directory if it does not exist."
527 (let ((image-dired-dir (file-name-as-directory
528 (expand-file-name image-dired-dir))))
529 (unless (file-directory-p image-dired-dir)
530 (with-file-modes #o700
531 (make-directory image-dired-dir t))
532 (message "Thumbnail directory created: %s" image-dired-dir))
533 image-dired-dir))
534
535(defun image-dired-insert-image (file type relief margin)
536 "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point."
537 (let ((i `(image :type ,type
538 :file ,file
539 :relief ,relief
540 :margin ,margin)))
541 (insert-image i)))
542
543(defun image-dired-get-thumbnail-image (file)
544 "Return the image descriptor for a thumbnail of image file FILE."
545 (unless (string-match-p (image-file-name-regexp) file)
546 (error "%s is not a valid image file" file))
547 (let* ((thumb-file (image-dired-thumb-name file))
548 (thumb-attr (file-attributes thumb-file)))
549 (when (or (not thumb-attr)
550 (time-less-p (file-attribute-modification-time thumb-attr)
551 (file-attribute-modification-time
552 (file-attributes file))))
553 (image-dired-create-thumb file thumb-file))
554 (create-image thumb-file)))
555
556(defun image-dired-insert-thumbnail (file original-file-name
557 associated-dired-buffer)
558 "Insert thumbnail image FILE.
559Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
560 (let (beg end)
561 (setq beg (point))
562 (image-dired-insert-image
563 file
564 ;; Thumbnails are created asynchronously, so we might not yet
565 ;; have a file. But if it exists, it might have been cached from
566 ;; before and we should use it instead of our current settings.
567 (or (and (file-exists-p file)
568 (image-type-from-file-header file))
569 (and (memq image-dired-thumbnail-storage
570 image-dired--thumbnail-standard-sizes)
571 'png)
572 'jpeg)
573 image-dired-thumb-relief
574 image-dired-thumb-margin)
575 (setq end (point))
576 (add-text-properties
577 beg end
578 (list 'image-dired-thumbnail t
579 'original-file-name original-file-name
580 'associated-dired-buffer associated-dired-buffer
581 'tags (image-dired-list-tags original-file-name)
582 'mouse-face 'highlight
583 'comment (image-dired-get-comment original-file-name)))))
584
585(defun image-dired-thumb-name (file)
586 "Return absolute file name for thumbnail FILE.
587Depending on the value of `image-dired-thumbnail-storage', the
588file name of the thumbnail will vary:
589- For `use-image-dired-dir', make a SHA1-hash of the image file's
590 directory name and add that to make the thumbnail file name
591 unique.
592- For `per-directory' storage, just add a subdirectory.
593- For `standard' storage, produce the file name according to the
594 Thumbnail Managing Standard. Among other things, an MD5-hash
595 of the image file's directory name will be added to the
596 filename.
597See also `image-dired-thumbnail-storage'."
598 (cond ((memq image-dired-thumbnail-storage
599 image-dired--thumbnail-standard-sizes)
600 (let ((thumbdir (cl-case image-dired-thumbnail-storage
601 (standard "thumbnails/normal")
602 (standard-large "thumbnails/large")
603 (standard-x-large "thumbnails/x-large")
604 (standard-xx-large "thumbnails/xx-large"))))
605 (expand-file-name
606 ;; MD5 is mandated by the Thumbnail Managing Standard.
607 (concat (md5 (concat "file://" (expand-file-name file))) ".png")
608 (expand-file-name thumbdir (xdg-cache-home)))))
609 ((eq 'use-image-dired-dir image-dired-thumbnail-storage)
610 (let* ((f (expand-file-name file))
611 (hash
612 (md5 (file-name-as-directory (file-name-directory f)))))
613 (format "%s%s%s.thumb.%s"
614 (file-name-as-directory (expand-file-name (image-dired-dir)))
615 (file-name-base f)
616 (if hash (concat "_" hash) "")
617 (file-name-extension f))))
618 ((eq 'per-directory image-dired-thumbnail-storage)
619 (let ((f (expand-file-name file)))
620 (format "%s.image-dired/%s.thumb.%s"
621 (file-name-directory f)
622 (file-name-base f)
623 (file-name-extension f))))))
624
625(defun image-dired--check-executable-exists (executable)
626 (unless (executable-find (symbol-value executable))
627 (error "Executable %S not found" executable)))
628
629
630;;; Creating thumbnails
631
632(defun image-dired-thumb-size (dimension)
633 "Return thumb size depending on `image-dired-thumbnail-storage'.
634DIMENSION should be either the symbol `width' or `height'."
635 (cond
636 ((eq 'standard image-dired-thumbnail-storage) 128)
637 ((eq 'standard-large image-dired-thumbnail-storage) 256)
638 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
639 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
640 (t (cl-ecase dimension
641 (width image-dired-thumb-width)
642 (height image-dired-thumb-height)))))
643
644(defvar image-dired--generate-thumbs-start nil
645 "Time when `display-thumbs' was called.")
646
647(defvar image-dired-queue nil
648 "List of items in the queue.
649Each item has the form (ORIGINAL-FILE TARGET-FILE).")
650
651(defvar image-dired-queue-active-jobs 0
652 "Number of active jobs in `image-dired-queue'.")
653
654(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
655 "Maximum number of concurrent jobs permitted for generating images.
656Increase at own risk. If you want to experiment with this,
657consider setting `image-dired-debug' to a non-nil value to see
658the time spent on generating thumbnails. Run `image-clear-cache'
659and remove the cached thumbnail files between each trial run.")
660
661(defun image-dired-pngnq-thumb (spec)
662 "Quantize thumbnail described by format SPEC with pngnq(1)."
663 (let ((process
664 (apply #'start-process "image-dired-pngnq" nil
665 image-dired-cmd-pngnq-program
666 (mapcar (lambda (arg) (format-spec arg spec))
667 image-dired-cmd-pngnq-options))))
668 (setf (process-sentinel process)
669 (lambda (process status)
670 (if (and (eq (process-status process) 'exit)
671 (zerop (process-exit-status process)))
672 ;; Pass off to pngcrush, or just rename the
673 ;; THUMB-nq8.png file back to THUMB.png
674 (if (and image-dired-cmd-pngcrush-program
675 (executable-find image-dired-cmd-pngcrush-program))
676 (image-dired-pngcrush-thumb spec)
677 (let ((nq8 (cdr (assq ?q spec)))
678 (thumb (cdr (assq ?t spec))))
679 (rename-file nq8 thumb t)))
680 (message "command %S %s" (process-command process)
681 (string-replace "\n" "" status)))))
682 process))
683
684(defun image-dired-pngcrush-thumb (spec)
685 "Optimize thumbnail described by format SPEC with pngcrush(1)."
686 ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
687 ;; pngcrush needs an infile and outfile, so we just copy THUMB to
688 ;; THUMB-nq8.png and use the latter as a temp file.
689 (when (not image-dired-cmd-pngnq-program)
690 (let ((temp (cdr (assq ?q spec)))
691 (thumb (cdr (assq ?t spec))))
692 (copy-file thumb temp)))
693 (let ((process
694 (apply #'start-process "image-dired-pngcrush" nil
695 image-dired-cmd-pngcrush-program
696 (mapcar (lambda (arg) (format-spec arg spec))
697 image-dired-cmd-pngcrush-options))))
698 (setf (process-sentinel process)
699 (lambda (process status)
700 (unless (and (eq (process-status process) 'exit)
701 (zerop (process-exit-status process)))
702 (message "command %S %s" (process-command process)
703 (string-replace "\n" "" status)))
704 (when (memq (process-status process) '(exit signal))
705 (let ((temp (cdr (assq ?q spec))))
706 (delete-file temp)))))
707 process))
708
709(defun image-dired-optipng-thumb (spec)
710 "Optimize thumbnail described by format SPEC with optipng(1)."
711 (let ((process
712 (apply #'start-process "image-dired-optipng" nil
713 image-dired-cmd-optipng-program
714 (mapcar (lambda (arg) (format-spec arg spec))
715 image-dired-cmd-optipng-options))))
716 (setf (process-sentinel process)
717 (lambda (process status)
718 (unless (and (eq (process-status process) 'exit)
719 (zerop (process-exit-status process)))
720 (message "command %S %s" (process-command process)
721 (string-replace "\n" "" status)))))
722 process))
723
724(defun image-dired-create-thumb-1 (original-file thumbnail-file)
725 "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
726 (image-dired--check-executable-exists
727 'image-dired-cmd-create-thumbnail-program)
728 (let* ((width (int-to-string (image-dired-thumb-size 'width)))
729 (height (int-to-string (image-dired-thumb-size 'height)))
730 (modif-time (format-time-string
731 "%s" (file-attribute-modification-time
732 (file-attributes original-file))))
733 (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
734 thumbnail-file))
735 (spec
736 (list
737 (cons ?w width)
738 (cons ?h height)
739 (cons ?m modif-time)
740 (cons ?f original-file)
741 (cons ?q thumbnail-nq8-file)
742 (cons ?t thumbnail-file)))
743 (thumbnail-dir (file-name-directory thumbnail-file))
744 process)
745 (when (not (file-exists-p thumbnail-dir))
746 (with-file-modes #o700
747 (make-directory thumbnail-dir t))
748 (message "Thumbnail directory created: %s" thumbnail-dir))
749
750 ;; Thumbnail file creation processes begin here and are marshaled
751 ;; in a queue by `image-dired-create-thumb'.
752 (setq process
753 (apply #'start-process "image-dired-create-thumbnail" nil
754 image-dired-cmd-create-thumbnail-program
755 (mapcar
756 (lambda (arg) (format-spec arg spec))
757 (if (memq image-dired-thumbnail-storage
758 image-dired--thumbnail-standard-sizes)
759 image-dired-cmd-create-standard-thumbnail-options
760 image-dired-cmd-create-thumbnail-options))))
761
762 (setf (process-sentinel process)
763 (lambda (process status)
764 ;; Trigger next in queue once a thumbnail has been created
765 (cl-decf image-dired-queue-active-jobs)
766 (image-dired-thumb-queue-run)
767 (when (= image-dired-queue-active-jobs 0)
768 (image-dired-debug-message
769 (format-time-string
770 "Generated thumbnails in %s.%3N seconds"
771 (time-subtract nil
772 image-dired--generate-thumbs-start))))
773 (if (not (and (eq (process-status process) 'exit)
774 (zerop (process-exit-status process))))
775 (message "Thumb could not be created for %s: %s"
776 (abbreviate-file-name original-file)
777 (string-replace "\n" "" status))
778 (set-file-modes thumbnail-file #o600)
779 (clear-image-cache thumbnail-file)
780 ;; PNG thumbnail has been created since we are
781 ;; following the XDG thumbnail spec, so try to optimize
782 (when (memq image-dired-thumbnail-storage
783 image-dired--thumbnail-standard-sizes)
784 (cond
785 ((and image-dired-cmd-pngnq-program
786 (executable-find image-dired-cmd-pngnq-program))
787 (image-dired-pngnq-thumb spec))
788 ((and image-dired-cmd-pngcrush-program
789 (executable-find image-dired-cmd-pngcrush-program))
790 (image-dired-pngcrush-thumb spec))
791 ((and image-dired-cmd-optipng-program
792 (executable-find image-dired-cmd-optipng-program))
793 (image-dired-optipng-thumb spec)))))))
794 process))
795
796(defun image-dired-thumb-queue-run ()
797 "Run a queued job if one exists and not too many jobs are running.
798Queued items live in `image-dired-queue'."
799 (while (and image-dired-queue
800 (< image-dired-queue-active-jobs
801 image-dired-queue-active-limit))
802 (cl-incf image-dired-queue-active-jobs)
803 (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
804
805(defun image-dired-create-thumb (original-file thumbnail-file)
806 "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'.
807The new file will be named THUMBNAIL-FILE."
808 (setq image-dired-queue
809 (nconc image-dired-queue
810 (list (list original-file thumbnail-file))))
811 (run-at-time 0 nil #'image-dired-thumb-queue-run))
812
813(defmacro image-dired--with-marked (&rest body)
814 "Eval BODY with point on each marked thumbnail.
815If no marked file could be found, execute BODY on the current
816thumbnail."
817 `(with-current-buffer image-dired-thumbnail-buffer
818 (let (found)
819 (save-mark-and-excursion
820 (goto-char (point-min))
821 (while (not (eobp))
822 (when (image-dired-thumb-file-marked-p)
823 (setq found t)
824 ,@body)
825 (forward-char)))
826 (unless found
827 ,@body))))
828
829;;;###autoload
830(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
831 "Toggle thumbnails in front of file names in the Dired buffer.
832If no marked file could be found, insert or hide thumbnails on the
833current line. ARG, if non-nil, specifies the files to use instead
834of the marked files. If ARG is an integer, use the next ARG (or
835previous -ARG, if ARG<0) files."
836 (interactive "P")
837 (dired-map-over-marks
838 (let ((image-pos (dired-move-to-filename))
839 (image-file (dired-get-filename nil t))
840 thumb-file
841 overlay)
842 (when (and image-file
843 (string-match-p (image-file-name-regexp) image-file))
844 (setq thumb-file (image-dired-get-thumbnail-image image-file))
845 ;; If image is not already added, then add it.
846 (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
847 if (overlay-get ov 'thumb-file) return ov)))
848 (if thumb-ov
849 (delete-overlay thumb-ov)
850 (put-image thumb-file image-pos)
851 (setq overlay
852 (cl-loop for ov in (overlays-in (point) (1+ (point)))
853 if (overlay-get ov 'put-image) return ov))
854 (overlay-put overlay 'image-file image-file)
855 (overlay-put overlay 'thumb-file thumb-file)))))
856 arg ; Show or hide image on ARG next files.
857 'show-progress) ; Update dired display after each image is updated.
858 (add-hook 'dired-after-readin-hook
859 'image-dired-dired-after-readin-hook nil t))
860
861(defun image-dired-dired-after-readin-hook ()
862 "Relocate existing thumbnail overlays in Dired buffer after reverting.
863Move them to their corresponding files if they still exist.
864Otherwise, delete overlays."
865 (mapc (lambda (overlay)
866 (when (overlay-get overlay 'put-image)
867 (let* ((image-file (overlay-get overlay 'image-file))
868 (image-pos (dired-goto-file image-file)))
869 (if image-pos
870 (move-overlay overlay image-pos image-pos)
871 (delete-overlay overlay)))))
872 (overlays-in (point-min) (point-max))))
873
874(defun image-dired-next-line-and-display ()
875 "Move to next Dired line and display thumbnail image."
876 (interactive)
877 (dired-next-line 1)
878 (image-dired-display-thumbs
879 t (or image-dired-append-when-browsing nil) t)
880 (if image-dired-dired-disp-props
881 (image-dired-dired-display-properties)))
882
883(defun image-dired-previous-line-and-display ()
884 "Move to previous Dired line and display thumbnail image."
885 (interactive)
886 (dired-previous-line 1)
887 (image-dired-display-thumbs
888 t (or image-dired-append-when-browsing nil) t)
889 (if image-dired-dired-disp-props
890 (image-dired-dired-display-properties)))
891
892(defun image-dired-toggle-append-browsing ()
893 "Toggle `image-dired-append-when-browsing'."
894 (interactive)
895 (setq image-dired-append-when-browsing
896 (not image-dired-append-when-browsing))
897 (message "Append browsing %s"
898 (if image-dired-append-when-browsing
899 "on"
900 "off")))
901
902(defun image-dired-mark-and-display-next ()
903 "Mark current file in Dired and display next thumbnail image."
904 (interactive)
905 (dired-mark 1)
906 (image-dired-display-thumbs
907 t (or image-dired-append-when-browsing nil) t)
908 (if image-dired-dired-disp-props
909 (image-dired-dired-display-properties)))
910
911(defun image-dired-toggle-dired-display-properties ()
912 "Toggle `image-dired-dired-disp-props'."
913 (interactive)
914 (setq image-dired-dired-disp-props
915 (not image-dired-dired-disp-props))
916 (message "Dired display properties %s"
917 (if image-dired-dired-disp-props
918 "on"
919 "off")))
920
921(defvar image-dired-thumbnail-buffer "*image-dired*"
922 "Image-Dired's thumbnail buffer.")
923
924(defun image-dired-create-thumbnail-buffer ()
925 "Create thumb buffer and set `image-dired-thumbnail-mode'."
926 (let ((buf (get-buffer-create image-dired-thumbnail-buffer)))
927 (with-current-buffer buf
928 (setq buffer-read-only t)
929 (if (not (eq major-mode 'image-dired-thumbnail-mode))
930 (image-dired-thumbnail-mode)))
931 buf))
932
933(defvar image-dired-display-image-buffer "*image-dired-display-image*"
934 "Where larger versions of the images are display.")
935
936(defvar image-dired-saved-window-configuration nil
937 "Saved window configuration.")
938
939;;;###autoload
940(defun image-dired-dired-with-window-configuration (dir &optional arg)
941 "Open directory DIR and create a default window configuration.
942
943Convenience command that:
944
945 - Opens Dired in folder DIR
946 - Splits windows in most useful (?) way
947 - Sets `truncate-lines' to t
948
949After the command has finished, you would typically mark some
950image files in Dired and type
951\\[image-dired-display-thumbs] (`image-dired-display-thumbs').
952
953If called with prefix argument ARG, skip splitting of windows.
954
955The current window configuration is saved and can be restored by
956calling `image-dired-restore-window-configuration'."
957 (interactive "DDirectory: \nP")
958 (let ((buf (image-dired-create-thumbnail-buffer))
959 (buf2 (get-buffer-create image-dired-display-image-buffer)))
960 (setq image-dired-saved-window-configuration
961 (current-window-configuration))
962 (dired dir)
963 (delete-other-windows)
964 (when (not arg)
965 (split-window-right)
966 (setq truncate-lines t)
967 (save-excursion
968 (other-window 1)
969 (pop-to-buffer-same-window buf)
970 (select-window (split-window-below))
971 (pop-to-buffer-same-window buf2)
972 (other-window -2)))))
973
974(defun image-dired-restore-window-configuration ()
975 "Restore window configuration.
976Restore any changes to the window configuration made by calling
977`image-dired-dired-with-window-configuration'."
978 (interactive nil image-dired-thumbnail-mode)
979 (if image-dired-saved-window-configuration
980 (set-window-configuration image-dired-saved-window-configuration)
981 (message "No saved window configuration")))
982
983(defun image-dired--line-up-with-method ()
984 "Line up thumbnails according to `image-dired-line-up-method'."
985 (cond ((eq 'dynamic image-dired-line-up-method)
986 (image-dired-line-up-dynamic))
987 ((eq 'fixed image-dired-line-up-method)
988 (image-dired-line-up))
989 ((eq 'interactive image-dired-line-up-method)
990 (image-dired-line-up-interactive))
991 ((eq 'none image-dired-line-up-method)
992 nil)
993 (t
994 (image-dired-line-up-dynamic))))
995
996;;;###autoload
997(defun image-dired-display-thumbs (&optional arg append do-not-pop)
998 "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'.
999If a thumbnail image does not exist for a file, it is created on the
1000fly. With prefix argument ARG, display only thumbnail for file at
1001point (this is useful if you have marked some files but want to show
1002another one).
1003
1004Recommended usage is to split the current frame horizontally so that
1005you have the Dired buffer in the left window and the
1006`image-dired-thumbnail-buffer' buffer in the right window.
1007
1008With optional argument APPEND, append thumbnail to thumbnail buffer
1009instead of erasing it first.
1010
1011Optional argument DO-NOT-POP controls if `pop-to-buffer' should be
1012used or not. If non-nil, use `display-buffer' instead of
1013`pop-to-buffer'. This is used from functions like
1014`image-dired-next-line-and-display' and
1015`image-dired-previous-line-and-display' where we do not want the
1016thumbnail buffer to be selected."
1017 (interactive "P")
1018 (setq image-dired--generate-thumbs-start (current-time))
1019 (let ((buf (image-dired-create-thumbnail-buffer))
1020 thumb-name files dired-buf)
1021 (if arg
1022 (setq files (list (dired-get-filename)))
1023 (setq files (dired-get-marked-files)))
1024 (setq dired-buf (current-buffer))
1025 (with-current-buffer buf
1026 (let ((inhibit-read-only t))
1027 (if (not append)
1028 (erase-buffer)
1029 (goto-char (point-max)))
1030 (dolist (curr-file files)
1031 (setq thumb-name (image-dired-thumb-name curr-file))
1032 (when (not (file-exists-p thumb-name))
1033 (image-dired-create-thumb curr-file thumb-name))
1034 (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
1035 (if do-not-pop
1036 (display-buffer buf)
1037 (pop-to-buffer buf))
1038 (image-dired--line-up-with-method))))
1039
1040;;;###autoload
1041(defun image-dired-show-all-from-dir (dir)
1042 "Make a thumbnail buffer for all images in DIR and display it.
1043Any file matching `image-file-name-regexp' is considered an image
1044file.
1045
1046If the number of image files in DIR exceeds
1047`image-dired-show-all-from-dir-max-files', ask for confirmation
1048before creating the thumbnail buffer. If that variable is nil,
1049never ask for confirmation."
1050 (interactive "DImage-Dired: ")
1051 (dired dir)
1052 (dired-mark-files-regexp (image-file-name-regexp))
1053 (let ((files (dired-get-marked-files nil nil nil t)))
1054 (cond ((and (null (cdr files)))
1055 (message "No image files in directory"))
1056 ((or (not image-dired-show-all-from-dir-max-files)
1057 (<= (length (cdr files)) image-dired-show-all-from-dir-max-files)
1058 (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files)
1059 (y-or-n-p
1060 (format
1061 "Directory contains more than %d image files. Proceed?"
1062 image-dired-show-all-from-dir-max-files))))
1063 (image-dired-display-thumbs)
1064 (pop-to-buffer image-dired-thumbnail-buffer)
1065 (setq default-directory dir)
1066 (image-dired-unmark-all-marks))
1067 (t (message "Image-Dired canceled")))))
1068
1069;;;###autoload
1070(defalias 'image-dired 'image-dired-show-all-from-dir)
1071
1072
1073;;; Tags
1074
1075(defun image-dired-sane-db-file ()
1076 "Check if `image-dired-db-file' exists.
1077If not, try to create it (including any parent directories).
1078Signal error if there are problems creating it."
1079 (or (file-exists-p image-dired-db-file)
1080 (let (dir buf)
1081 (unless (file-directory-p (setq dir (file-name-directory
1082 image-dired-db-file)))
1083 (with-file-modes #o700
1084 (make-directory dir t)))
1085 (with-current-buffer (setq buf (create-file-buffer
1086 image-dired-db-file))
1087 (with-file-modes #o600
1088 (write-file image-dired-db-file)))
1089 (kill-buffer buf)
1090 (file-exists-p image-dired-db-file))
1091 (error "Could not create %s" image-dired-db-file)))
1092
1093(defvar image-dired-tag-history nil "Variable holding the tag history.")
1094
1095(defun image-dired-write-tags (file-tags)
1096 "Write file tags to database.
1097Write each file and tag in FILE-TAGS to the database.
1098FILE-TAGS is an alist in the following form:
1099 ((FILE . TAG) ... )"
1100 (image-dired-sane-db-file)
1101 (let (end file tag)
1102 (image-dired--with-db-file
1103 (setq buffer-file-name image-dired-db-file)
1104 (dolist (elt file-tags)
1105 (setq file (car elt)
1106 tag (cdr elt))
1107 (goto-char (point-min))
1108 (if (search-forward-regexp (format "^%s.*$" file) nil t)
1109 (progn
1110 (setq end (point))
1111 (beginning-of-line)
1112 (when (not (search-forward (format ";%s" tag) end t))
1113 (end-of-line)
1114 (insert (format ";%s" tag))))
1115 (goto-char (point-max))
1116 (insert (format "%s;%s\n" file tag))))
1117 (save-buffer))))
1118
1119(defun image-dired-remove-tag (files tag)
1120 "For all FILES, remove TAG from the image database."
1121 (image-dired-sane-db-file)
1122 (image-dired--with-db-file
1123 (setq buffer-file-name image-dired-db-file)
1124 (let (end)
1125 (unless (listp files)
1126 (if (stringp files)
1127 (setq files (list files))
1128 (error "Files must be a string or a list of strings!")))
1129 (dolist (file files)
1130 (goto-char (point-min))
1131 (when (search-forward-regexp (format "^%s;" file) nil t)
1132 (end-of-line)
1133 (setq end (point))
1134 (beginning-of-line)
1135 (when (search-forward-regexp
1136 (format "\\(;%s\\)\\($\\|;\\)" tag) end t)
1137 (delete-region (match-beginning 1) (match-end 1))
1138 ;; Check if file should still be in the database. If
1139 ;; it has no tags or comments, it will be removed.
1140 (end-of-line)
1141 (setq end (point))
1142 (beginning-of-line)
1143 (when (not (search-forward ";" end t))
1144 (kill-line 1))))))
1145 (save-buffer)))
1146
1147(defun image-dired-list-tags (file)
1148 "Read all tags for image FILE from the image database."
1149 (image-dired-sane-db-file)
1150 (image-dired--with-db-file
1151 (let (end (tags ""))
1152 (when (search-forward-regexp (format "^%s" file) nil t)
1153 (end-of-line)
1154 (setq end (point))
1155 (beginning-of-line)
1156 (if (search-forward ";" end t)
1157 (if (search-forward "comment:" end t)
1158 (if (search-forward ";" end t)
1159 (setq tags (buffer-substring (point) end)))
1160 (setq tags (buffer-substring (point) end)))))
1161 (split-string tags ";"))))
1162
1163;;;###autoload
1164(defun image-dired-tag-files (arg)
1165 "Tag marked file(s) in Dired. With prefix ARG, tag file at point."
1166 (interactive "P")
1167 (let ((tag (completing-read
1168 "Tags to add (separate tags with a semicolon): "
1169 image-dired-tag-history nil nil nil 'image-dired-tag-history))
1170 files)
1171 (if arg
1172 (setq files (list (dired-get-filename)))
1173 (setq files (dired-get-marked-files)))
1174 (image-dired-write-tags
1175 (mapcar
1176 (lambda (x)
1177 (cons x tag))
1178 files))))
1179
1180(defun image-dired-tag-thumbnail ()
1181 "Tag current or marked thumbnails."
1182 (interactive)
1183 (let ((tag (completing-read
1184 "Tags to add (separate tags with a semicolon): "
1185 image-dired-tag-history nil nil nil 'image-dired-tag-history)))
1186 (image-dired--with-marked
1187 (image-dired-write-tags
1188 (list (cons (image-dired-original-file-name) tag)))
1189 (image-dired-update-property
1190 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1191
1192;;;###autoload
1193(defun image-dired-delete-tag (arg)
1194 "Remove tag for selected file(s).
1195With prefix argument ARG, remove tag from file at point."
1196 (interactive "P")
1197 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1198 nil nil nil 'image-dired-tag-history))
1199 files)
1200 (if arg
1201 (setq files (list (dired-get-filename)))
1202 (setq files (dired-get-marked-files)))
1203 (image-dired-remove-tag files tag)))
1204
1205(defun image-dired-tag-thumbnail-remove ()
1206 "Remove tag from current or marked thumbnails."
1207 (interactive)
1208 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1209 nil nil nil 'image-dired-tag-history)))
1210 (image-dired--with-marked
1211 (image-dired-remove-tag (image-dired-original-file-name) tag)
1212 (image-dired-update-property
1213 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1214
1215
1216;;; Thumbnail mode (cont.)
1217
1218(defun image-dired-original-file-name ()
1219 "Get original file name for thumbnail or display image at point."
1220 (get-text-property (point) 'original-file-name))
1221
1222(defun image-dired-file-name-at-point ()
1223 "Get abbreviated file name for thumbnail or display image at point."
1224 (let ((f (image-dired-original-file-name)))
1225 (when f
1226 (abbreviate-file-name f))))
1227
1228(defun image-dired-associated-dired-buffer ()
1229 "Get associated Dired buffer at point."
1230 (get-text-property (point) 'associated-dired-buffer))
1231
1232(defun image-dired-get-buffer-window (buf)
1233 "Return window where buffer BUF is."
1234 (get-window-with-predicate
1235 (lambda (window)
1236 (equal (window-buffer window) buf))
1237 nil t))
1238
1239(defun image-dired-track-original-file ()
1240 "Track the original file in the associated Dired buffer.
1241See documentation for `image-dired-toggle-movement-tracking'.
1242Interactive use only useful if `image-dired-track-movement' is nil."
1243 (interactive)
1244 (let* ((dired-buf (image-dired-associated-dired-buffer))
1245 (file-name (image-dired-original-file-name))
1246 (window (image-dired-get-buffer-window dired-buf)))
1247 (and (buffer-live-p dired-buf) file-name
1248 (with-current-buffer dired-buf
1249 (if (not (dired-goto-file file-name))
1250 (message "Could not track file")
1251 (if window (set-window-point window (point))))))))
1252
1253(defun image-dired-toggle-movement-tracking ()
1254 "Turn on and off `image-dired-track-movement'.
1255Tracking of the movements between thumbnail and Dired buffer so that
1256they are \"mirrored\" in the dired buffer. When this is on, moving
1257around in the thumbnail or dired buffer will find the matching
1258position in the other buffer."
1259 (interactive)
1260 (setq image-dired-track-movement (not image-dired-track-movement))
1261 (message "Movement tracking %s" (if image-dired-track-movement "on" "off")))
1262
1263(defun image-dired-track-thumbnail ()
1264 "Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
1265This is almost the same as what `image-dired-track-original-file' does,
1266but the other way around."
1267 (let ((file (dired-get-filename))
1268 prop-val found window)
1269 (when (get-buffer image-dired-thumbnail-buffer)
1270 (with-current-buffer image-dired-thumbnail-buffer
1271 (goto-char (point-min))
1272 (while (and (not (eobp))
1273 (not found))
1274 (if (and (setq prop-val
1275 (get-text-property (point) 'original-file-name))
1276 (string= prop-val file))
1277 (setq found t))
1278 (if (not found)
1279 (forward-char 1)))
1280 (when found
1281 (if (setq window (image-dired-thumbnail-window))
1282 (set-window-point window (point)))
1283 (image-dired-update-header-line))))))
1284
1285(defun image-dired-dired-next-line (&optional arg)
1286 "Call `dired-next-line', then track thumbnail.
1287This can safely replace `dired-next-line'.
1288With prefix argument, move ARG lines."
1289 (interactive "P")
1290 (dired-next-line (or arg 1))
1291 (if image-dired-track-movement
1292 (image-dired-track-thumbnail)))
1293
1294(defun image-dired-dired-previous-line (&optional arg)
1295 "Call `dired-previous-line', then track thumbnail.
1296This can safely replace `dired-previous-line'.
1297With prefix argument, move ARG lines."
1298 (interactive "P")
1299 (dired-previous-line (or arg 1))
1300 (if image-dired-track-movement
1301 (image-dired-track-thumbnail)))
1302
1303(defun image-dired--display-thumb-properties-fun ()
1304 (let ((old-buf (current-buffer))
1305 (old-point (point)))
1306 (lambda ()
1307 (when (and (equal (current-buffer) old-buf)
1308 (= (point) old-point))
1309 (ignore-errors
1310 (image-dired-update-header-line))))))
1311
1312(defun image-dired-forward-image (&optional arg wrap-around)
1313 "Move to next image and display properties.
1314Optional prefix ARG says how many images to move; the default is
1315one image. Negative means move backwards.
1316On reaching end or beginning of buffer, stop and show a message.
1317
1318If optional argument WRAP-AROUND is non-nil, wrap around: if
1319point is on the last image, move to the last one and vice versa."
1320 (interactive "p")
1321 (setq arg (or arg 1))
1322 (let (pos)
1323 (dotimes (_ (abs arg))
1324 (if (and (not (if (> arg 0) (eobp) (bobp)))
1325 (save-excursion
1326 (forward-char (if (> arg 0) 1 -1))
1327 (while (and (not (if (> arg 0) (eobp) (bobp)))
1328 (not (image-dired-image-at-point-p)))
1329 (forward-char (if (> arg 0) 1 -1)))
1330 (setq pos (point))
1331 (image-dired-image-at-point-p)))
1332 (progn (goto-char pos)
1333 (image-dired-update-header-line))
1334 (if wrap-around
1335 (progn (goto-char (if (> arg 0)
1336 (point-min)
1337 ;; There are two spaces after the last image.
1338 (- (point-max) 2)))
1339 (image-dired-update-header-line))
1340 (message "At %s image" (if (> arg 0) "last" "first"))
1341 (run-at-time 1 nil (image-dired--display-thumb-properties-fun))))))
1342 (when image-dired-track-movement
1343 (image-dired-track-original-file)))
1344
1345(defun image-dired-backward-image (&optional arg)
1346 "Move to previous image and display properties.
1347Optional prefix ARG says how many images to move; the default is
1348one image. Negative means move forward.
1349On reaching end or beginning of buffer, stop and show a message."
1350 (interactive "p")
1351 (image-dired-forward-image (- (or arg 1))))
1352
1353(defun image-dired-next-line ()
1354 "Move to next line and display properties."
1355 (interactive nil image-dired-thumbnail-mode)
1356 (let ((goal-column (current-column)))
1357 (forward-line 1)
1358 (move-to-column goal-column))
1359 ;; If we end up in an empty spot, back up to the next thumbnail.
1360 (if (not (image-dired-image-at-point-p))
1361 (image-dired-backward-image))
1362 (if image-dired-track-movement
1363 (image-dired-track-original-file))
1364 (image-dired-update-header-line))
1365
1366
1367(defun image-dired-previous-line ()
1368 "Move to previous line and display properties."
1369 (interactive nil image-dired-thumbnail-mode)
1370 (let ((goal-column (current-column)))
1371 (forward-line -1)
1372 (move-to-column goal-column))
1373 ;; If we end up in an empty spot, back up to the next
1374 ;; thumbnail. This should only happen if the user deleted a
1375 ;; thumbnail and did not refresh, so it is not very common. But we
1376 ;; can handle it in a good manner, so why not?
1377 (if (not (image-dired-image-at-point-p))
1378 (image-dired-backward-image))
1379 (if image-dired-track-movement
1380 (image-dired-track-original-file))
1381 (image-dired-update-header-line))
1382
1383(defun image-dired-beginning-of-buffer ()
1384 "Move to the first image in the buffer and display properties."
1385 (interactive nil image-dired-thumbnail-mode)
1386 (goto-char (point-min))
1387 (while (and (not (image-at-point-p))
1388 (not (eobp)))
1389 (forward-char 1))
1390 (when image-dired-track-movement
1391 (image-dired-track-original-file))
1392 (image-dired-update-header-line))
1393
1394(defun image-dired-end-of-buffer ()
1395 "Move to the last image in the buffer and display properties."
1396 (interactive nil image-dired-thumbnail-mode)
1397 (goto-char (point-max))
1398 (while (and (not (image-at-point-p))
1399 (not (bobp)))
1400 (forward-char -1))
1401 (when image-dired-track-movement
1402 (image-dired-track-original-file))
1403 (image-dired-update-header-line))
1404
1405(defun image-dired-format-properties-string (buf file props comment)
1406 "Format display properties.
1407BUF is the associated Dired buffer, FILE is the original image file
1408name, PROPS is a stringified list of tags and COMMENT is the image file's
1409comment."
1410 (format-spec
1411 image-dired-display-properties-format
1412 (list
1413 (cons ?b (or buf ""))
1414 (cons ?f file)
1415 (cons ?t (or props ""))
1416 (cons ?c (or comment "")))))
1417
1418(defun image-dired-update-header-line ()
1419 "Update image information in the header line."
1420 (when (and (not (eobp))
1421 (memq major-mode '(image-dired-thumbnail-mode
1422 image-dired-display-image-mode)))
1423 (let ((file-name (file-name-nondirectory (image-dired-original-file-name)))
1424 (dired-buf (buffer-name (image-dired-associated-dired-buffer)))
1425 (props (mapconcat #'identity (get-text-property (point) 'tags) ", "))
1426 (comment (get-text-property (point) 'comment))
1427 (message-log-max nil))
1428 (if file-name
1429 (setq header-line-format
1430 (image-dired-format-properties-string
1431 dired-buf
1432 file-name
1433 props
1434 comment))))))
1435
1436(defun image-dired-dired-file-marked-p (&optional marker)
1437 "In Dired, return t if file on current line is marked.
1438If optional argument MARKER is non-nil, it is a character to look
1439for. The default is to look for `dired-marker-char'."
1440 (setq marker (or marker dired-marker-char))
1441 (save-excursion
1442 (beginning-of-line)
1443 (and (looking-at dired-re-mark)
1444 (= (aref (match-string 0) 0) marker))))
1445
1446(defun image-dired-dired-file-flagged-p ()
1447 "In Dired, return t if file on current line is flagged for deletion."
1448 (image-dired-dired-file-marked-p dired-del-marker))
1449
1450(defmacro image-dired--with-thumbnail-buffer (&rest body)
1451 (declare (indent defun) (debug t))
1452 `(if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1453 (with-current-buffer buf
1454 (if-let ((win (get-buffer-window buf)))
1455 (with-selected-window win
1456 ,@body)
1457 ,@body))
1458 (user-error "No such buffer: %s" image-dired-thumbnail-buffer)))
1459
1460(defmacro image-dired--on-file-in-dired-buffer (&rest body)
1461 "Run BODY with point on file at point in Dired buffer.
1462Should be called from commands in `image-dired-thumbnail-mode'."
1463 (declare (indent defun) (debug t))
1464 `(let ((file-name (image-dired-original-file-name))
1465 (dired-buf (image-dired-associated-dired-buffer)))
1466 (if (not (and dired-buf file-name))
1467 (message "No image, or image with correct properties, at point")
1468 (with-current-buffer dired-buf
1469 (when (dired-goto-file file-name)
1470 ,@body
1471 (image-dired-thumb-update-marks))))))
1472
1473(defmacro image-dired--do-mark-command (maybe-next &rest body)
1474 "Helper macro for the mark, unmark and flag commands.
1475Run BODY in Dired buffer.
1476If optional argument MAYBE-NEXT is non-nil, show next image
1477according to `image-dired-marking-shows-next'."
1478 (declare (indent defun) (debug t))
1479 `(image-dired--with-thumbnail-buffer
1480 (image-dired--on-file-in-dired-buffer
1481 ,@body)
1482 ,(when maybe-next
1483 '(if image-dired-marking-shows-next
1484 (image-dired-display-next-thumbnail-original)
1485 (image-dired-next-line)))))
1486
1487(defun image-dired-mark-thumb-original-file ()
1488 "Mark original image file in associated Dired buffer."
1489 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1490 (image-dired--do-mark-command t
1491 (dired-mark 1)))
1492
1493(defun image-dired-unmark-thumb-original-file ()
1494 "Unmark original image file in associated Dired buffer."
1495 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1496 (image-dired--do-mark-command t
1497 (dired-unmark 1)))
1498
1499(defun image-dired-flag-thumb-original-file ()
1500 "Flag original image file for deletion in associated Dired buffer."
1501 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1502 (image-dired--do-mark-command t
1503 (dired-flag-file-deletion 1)))
1504
1505(defun image-dired-toggle-mark-thumb-original-file ()
1506 "Toggle mark on original image file in associated Dired buffer."
1507 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1508 (image-dired--do-mark-command nil
1509 (if (image-dired-dired-file-marked-p)
1510 (dired-unmark 1)
1511 (dired-mark 1))))
1512
1513(defun image-dired-unmark-all-marks ()
1514 "Remove all marks from all files in associated Dired buffer.
1515Also update the marks in the thumbnail buffer."
1516 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1517 (image-dired--do-mark-command nil
1518 (dired-unmark-all-marks))
1519 (image-dired--with-thumbnail-buffer
1520 (image-dired-thumb-update-marks)))
1521
1522(defun image-dired-jump-original-dired-buffer ()
1523 "Jump to the Dired buffer associated with the current image file.
1524You probably want to use this together with
1525`image-dired-track-original-file'."
1526 (interactive nil image-dired-thumbnail-mode)
1527 (let ((buf (image-dired-associated-dired-buffer))
1528 window frame)
1529 (setq window (image-dired-get-buffer-window buf))
1530 (if window
1531 (progn
1532 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1533 (select-frame-set-input-focus frame))
1534 (select-window window))
1535 (message "Associated dired buffer not visible"))))
1536
1537;;;###autoload
1538(defun image-dired-jump-thumbnail-buffer ()
1539 "Jump to thumbnail buffer."
1540 (interactive)
1541 (let ((window (image-dired-thumbnail-window))
1542 frame)
1543 (if window
1544 (progn
1545 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1546 (select-frame-set-input-focus frame))
1547 (select-window window))
1548 (message "Thumbnail buffer not visible"))))
1549
1550(defvar image-dired-thumbnail-mode-line-up-map
1551 (let ((map (make-sparse-keymap)))
1552 ;; map it to "g" so that the user can press it more quickly
1553 (define-key map "g" #'image-dired-line-up-dynamic)
1554 ;; "f" for "fixed" number of thumbs per row
1555 (define-key map "f" #'image-dired-line-up)
1556 ;; "i" for "interactive"
1557 (define-key map "i" #'image-dired-line-up-interactive)
1558 map)
1559 "Keymap for line-up commands in `image-dired-thumbnail-mode'.")
1560
1561(defvar image-dired-thumbnail-mode-tag-map
1562 (let ((map (make-sparse-keymap)))
1563 ;; map it to "t" so that the user can press it more quickly
1564 (define-key map "t" #'image-dired-tag-thumbnail)
1565 ;; "r" for "remove"
1566 (define-key map "r" #'image-dired-tag-thumbnail-remove)
1567 map)
1568 "Keymap for tag commands in `image-dired-thumbnail-mode'.")
1569
1570(defvar image-dired-thumbnail-mode-map
1571 (let ((map (make-sparse-keymap)))
1572 (define-key map [right] #'image-dired-forward-image)
1573 (define-key map [left] #'image-dired-backward-image)
1574 (define-key map [up] #'image-dired-previous-line)
1575 (define-key map [down] #'image-dired-next-line)
1576 (define-key map "\C-f" #'image-dired-forward-image)
1577 (define-key map "\C-b" #'image-dired-backward-image)
1578 (define-key map "\C-p" #'image-dired-previous-line)
1579 (define-key map "\C-n" #'image-dired-next-line)
1580
1581 (define-key map "<" #'image-dired-beginning-of-buffer)
1582 (define-key map ">" #'image-dired-end-of-buffer)
1583 (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer)
1584 (define-key map (kbd "M->") #'image-dired-end-of-buffer)
1585
1586 (define-key map "d" #'image-dired-flag-thumb-original-file)
1587 (define-key map [delete] #'image-dired-flag-thumb-original-file)
1588 (define-key map "m" #'image-dired-mark-thumb-original-file)
1589 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1590 (define-key map "U" #'image-dired-unmark-all-marks)
1591 (define-key map "." #'image-dired-track-original-file)
1592 (define-key map [tab] #'image-dired-jump-original-dired-buffer)
1593
1594 ;; add line-up map
1595 (define-key map "g" image-dired-thumbnail-mode-line-up-map)
1596 ;; add tag map
1597 (define-key map "t" image-dired-thumbnail-mode-tag-map)
1598
1599 (define-key map "\C-m" #'image-dired-display-thumbnail-original-image)
1600 (define-key map [C-return] #'image-dired-thumbnail-display-external)
1601
1602 (define-key map "L" #'image-dired-rotate-original-left)
1603 (define-key map "R" #'image-dired-rotate-original-right)
1604
1605 (define-key map "D" #'image-dired-thumbnail-set-image-description)
1606 (define-key map "S" #'image-dired-slideshow-start)
1607 (define-key map "\C-d" #'image-dired-delete-char)
1608 (define-key map " " #'image-dired-display-next-thumbnail-original)
1609 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1610 (define-key map "c" #'image-dired-comment-thumbnail)
1611
1612 ;; Mouse
1613 (define-key map [mouse-2] #'image-dired-mouse-display-image)
1614 (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail)
1615 (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail)
1616 (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail)
1617 (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail)
1618 (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail)
1619 ;; Seems I must first set C-down-mouse-1 to undefined, or else it
1620 ;; will trigger the buffer menu. If I try to instead bind
1621 ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
1622 ;; about C-mouse-1 not being defined afterwards. Annoying, but I
1623 ;; probably do not completely understand mouse events.
1624 (define-key map [C-down-mouse-1] #'undefined)
1625 (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark)
1626 map)
1627 "Keymap for `image-dired-thumbnail-mode'.")
1628
1629(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map
1630 "Menu for `image-dired-thumbnail-mode'."
1631 '("Image-Dired"
1632 ["Display image" image-dired-display-thumbnail-original-image]
1633 ["Display in external viewer" image-dired-thumbnail-display-external]
1634 ["Jump to Dired buffer" image-dired-jump-original-dired-buffer]
1635 "---"
1636 ["Mark image" image-dired-mark-thumb-original-file]
1637 ["Unmark image" image-dired-unmark-thumb-original-file]
1638 ["Unmark all images" image-dired-unmark-all-marks]
1639 ["Flag for deletion" image-dired-flag-thumb-original-file]
1640 ["Delete marked images" image-dired-delete-marked]
1641 "---"
1642 ["Rotate original right" image-dired-rotate-original-right]
1643 ["Rotate original left" image-dired-rotate-original-left]
1644 "---"
1645 ["Comment thumbnail" image-dired-comment-thumbnail]
1646 ["Tag current or marked thumbnails" image-dired-tag-thumbnail]
1647 ["Remove tag from current or marked thumbnails"
1648 image-dired-tag-thumbnail-remove]
1649 ["Start slideshow" image-dired-slideshow-start]
1650 "---"
1651 ("View Options"
1652 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1653 :style toggle
1654 :selected image-dired-track-movement]
1655 "---"
1656 ["Line up thumbnails" image-dired-line-up]
1657 ["Dynamic line up" image-dired-line-up-dynamic]
1658 ["Refresh thumb" image-dired-refresh-thumb])
1659 ["Quit" quit-window]))
1660
1661(defvar image-dired-display-image-mode-map
1662 (let ((map (make-sparse-keymap)))
1663 (define-key map "S" #'image-dired-slideshow-start)
1664 (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original)
1665 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1666 (define-key map "n" #'image-dired-display-next-thumbnail-original)
1667 (define-key map "p" #'image-dired-display-previous-thumbnail-original)
1668 (define-key map "m" #'image-dired-mark-thumb-original-file)
1669 (define-key map "d" #'image-dired-flag-thumb-original-file)
1670 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1671 (define-key map "U" #'image-dired-unmark-all-marks)
1672 ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
1673 (define-key map "o" nil) ; image-save
1674 map)
1675 "Keymap for `image-dired-display-image-mode'.")
1676
1677(define-derived-mode image-dired-thumbnail-mode
1678 special-mode "image-dired-thumbnail"
1679 "Browse and manipulate thumbnail images using Dired.
1680Use `image-dired-minor-mode' to get a nice setup."
1681 :interactive nil
1682 (buffer-disable-undo)
1683 (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)
1684 (setq-local window-resize-pixelwise t)
1685 (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record)
1686 ;; Use approximately as much vertical spacing as horizontal.
1687 (setq-local line-spacing (frame-char-width)))
1688
1689
1690;;; Display image mode
1691
1692(define-derived-mode image-dired-display-image-mode
1693 image-mode "image-dired-image-display"
1694 "Mode for displaying and manipulating original image.
1695Resized or in full-size."
1696 :interactive nil
1697 (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t))
1698
1699(defvar image-dired-minor-mode-map
1700 (let ((map (make-sparse-keymap)))
1701 ;; (set-keymap-parent map dired-mode-map)
1702 ;; Hijack previous and next line movement. Let C-p and C-b be
1703 ;; though...
1704 (define-key map "p" #'image-dired-dired-previous-line)
1705 (define-key map "n" #'image-dired-dired-next-line)
1706 (define-key map [up] #'image-dired-dired-previous-line)
1707 (define-key map [down] #'image-dired-dired-next-line)
1708
1709 (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display)
1710 (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display)
1711 (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next)
1712
1713 (define-key map "\C-td" #'image-dired-display-thumbs)
1714 (define-key map [tab] #'image-dired-jump-thumbnail-buffer)
1715 (define-key map "\C-ti" #'image-dired-dired-display-image)
1716 (define-key map "\C-tx" #'image-dired-dired-display-external)
1717 (define-key map "\C-ta" #'image-dired-display-thumbs-append)
1718 (define-key map "\C-t." #'image-dired-display-thumb)
1719 (define-key map "\C-tc" #'image-dired-dired-comment-files)
1720 (define-key map "\C-tf" #'image-dired-mark-tagged-files)
1721 map)
1722 "Keymap for `image-dired-minor-mode'.")
1723
1724(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
1725 "Menu for `image-dired-minor-mode'."
1726 '("Image-dired"
1727 ["Display thumb for next file" image-dired-next-line-and-display]
1728 ["Display thumb for previous file" image-dired-previous-line-and-display]
1729 ["Mark and display next" image-dired-mark-and-display-next]
1730 "---"
1731 ["Create thumbnails for marked files" image-dired-create-thumbs]
1732 "---"
1733 ["Display thumbnails append" image-dired-display-thumbs-append]
1734 ["Display this thumbnail" image-dired-display-thumb]
1735 ["Display image" image-dired-dired-display-image]
1736 ["Display in external viewer" image-dired-dired-display-external]
1737 "---"
1738 ["Toggle display properties" image-dired-toggle-dired-display-properties
1739 :style toggle
1740 :selected image-dired-dired-disp-props]
1741 ["Toggle append browsing" image-dired-toggle-append-browsing
1742 :style toggle
1743 :selected image-dired-append-when-browsing]
1744 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1745 :style toggle
1746 :selected image-dired-track-movement]
1747 "---"
1748 ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
1749 ["Mark tagged files" image-dired-mark-tagged-files]
1750 ["Comment files" image-dired-dired-comment-files]
1751 ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
1752
1753;;;###autoload
1754(define-minor-mode image-dired-minor-mode
1755 "Setup easy-to-use keybindings for the commands to be used in Dired mode.
1756Note that n, p and <down> and <up> will be hijacked and bound to
1757`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
1758 :keymap image-dired-minor-mode-map)
1759
1760(declare-function clear-image-cache "image.c" (&optional filter))
1761
1762(defun image-dired-create-thumbs (&optional arg)
1763 "Create thumbnail images for all marked files in Dired.
1764With prefix argument ARG, create thumbnails even if they already exist
1765\(i.e. use this to refresh your thumbnails)."
1766 (interactive "P")
1767 (let (thumb-name)
1768 (dolist (curr-file (dired-get-marked-files))
1769 (setq thumb-name (image-dired-thumb-name curr-file))
1770 ;; If the user overrides the exist check, we must clear the
1771 ;; image cache so that if the user wants to display the
1772 ;; thumbnail, it is not fetched from cache.
1773 (when arg
1774 (clear-image-cache (expand-file-name thumb-name)))
1775 (when (or (not (file-exists-p thumb-name))
1776 arg)
1777 (image-dired-create-thumb curr-file thumb-name)))))
1778
1779
1780;;; Slideshow
1781
1782(defcustom image-dired-slideshow-delay 5.0
1783 "Seconds to wait before showing the next image in a slideshow.
1784This is used by `image-dired-slideshow-start'."
1785 :type 'float
1786 :version "29.1")
1787
1788(define-obsolete-variable-alias 'image-dired-slideshow-timer
1789 'image-dired--slideshow-timer "29.1")
1790(defvar image-dired--slideshow-timer nil
1791 "Slideshow timer.")
1792
1793(defvar image-dired--slideshow-initial nil)
1794
1795(defun image-dired-slideshow-step ()
1796 "Step to next image in a slideshow."
1797 (if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1798 (with-current-buffer buf
1799 (image-dired-display-next-thumbnail-original))
1800 (image-dired-slideshow-stop)))
1801
1802(defun image-dired-slideshow-start (&optional arg)
1803 "Start a slideshow, waiting `image-dired-slideshow-delay' between images.
1804
1805With prefix argument ARG, wait that many seconds before going to
1806the next image.
1807
1808With a negative prefix argument, prompt user for the delay."
1809 (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode)
1810 (let ((delay (if (not arg)
1811 image-dired-slideshow-delay
1812 (if (> arg 0)
1813 arg
1814 (string-to-number
1815 (let ((delay (number-to-string image-dired-slideshow-delay)))
1816 (read-string
1817 (format-prompt "Delay, in seconds. Decimals are accepted" delay))
1818 delay))))))
1819 (setq image-dired--slideshow-timer
1820 (run-with-timer
1821 0 delay
1822 'image-dired-slideshow-step))
1823 (add-hook 'post-command-hook 'image-dired-slideshow-stop)
1824 (setq image-dired--slideshow-initial t)
1825 (message "Running slideshow; use any command to stop")))
1826
1827(defun image-dired-slideshow-stop ()
1828 "Cancel slideshow."
1829 ;; Make sure we don't immediately stop after
1830 ;; `image-dired-slideshow-start'.
1831 (unless image-dired--slideshow-initial
1832 (remove-hook 'post-command-hook 'image-dired-slideshow-stop)
1833 (cancel-timer image-dired--slideshow-timer))
1834 (setq image-dired--slideshow-initial nil))
1835
1836
1837;;; Thumbnail mode (cont. 3)
1838
1839(defun image-dired-delete-char ()
1840 "Remove current thumbnail from thumbnail buffer and line up."
1841 (interactive nil image-dired-thumbnail-mode)
1842 (let ((inhibit-read-only t))
1843 (delete-char 1)
1844 (when (= (following-char) ?\s)
1845 (delete-char 1))))
1846
1847;;;###autoload
1848(defun image-dired-display-thumbs-append ()
1849 "Append thumbnails to `image-dired-thumbnail-buffer'."
1850 (interactive)
1851 (image-dired-display-thumbs nil t t))
1852
1853;;;###autoload
1854(defun image-dired-display-thumb ()
1855 "Shorthand for `image-dired-display-thumbs' with prefix argument."
1856 (interactive)
1857 (image-dired-display-thumbs t nil t))
1858
1859(defun image-dired-line-up ()
1860 "Line up thumbnails according to `image-dired-thumbs-per-row'.
1861See also `image-dired-line-up-dynamic'."
1862 (interactive)
1863 (let ((inhibit-read-only t))
1864 (goto-char (point-min))
1865 (while (and (not (image-dired-image-at-point-p))
1866 (not (eobp)))
1867 (delete-char 1))
1868 (while (not (eobp))
1869 (forward-char)
1870 (while (and (not (image-dired-image-at-point-p))
1871 (not (eobp)))
1872 (delete-char 1)))
1873 (goto-char (point-min))
1874 (let ((seen 0)
1875 (thumb-prev-pos 0)
1876 (thumb-width-chars
1877 (ceiling (/ (+ (* 2 image-dired-thumb-relief)
1878 (* 2 image-dired-thumb-margin)
1879 (image-dired-thumb-size 'width))
1880 (float (frame-char-width))))))
1881 (while (not (eobp))
1882 (forward-char)
1883 (if (= image-dired-thumbs-per-row 1)
1884 (insert "\n")
1885 (cl-incf thumb-prev-pos thumb-width-chars)
1886 (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos)))
1887 (cl-incf seen)
1888 (when (and (= seen (- image-dired-thumbs-per-row 1))
1889 (not (eobp)))
1890 (forward-char)
1891 (insert "\n")
1892 (setq seen 0)
1893 (setq thumb-prev-pos 0)))))
1894 (goto-char (point-min))))
1895
1896(defun image-dired-line-up-dynamic ()
1897 "Line up thumbnails images dynamically.
1898Calculate how many thumbnails fit."
1899 (interactive)
1900 (let* ((char-width (frame-char-width))
1901 (width (image-dired-window-width-pixels (image-dired-thumbnail-window)))
1902 (image-dired-thumbs-per-row
1903 (/ width
1904 (+ (* 2 image-dired-thumb-relief)
1905 (* 2 image-dired-thumb-margin)
1906 (image-dired-thumb-size 'width)
1907 char-width))))
1908 (image-dired-line-up)))
1909
1910(defun image-dired-line-up-interactive ()
1911 "Line up thumbnails interactively.
1912Ask user how many thumbnails should be displayed per row."
1913 (interactive)
1914 (let ((image-dired-thumbs-per-row
1915 (string-to-number (read-string "How many thumbs per row: "))))
1916 (if (not (> image-dired-thumbs-per-row 0))
1917 (message "Number must be greater than 0")
1918 (image-dired-line-up))))
1919
1920(defun image-dired-thumbnail-display-external ()
1921 "Display original image for thumbnail at point using external viewer."
1922 (interactive)
1923 (let ((file (image-dired-original-file-name)))
1924 (if (not (image-dired-image-at-point-p))
1925 (message "No thumbnail at point")
1926 (if (not file)
1927 (message "No original file name found")
1928 (start-process "image-dired-thumb-external" nil
1929 image-dired-external-viewer file)))))
1930
1931;;;###autoload
1932(defun image-dired-dired-display-external ()
1933 "Display file at point using an external viewer."
1934 (interactive)
1935 (let ((file (dired-get-filename)))
1936 (start-process "image-dired-external" nil
1937 image-dired-external-viewer file)))
1938
1939(defun image-dired-window-width-pixels (window)
1940 "Calculate WINDOW width in pixels."
1941 (* (window-width window) (frame-char-width)))
1942
1943(defun image-dired-display-window ()
1944 "Return window where `image-dired-display-image-buffer' is visible."
1945 (get-window-with-predicate
1946 (lambda (window)
1947 (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer))
1948 nil t))
1949
1950(defun image-dired-thumbnail-window ()
1951 "Return window where `image-dired-thumbnail-buffer' is visible."
1952 (get-window-with-predicate
1953 (lambda (window)
1954 (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer))
1955 nil t))
1956
1957(defun image-dired-associated-dired-buffer-window ()
1958 "Return window where associated Dired buffer is visible."
1959 (let (buf)
1960 (if (image-dired-image-at-point-p)
1961 (progn
1962 (setq buf (image-dired-associated-dired-buffer))
1963 (get-window-with-predicate
1964 (lambda (window)
1965 (equal (window-buffer window) buf))))
1966 (error "No thumbnail image at point"))))
1967
1968(defun image-dired-display-image (file &optional _ignored)
1969 "Display image FILE in image buffer.
1970Use this when you want to display the image, in a new window.
1971The window will use `image-dired-display-image-mode' which is
1972based on `image-mode'."
1973 (declare (advertised-calling-convention (file) "29.1"))
1974 (setq file (expand-file-name file))
1975 (when (not (file-exists-p file))
1976 (error "No such file: %s" file))
1977 (let ((buf (get-buffer image-dired-display-image-buffer))
1978 (cur-win (selected-window)))
1979 (when buf
1980 (kill-buffer buf))
1981 (when-let ((buf (find-file-noselect file nil t)))
1982 (pop-to-buffer buf)
1983 (rename-buffer image-dired-display-image-buffer)
1984 (image-dired-display-image-mode)
1985 (select-window cur-win))))
1986
1987(defun image-dired-display-thumbnail-original-image (&optional arg)
1988 "Display current thumbnail's original image in display buffer.
1989See documentation for `image-dired-display-image' for more information.
1990With prefix argument ARG, display image in its original size."
1991 (interactive "P")
1992 (let ((file (image-dired-original-file-name)))
1993 (if (not (string-equal major-mode "image-dired-thumbnail-mode"))
1994 (message "Not in image-dired-thumbnail-mode")
1995 (if (not (image-dired-image-at-point-p))
1996 (message "No thumbnail at point")
1997 (if (not file)
1998 (message "No original file name found")
1999 (image-dired-display-image file arg))))))
2000
2001
2002;;;###autoload
2003(defun image-dired-dired-display-image (&optional arg)
2004 "Display current image file.
2005See documentation for `image-dired-display-image' for more information.
2006With prefix argument ARG, display image in its original size."
2007 (interactive "P")
2008 (image-dired-display-image (dired-get-filename) arg))
2009
2010(defun image-dired-image-at-point-p ()
2011 "Return non-nil if there is an `image-dired' thumbnail at point."
2012 (get-text-property (point) 'image-dired-thumbnail))
2013
2014(defun image-dired-refresh-thumb ()
2015 "Force creation of new image for current thumbnail."
2016 (interactive nil image-dired-thumbnail-mode)
2017 (let* ((file (image-dired-original-file-name))
2018 (thumb (expand-file-name (image-dired-thumb-name file))))
2019 (clear-image-cache (expand-file-name thumb))
2020 (image-dired-create-thumb file thumb)))
2021
2022(defun image-dired-rotate-original (degrees)
2023 "Rotate original image DEGREES degrees."
2024 (image-dired--check-executable-exists
2025 'image-dired-cmd-rotate-original-program)
2026 (if (not (image-dired-image-at-point-p))
2027 (message "No image at point")
2028 (let* ((file (image-dired-original-file-name))
2029 (spec
2030 (list
2031 (cons ?d degrees)
2032 (cons ?o (expand-file-name file))
2033 (cons ?t image-dired-temp-rotate-image-file))))
2034 (unless (eq 'jpeg (image-type file))
2035 (user-error "Only JPEG images can be rotated"))
2036 (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
2037 nil nil nil
2038 (mapcar (lambda (arg) (format-spec arg spec))
2039 image-dired-cmd-rotate-original-options))))
2040 (error "Could not rotate image")
2041 (image-dired-display-image image-dired-temp-rotate-image-file)
2042 (if (or (and image-dired-rotate-original-ask-before-overwrite
2043 (y-or-n-p
2044 "Rotate to temp file OK. Overwrite original image? "))
2045 (not image-dired-rotate-original-ask-before-overwrite))
2046 (progn
2047 (copy-file image-dired-temp-rotate-image-file file t)
2048 (image-dired-refresh-thumb))
2049 (image-dired-display-image file))))))
2050
2051(defun image-dired-rotate-original-left ()
2052 "Rotate original image left (counter clockwise) 90 degrees.
2053The result of the rotation is displayed in the image display area
2054and a confirmation is needed before the original image files is
2055overwritten. This confirmation can be turned off using
2056`image-dired-rotate-original-ask-before-overwrite'."
2057 (interactive)
2058 (image-dired-rotate-original "270"))
2059
2060(defun image-dired-rotate-original-right ()
2061 "Rotate original image right (clockwise) 90 degrees.
2062The result of the rotation is displayed in the image display area
2063and a confirmation is needed before the original image files is
2064overwritten. This confirmation can be turned off using
2065`image-dired-rotate-original-ask-before-overwrite'."
2066 (interactive)
2067 (image-dired-rotate-original "90"))
2068
2069
2070;;; EXIF support
2071
2072(defun image-dired-get-exif-file-name (file)
2073 "Use the image's EXIF information to return a unique file name.
2074The file name should be unique as long as you do not take more than
2075one picture per second. The original file name is suffixed at the end
2076for traceability. The format of the returned file name is
2077YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
2078`image-dired-copy-with-exif-file-name'."
2079 (let (data no-exif-data-found)
2080 (if (not (eq 'jpeg (image-type (expand-file-name file))))
2081 (setq no-exif-data-found t
2082 data (format-time-string
2083 "%Y:%m:%d %H:%M:%S"
2084 (file-attribute-modification-time
2085 (file-attributes (expand-file-name file)))))
2086 (setq data (exif-field 'date-time (exif-parse-file
2087 (expand-file-name file)))))
2088 (while (string-match "[ :]" data)
2089 (setq data (replace-match "_" nil nil data)))
2090 (format "%s%s%s" data
2091 (if no-exif-data-found
2092 "_noexif_"
2093 "_")
2094 (file-name-nondirectory file))))
2095
2096(defun image-dired-thumbnail-set-image-description ()
2097 "Set the ImageDescription EXIF tag for the original image.
2098If the image already has a value for this tag, it is used as the
2099default value at the prompt."
2100 (interactive)
2101 (if (not (image-dired-image-at-point-p))
2102 (message "No thumbnail at point")
2103 (let* ((file (image-dired-original-file-name))
2104 (old-value (or (exif-field 'description (exif-parse-file file)) "")))
2105 (if (eq 0
2106 (image-dired-set-exif-data file "ImageDescription"
2107 (read-string "Value of ImageDescription: "
2108 old-value)))
2109 (message "Successfully wrote ImageDescription tag")
2110 (error "Could not write ImageDescription tag")))))
2111
2112(defun image-dired-set-exif-data (file tag-name tag-value)
2113 "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
2114 (image-dired--check-executable-exists
2115 'image-dired-cmd-write-exif-data-program)
2116 (let ((spec
2117 (list
2118 (cons ?f (expand-file-name file))
2119 (cons ?t tag-name)
2120 (cons ?v tag-value))))
2121 (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
2122 (mapcar (lambda (arg) (format-spec arg spec))
2123 image-dired-cmd-write-exif-data-options))))
2124
2125(defun image-dired-copy-with-exif-file-name ()
2126 "Copy file with unique name to main image directory.
2127Copy current or all marked files in Dired to a new file in your
2128main image directory, using a file name generated by
2129`image-dired-get-exif-file-name'. A typical usage for this if when
2130copying images from a digital camera into the image directory.
2131
2132 Typically, you would open up the folder with the incoming
2133digital images, mark the files to be copied, and execute this
2134function. The result is a couple of new files in
2135`image-dired-main-image-directory' called
21362005_05_08_12_52_00_dscn0319.jpg,
21372005_05_08_14_27_45_dscn0320.jpg etc."
2138 (interactive)
2139 (let (new-name
2140 (files (dired-get-marked-files)))
2141 (mapc
2142 (lambda (curr-file)
2143 (setq new-name
2144 (format "%s/%s"
2145 (file-name-as-directory
2146 (expand-file-name image-dired-main-image-directory))
2147 (image-dired-get-exif-file-name curr-file)))
2148 (message "Copying %s to %s" curr-file new-name)
2149 (copy-file curr-file new-name))
2150 files)))
2151
2152;;; Thumbnail mode (cont.)
2153
2154(defun image-dired-display-next-thumbnail-original (&optional arg)
2155 "Move to the next image in the thumbnail buffer and display it.
2156With prefix ARG, move that many thumbnails."
2157 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2158 (image-dired--with-thumbnail-buffer
2159 (image-dired-forward-image arg t)
2160 (image-dired-display-thumbnail-original-image)))
2161
2162(defun image-dired-display-previous-thumbnail-original (arg)
2163 "Move to the previous image in the thumbnail buffer and display it.
2164With prefix ARG, move that many thumbnails."
2165 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2166 (image-dired-display-next-thumbnail-original (- arg)))
2167
2168
2169;;; Image Comments
2170
2171(defun image-dired-write-comments (file-comments)
2172 "Write file comments to database.
2173Write file comments to one or more files.
2174FILE-COMMENTS is an alist on the following form:
2175 ((FILE . COMMENT) ... )"
2176 (image-dired-sane-db-file)
2177 (let (end comment-beg-pos comment-end-pos file comment)
2178 (image-dired--with-db-file
2179 (setq buffer-file-name image-dired-db-file)
2180 (dolist (elt file-comments)
2181 (setq file (car elt)
2182 comment (cdr elt))
2183 (goto-char (point-min))
2184 (if (search-forward-regexp (format "^%s.*$" file) nil t)
2185 (progn
2186 (setq end (point))
2187 (beginning-of-line)
2188 ;; Delete old comment, if any
2189 (when (search-forward ";comment:" end t)
2190 (setq comment-beg-pos (match-beginning 0))
2191 ;; Any tags after the comment?
2192 (if (search-forward ";" end t)
2193 (setq comment-end-pos (- (point) 1))
2194 (setq comment-end-pos end))
2195 ;; Delete comment tag and comment
2196 (delete-region comment-beg-pos comment-end-pos))
2197 ;; Insert new comment
2198 (beginning-of-line)
2199 (unless (search-forward ";" end t)
2200 (end-of-line)
2201 (insert ";"))
2202 (insert (format "comment:%s;" comment)))
2203 ;; File does not exist in database - add it.
2204 (goto-char (point-max))
2205 (insert (format "%s;comment:%s\n" file comment))))
2206 (save-buffer))))
2207
2208(defun image-dired-update-property (prop value)
2209 "Update text property PROP with value VALUE at point."
2210 (let ((inhibit-read-only t))
2211 (put-text-property
2212 (point) (1+ (point))
2213 prop
2214 value)))
2215
2216;;;###autoload
2217(defun image-dired-dired-comment-files ()
2218 "Add comment to current or marked files in Dired."
2219 (interactive)
2220 (let ((comment (image-dired-read-comment)))
2221 (image-dired-write-comments
2222 (mapcar
2223 (lambda (curr-file)
2224 (cons curr-file comment))
2225 (dired-get-marked-files)))))
2226
2227(defun image-dired-comment-thumbnail ()
2228 "Add comment to current thumbnail in thumbnail buffer."
2229 (interactive)
2230 (let* ((file (image-dired-original-file-name))
2231 (comment (image-dired-read-comment file)))
2232 (image-dired-write-comments (list (cons file comment)))
2233 (image-dired-update-property 'comment comment))
2234 (image-dired-update-header-line))
2235
2236(defun image-dired-read-comment (&optional file)
2237 "Read comment for an image.
2238Optionally use old comment from FILE as initial value."
2239 (let ((comment
2240 (read-string
2241 "Comment: "
2242 (if file (image-dired-get-comment file)))))
2243 comment))
2244
2245(defun image-dired-get-comment (file)
2246 "Get comment for file FILE."
2247 (image-dired-sane-db-file)
2248 (image-dired--with-db-file
2249 (let (end comment-beg-pos comment-end-pos comment)
2250 (when (search-forward-regexp (format "^%s" file) nil t)
2251 (end-of-line)
2252 (setq end (point))
2253 (beginning-of-line)
2254 (when (search-forward ";comment:" end t)
2255 (setq comment-beg-pos (point))
2256 (if (search-forward ";" end t)
2257 (setq comment-end-pos (- (point) 1))
2258 (setq comment-end-pos end))
2259 (setq comment (buffer-substring
2260 comment-beg-pos comment-end-pos))))
2261 comment)))
2262
2263;;;###autoload
2264(defun image-dired-mark-tagged-files (regexp)
2265 "Use REGEXP to mark files with matching tag.
2266A `tag' is a keyword, a piece of meta data, associated with an
2267image file and stored in image-dired's database file. This command
2268lets you input a regexp and this will be matched against all tags
2269on all image files in the database file. The files that have a
2270matching tag will be marked in the Dired buffer."
2271 (interactive "sMark tagged files (regexp): ")
2272 (image-dired-sane-db-file)
2273 (let ((hits 0)
2274 files)
2275 (image-dired--with-db-file
2276 ;; Collect matches
2277 (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t)
2278 (let ((file (match-string 1))
2279 (tags (split-string (match-string 2) ";")))
2280 (when (seq-find (lambda (tag)
2281 (string-match-p regexp tag))
2282 tags)
2283 (push file files)))))
2284 ;; Mark files
2285 (dolist (curr-file files)
2286 ;; I tried using `dired-mark-files-regexp' but it was waaaay to
2287 ;; slow. Don't bother about hits found in other directories
2288 ;; than the current one.
2289 (when (string= (file-name-as-directory
2290 (expand-file-name default-directory))
2291 (file-name-as-directory
2292 (file-name-directory curr-file)))
2293 (setq curr-file (file-name-nondirectory curr-file))
2294 (goto-char (point-min))
2295 (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
2296 (setq hits (+ hits 1))
2297 (dired-mark 1))))
2298 (message "%d files with matching tag marked" hits)))
2299
2300
2301
2302;;; Mouse support
2303
2304(defun image-dired-mouse-display-image (event)
2305 "Use mouse EVENT, call `image-dired-display-image' to display image.
2306Track this in associated Dired buffer if `image-dired-track-movement' is
2307non-nil."
2308 (interactive "e")
2309 (mouse-set-point event)
2310 (goto-char (posn-point (event-end event)))
2311 (unless (image-at-point-p)
2312 (image-dired-backward-image))
2313 (let ((file (image-dired-original-file-name)))
2314 (when file
2315 (if image-dired-track-movement
2316 (image-dired-track-original-file))
2317 (image-dired-display-image file))))
2318
2319(defun image-dired-mouse-select-thumbnail (event)
2320 "Use mouse EVENT to select thumbnail image.
2321Track this in associated Dired buffer if `image-dired-track-movement' is
2322non-nil."
2323 (interactive "e")
2324 (mouse-set-point event)
2325 (goto-char (posn-point (event-end event)))
2326 (unless (image-at-point-p)
2327 (image-dired-backward-image))
2328 (if image-dired-track-movement
2329 (image-dired-track-original-file))
2330 (image-dired-update-header-line))
2331
2332
2333
2334;;; Dired marks and tags
2335
2336(defun image-dired-thumb-file-marked-p (&optional flagged)
2337 "Check if file is marked in associated Dired buffer.
2338If optional argument FLAGGED is non-nil, check if file is flagged
2339for deletion instead."
2340 (let ((file-name (image-dired-original-file-name))
2341 (dired-buf (image-dired-associated-dired-buffer)))
2342 (when (and dired-buf file-name)
2343 (with-current-buffer dired-buf
2344 (save-excursion
2345 (when (dired-goto-file file-name)
2346 (if flagged
2347 (image-dired-dired-file-flagged-p)
2348 (image-dired-dired-file-marked-p))))))))
2349
2350(defun image-dired-thumb-file-flagged-p ()
2351 "Check if file is flagged for deletion in associated Dired buffer."
2352 (image-dired-thumb-file-marked-p t))
2353
2354(defun image-dired-delete-marked ()
2355 "Delete current or marked thumbnails and associated images."
2356 (interactive)
2357 (image-dired--with-marked
2358 (image-dired-delete-char)
2359 (unless (bobp)
2360 (backward-char)))
2361 (image-dired--line-up-with-method)
2362 (with-current-buffer (image-dired-associated-dired-buffer)
2363 (dired-do-delete)))
2364
2365(defun image-dired-thumb-update-marks ()
2366 "Update the marks in the thumbnail buffer."
2367 (when image-dired-thumb-visible-marks
2368 (with-current-buffer image-dired-thumbnail-buffer
2369 (save-mark-and-excursion
2370 (goto-char (point-min))
2371 (let ((inhibit-read-only t))
2372 (while (not (eobp))
2373 (with-silent-modifications
2374 (cond ((image-dired-thumb-file-marked-p)
2375 (add-face-text-property (point) (1+ (point))
2376 'image-dired-thumb-mark))
2377 ((image-dired-thumb-file-flagged-p)
2378 (add-face-text-property (point) (1+ (point))
2379 'image-dired-thumb-flagged))
2380 (t (remove-text-properties (point) (1+ (point))
2381 '(face image-dired-thumb-mark)))))
2382 (forward-char)))))))
2383
2384(defun image-dired-mouse-toggle-mark-1 ()
2385 "Toggle Dired mark for current thumbnail.
2386Track this in associated Dired buffer if
2387`image-dired-track-movement' is non-nil."
2388 (when image-dired-track-movement
2389 (image-dired-track-original-file))
2390 (image-dired-toggle-mark-thumb-original-file))
2391
2392(defun image-dired-mouse-toggle-mark (event)
2393 "Use mouse EVENT to toggle Dired mark for thumbnail.
2394Toggle marks of all thumbnails in region, if it's active.
2395Track this in associated Dired buffer if
2396`image-dired-track-movement' is non-nil."
2397 (interactive "e")
2398 (if (use-region-p)
2399 (let ((end (region-end)))
2400 (save-excursion
2401 (goto-char (region-beginning))
2402 (while (<= (point) end)
2403 (when (image-dired-image-at-point-p)
2404 (image-dired-mouse-toggle-mark-1))
2405 (forward-char))))
2406 (mouse-set-point event)
2407 (goto-char (posn-point (event-end event)))
2408 (image-dired-mouse-toggle-mark-1))
2409 (image-dired-thumb-update-marks))
2410
2411(defun image-dired-dired-display-properties ()
2412 "Display properties for Dired file in the echo area."
2413 (interactive)
2414 (let* ((file (dired-get-filename))
2415 (file-name (file-name-nondirectory file))
2416 (dired-buf (buffer-name (current-buffer)))
2417 (props (mapconcat #'identity (image-dired-list-tags file) ", "))
2418 (comment (image-dired-get-comment file))
2419 (message-log-max nil))
2420 (if file-name
2421 (message "%s"
2422 (image-dired-format-properties-string
2423 dired-buf
2424 file-name
2425 props
2426 comment)))))
2427
2428
2429
2430;;; Gallery support
2431
2432;; TODO:
2433;; * Support gallery creation when using per-directory thumbnail
2434;; storage.
2435;; * Enhanced gallery creation with basic CSS-support and pagination
2436;; of tag pages with many pictures.
2437
2438(defgroup image-dired-gallery nil
2439 "Image-Dired support for generating a HTML gallery."
2440 :prefix "image-dired-"
2441 :group 'image-dired
2442 :version "29.1")
2443
2444(defcustom image-dired-gallery-dir
2445 (expand-file-name ".image-dired_gallery" image-dired-dir)
2446 "Directory to store generated gallery html pages.
2447The name of this directory needs to be \"shared\" to the public
2448so that it can access the index.html page that image-dired creates."
2449 :type 'directory)
2450
2451(defcustom image-dired-gallery-image-root-url
2452 "https://example.org/image-diredpics"
2453 "URL where the full size images are to be found on your web server.
2454Note that this URL has to be configured on your web server.
2455Image-Dired expects to find pictures in this directory.
2456This is used by `image-dired-gallery-generate'."
2457 :type 'string
2458 :version "29.1")
2459
2460(defcustom image-dired-gallery-thumb-image-root-url
2461 "https://example.org/image-diredthumbs"
2462 "URL where the thumbnail images are to be found on your web server.
2463Note that URL path has to be configured on your web server.
2464Image-Dired expects to find pictures in this directory.
2465This is used by `image-dired-gallery-generate'."
2466 :type 'string
2467 :version "29.1")
2468
2469(defcustom image-dired-gallery-hidden-tags
2470 (list "private" "hidden" "pending")
2471 "List of \"hidden\" tags.
2472Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
2473 :type '(repeat string))
2474
2475(defvar image-dired-tag-file-list nil
2476 "List to store tag-file structure.")
2477
2478(defvar image-dired-file-tag-list nil
2479 "List to store file-tag structure.")
2480
2481(defvar image-dired-file-comment-list nil
2482 "List to store file comments.")
2483
2484(defun image-dired--add-to-tag-file-lists (tag file)
2485 "Helper function used from `image-dired--create-gallery-lists'.
2486
2487Add TAG to FILE in one list and FILE to TAG in the other.
2488
2489Lisp structures look like the following:
2490
2491image-dired-file-tag-list:
2492
2493 ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...)
2494 (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...)
2495 ...)
2496
2497image-dired-tag-file-list:
2498
2499 ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...)
2500 (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...)
2501 ...)"
2502 ;; Add tag to file list
2503 (let (curr)
2504 (if image-dired-file-tag-list
2505 (if (setq curr (assoc file image-dired-file-tag-list))
2506 (setcdr curr (cons tag (cdr curr)))
2507 (setcdr image-dired-file-tag-list
2508 (cons (list file tag) (cdr image-dired-file-tag-list))))
2509 (setq image-dired-file-tag-list (list (list file tag))))
2510 ;; Add file to tag list
2511 (if image-dired-tag-file-list
2512 (if (setq curr (assoc tag image-dired-tag-file-list))
2513 (if (not (member file curr))
2514 (setcdr curr (cons file (cdr curr))))
2515 (setcdr image-dired-tag-file-list
2516 (cons (list tag file) (cdr image-dired-tag-file-list))))
2517 (setq image-dired-tag-file-list (list (list tag file))))))
2518
2519(defun image-dired--add-to-file-comment-list (file comment)
2520 "Helper function used from `image-dired--create-gallery-lists'.
2521
2522For FILE, add COMMENT to list.
2523
2524Lisp structure looks like the following:
2525
2526image-dired-file-comment-list:
2527
2528 ((\"filename1\" . \"comment1\")
2529 (\"filename2\" . \"comment2\")
2530 ...)"
2531 (if image-dired-file-comment-list
2532 (if (not (assoc file image-dired-file-comment-list))
2533 (setcdr image-dired-file-comment-list
2534 (cons (cons file comment)
2535 (cdr image-dired-file-comment-list))))
2536 (setq image-dired-file-comment-list (list (cons file comment)))))
2537
2538(defun image-dired--create-gallery-lists ()
2539 "Create temporary lists used by `image-dired-gallery-generate'."
2540 (image-dired-sane-db-file)
2541 (image-dired--with-db-file
2542 (let (end beg file row-tags)
2543 (setq image-dired-tag-file-list nil)
2544 (setq image-dired-file-tag-list nil)
2545 (setq image-dired-file-comment-list nil)
2546 (goto-char (point-min))
2547 (while (search-forward-regexp "^." nil t)
2548 (end-of-line)
2549 (setq end (point))
2550 (beginning-of-line)
2551 (setq beg (point))
2552 (unless (search-forward ";" end nil)
2553 (error "Something is really wrong, check format of database"))
2554 (setq row-tags (split-string
2555 (buffer-substring beg end) ";"))
2556 (setq file (car row-tags))
2557 (dolist (x (cdr row-tags))
2558 (if (not (string-match "^comment:\\(.*\\)" x))
2559 (image-dired--add-to-tag-file-lists x file)
2560 (image-dired--add-to-file-comment-list file (match-string 1 x)))))))
2561 ;; Sort tag-file list
2562 (setq image-dired-tag-file-list
2563 (sort image-dired-tag-file-list
2564 (lambda (x y)
2565 (string< (car x) (car y))))))
2566
2567(defun image-dired--hidden-p (file)
2568 "Return t if image FILE has a \"hidden\" tag."
2569 (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
2570 if (member tag image-dired-gallery-hidden-tags) return t))
2571
2572(defun image-dired-gallery-generate ()
2573 "Generate gallery pages.
2574First we create a couple of Lisp structures from the database to make
2575it easier to generate, then HTML-files are created in
2576`image-dired-gallery-dir'."
2577 (interactive)
2578 (if (eq 'per-directory image-dired-thumbnail-storage)
2579 (error "Currently, gallery generation is not supported \
2580when using per-directory thumbnail file storage"))
2581 (image-dired--create-gallery-lists)
2582 (let ((tags image-dired-tag-file-list)
2583 (index-file (format "%s/index.html" image-dired-gallery-dir))
2584 count tag tag-file
2585 comment file-tags tag-link tag-link-list)
2586 ;; Make sure gallery root exist
2587 (if (file-exists-p image-dired-gallery-dir)
2588 (if (not (file-directory-p image-dired-gallery-dir))
2589 (error "Variable image-dired-gallery-dir is not a directory"))
2590 ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
2591 (make-directory image-dired-gallery-dir))
2592 ;; Open index file
2593 (with-temp-file index-file
2594 (if (file-exists-p index-file)
2595 (insert-file-contents index-file))
2596 (insert "<html>\n")
2597 (insert " <body>\n")
2598 (insert " <h2>Image-Dired Gallery</h2>\n")
2599 (insert (format "<p>\n Gallery generated %s\n <p>\n"
2600 (current-time-string)))
2601 (insert " <h3>Tag index</h3>\n")
2602 (setq count 1)
2603 ;; Pre-generate list of all tag links
2604 (dolist (curr tags)
2605 (setq tag (car curr))
2606 (when (not (member tag image-dired-gallery-hidden-tags))
2607 (setq tag-link (format "<a href=\"%d.html\">%s</a>" count tag))
2608 (if tag-link-list
2609 (setq tag-link-list
2610 (append tag-link-list (list (cons tag tag-link))))
2611 (setq tag-link-list (list (cons tag tag-link))))
2612 (setq count (1+ count))))
2613 (setq count 1)
2614 ;; Main loop where we generated thumbnail pages per tag
2615 (dolist (curr tags)
2616 (setq tag (car curr))
2617 ;; Don't display hidden tags
2618 (when (not (member tag image-dired-gallery-hidden-tags))
2619 ;; Insert link to tag page in index
2620 (insert (format " %s<br>\n" (cdr (assoc tag tag-link-list))))
2621 ;; Open per-tag file
2622 (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count))
2623 (with-temp-file tag-file
2624 (if (file-exists-p tag-file)
2625 (insert-file-contents tag-file))
2626 (erase-buffer)
2627 (insert "<html>\n")
2628 (insert " <body>\n")
2629 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2630 (insert (format " <h2>Images with tag &quot;%s&quot;</h2>" tag))
2631 ;; Main loop for files per tag page
2632 (dolist (file (cdr curr))
2633 (unless (image-dired-hidden-p file)
2634 ;; Insert thumbnail with link to full image
2635 (insert
2636 (format "<a href=\"%s/%s\"><img src=\"%s/%s\"%s></a>\n"
2637 image-dired-gallery-image-root-url
2638 (file-name-nondirectory file)
2639 image-dired-gallery-thumb-image-root-url
2640 (file-name-nondirectory (image-dired-thumb-name file)) file))
2641 ;; Insert comment, if any
2642 (if (setq comment (cdr (assoc file image-dired-file-comment-list)))
2643 (insert (format "<br>\n%s<br>\n" comment))
2644 (insert "<br>\n"))
2645 ;; Insert links to other tags, if any
2646 (when (> (length
2647 (setq file-tags (assoc file image-dired-file-tag-list))) 2)
2648 (insert "[ ")
2649 (dolist (extra-tag file-tags)
2650 ;; Only insert if not file name or the main tag
2651 (if (and (not (equal extra-tag tag))
2652 (not (equal extra-tag file)))
2653 (insert
2654 (format "%s " (cdr (assoc extra-tag tag-link-list))))))
2655 (insert "]<br>\n"))))
2656 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2657 (insert " </body>\n")
2658 (insert "</html>\n"))
2659 (setq count (1+ count))))
2660 (insert " </body>\n")
2661 (insert "</html>"))))
2662
2663
2664;;; Tag support
2665
2666(defvar image-dired-widget-list nil
2667 "List to keep track of meta data in edit buffer.")
2668
2669(declare-function widget-forward "wid-edit" (arg))
2670
2671;;;###autoload
2672(defun image-dired-dired-edit-comment-and-tags ()
2673 "Edit comment and tags of current or marked image files.
2674Edit comment and tags for all marked image files in an
2675easy-to-use form."
2676 (interactive)
2677 (setq image-dired-widget-list nil)
2678 ;; Setup buffer.
2679 (let ((files (dired-get-marked-files)))
2680 (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
2681 (kill-all-local-variables)
2682 (let ((inhibit-read-only t))
2683 (erase-buffer))
2684 (remove-overlays)
2685 ;; Some help for the user.
2686 (widget-insert
2687"\nEdit comments and tags for each image. Separate multiple tags
2688with a comma. Move forward between fields using TAB or RET.
2689Move to the previous field using backtab (S-TAB). Save by
2690activating the Save button at the bottom of the form or cancel
2691the operation by activating the Cancel button.\n\n")
2692 ;; Here comes all images and a comment and tag field for each
2693 ;; image.
2694 (let (thumb-file img comment-widget tag-widget)
2695
2696 (dolist (file files)
2697
2698 (setq thumb-file (image-dired-thumb-name file)
2699 img (create-image thumb-file))
2700
2701 (insert-image img)
2702 (widget-insert "\n\nComment: ")
2703 (setq comment-widget
2704 (widget-create 'editable-field
2705 :size 60
2706 :format "%v "
2707 :value (or (image-dired-get-comment file) "")))
2708 (widget-insert "\nTags: ")
2709 (setq tag-widget
2710 (widget-create 'editable-field
2711 :size 60
2712 :format "%v "
2713 :value (or (mapconcat
2714 #'identity
2715 (image-dired-list-tags file)
2716 ",") "")))
2717 ;; Save information in all widgets so that we can use it when
2718 ;; the user saves the form.
2719 (setq image-dired-widget-list
2720 (append image-dired-widget-list
2721 (list (list file comment-widget tag-widget))))
2722 (widget-insert "\n\n")))
2723
2724 ;; Footer with Save and Cancel button.
2725 (widget-insert "\n")
2726 (widget-create 'push-button
2727 :notify
2728 (lambda (&rest _ignore)
2729 (image-dired-save-information-from-widgets)
2730 (bury-buffer)
2731 (message "Done"))
2732 "Save")
2733 (widget-insert " ")
2734 (widget-create 'push-button
2735 :notify
2736 (lambda (&rest _ignore)
2737 (bury-buffer)
2738 (message "Operation canceled"))
2739 "Cancel")
2740 (widget-insert "\n")
2741 (use-local-map widget-keymap)
2742 (widget-setup)
2743 ;; Jump to the first widget.
2744 (widget-forward 1)))
2745
2746(defun image-dired-save-information-from-widgets ()
2747 "Save information found in `image-dired-widget-list'.
2748Use the information in `image-dired-widget-list' to save comments and
2749tags to their respective image file. Internal function used by
2750`image-dired-dired-edit-comment-and-tags'."
2751 (let (file comment tag-string tag-list lst)
2752 (image-dired-write-comments
2753 (mapcar
2754 (lambda (widget)
2755 (setq file (car widget)
2756 comment (widget-value (cadr widget)))
2757 (cons file comment))
2758 image-dired-widget-list))
2759 (image-dired-write-tags
2760 (dolist (widget image-dired-widget-list lst)
2761 (setq file (car widget)
2762 tag-string (widget-value (car (cddr widget)))
2763 tag-list (split-string tag-string ","))
2764 (dolist (tag tag-list)
2765 (push (cons file tag) lst))))))
2766
2767
2768;;; bookmark.el support
2769
2770(declare-function bookmark-make-record-default
2771 "bookmark" (&optional no-file no-context posn))
2772(declare-function bookmark-prop-get "bookmark" (bookmark prop))
2773
2774(defun image-dired-bookmark-name ()
2775 "Create a default bookmark name for the current EWW buffer."
2776 (file-name-nondirectory
2777 (directory-file-name
2778 (file-name-directory (image-dired-original-file-name)))))
2779
2780(defun image-dired-bookmark-make-record ()
2781 "Create a bookmark for the current EWW buffer."
2782 `(,(image-dired-bookmark-name)
2783 ,@(bookmark-make-record-default t)
2784 (location . ,(file-name-directory (image-dired-original-file-name)))
2785 (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name)))
2786 (handler . image-dired-bookmark-jump)))
2787
2788;;;###autoload
2789(defun image-dired-bookmark-jump (bookmark)
2790 "Default bookmark handler for Image-Dired buffers."
2791 ;; User already cached thumbnails, so disable any checking.
2792 (let ((image-dired-show-all-from-dir-max-files nil))
2793 (image-dired (bookmark-prop-get bookmark 'location))
2794 ;; TODO: Go to the bookmarked file, if it exists.
2795 ;; (bookmark-prop-get bookmark 'image-dired-file)
2796 (goto-char (point-min))))
2797
2798(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired")
2799
2800;;; Obsolete
2801
2802;;;###autoload
2803(define-obsolete-function-alias 'tumme #'image-dired "24.4")
2804
2805;;;###autoload
2806(define-obsolete-function-alias 'image-dired-setup-dired-keybindings
2807 #'image-dired-minor-mode "26.1")
2808
2809(defcustom image-dired-temp-image-file
2810 (expand-file-name ".image-dired_temp" image-dired-dir)
2811 "Name of temporary image file used by various commands."
2812 :type 'file)
2813(make-obsolete-variable 'image-dired-temp-image-file
2814 "no longer used." "29.1")
2815
2816(defcustom image-dired-cmd-create-temp-image-program
2817 (if (executable-find "gm") "gm" "convert")
2818 "Executable used to create temporary image.
2819Used together with `image-dired-cmd-create-temp-image-options'."
2820 :type 'file
2821 :version "29.1")
2822(make-obsolete-variable 'image-dired-cmd-create-temp-image-program
2823 "no longer used." "29.1")
2824
2825(defcustom image-dired-cmd-create-temp-image-options
2826 (let ((opts '("-size" "%wx%h" "%f[0]"
2827 "-resize" "%wx%h>"
2828 "-strip" "jpeg:%t")))
2829 (if (executable-find "gm") (cons "convert" opts) opts))
2830 "Options of command used to create temporary image for display window.
2831Used together with `image-dired-cmd-create-temp-image-program',
2832Available format specifiers are: %w and %h which are replaced by
2833the calculated max size for width and height in the image display window,
2834%f which is replaced by the file name of the original image and %t which
2835is replaced by the file name of the temporary file."
2836 :version "29.1"
2837 :type '(repeat (string :tag "Argument")))
2838(make-obsolete-variable 'image-dired-cmd-create-temp-image-options
2839 "no longer used." "29.1")
2840
2841(defcustom image-dired-display-window-width-correction 1
2842 "Number to be used to correct image display window width.
2843Change if the default (1) does not work (i.e. if the image does not
2844completely fit)."
2845 :type 'integer)
2846(make-obsolete-variable 'image-dired-display-window-width-correction
2847 "no longer used." "29.1")
2848
2849(defcustom image-dired-display-window-height-correction 0
2850 "Number to be used to correct image display window height.
2851Change if the default (0) does not work (i.e. if the image does not
2852completely fit)."
2853 :type 'integer)
2854(make-obsolete-variable 'image-dired-display-window-height-correction
2855 "no longer used." "29.1")
2856
2857(defun image-dired-display-window-width (window)
2858 "Return width, in pixels, of WINDOW."
2859 (declare (obsolete nil "29.1"))
2860 (- (image-dired-window-width-pixels window)
2861 image-dired-display-window-width-correction))
2862
2863(defun image-dired-display-window-height (window)
2864 "Return height, in pixels, of WINDOW."
2865 (declare (obsolete nil "29.1"))
2866 (- (image-dired-window-height-pixels window)
2867 image-dired-display-window-height-correction))
2868
2869(defun image-dired-window-height-pixels (window)
2870 "Calculate WINDOW height in pixels."
2871 (declare (obsolete nil "29.1"))
2872 ;; Note: The mode-line consumes one line
2873 (* (- (window-height window) 1) (frame-char-height)))
2874
2875(defcustom image-dired-cmd-read-exif-data-program "exiftool"
2876 "Program used to read EXIF data to image.
2877Used together with `image-dired-cmd-read-exif-data-options'."
2878 :type 'file)
2879(make-obsolete-variable 'image-dired-cmd-read-exif-data-program
2880 "use `exif-parse-file' and `exif-field' instead." "29.1")
2881
2882(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f")
2883 "Arguments of command used to read EXIF data.
2884Used with `image-dired-cmd-read-exif-data-program'.
2885Available format specifiers are: %f which is replaced
2886by the image file name and %t which is replaced by the tag name."
2887 :version "26.1"
2888 :type '(repeat (string :tag "Argument")))
2889(make-obsolete-variable 'image-dired-cmd-read-exif-data-options
2890 "use `exif-parse-file' and `exif-field' instead." "29.1")
2891
2892(defun image-dired-get-exif-data (file tag-name)
2893 "From FILE, return EXIF tag TAG-NAME."
2894 (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1"))
2895 (image-dired--check-executable-exists
2896 'image-dired-cmd-read-exif-data-program)
2897 (let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
2898 (spec (list (cons ?f file) (cons ?t tag-name)))
2899 tag-value)
2900 (with-current-buffer buf
2901 (delete-region (point-min) (point-max))
2902 (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
2903 nil t nil
2904 (mapcar
2905 (lambda (arg) (format-spec arg spec))
2906 image-dired-cmd-read-exif-data-options))
2907 0))
2908 (error "Could not get EXIF tag")
2909 (goto-char (point-min))
2910 ;; Clean buffer from newlines and carriage returns before
2911 ;; getting final info
2912 (while (search-forward-regexp "[\n\r]" nil t)
2913 (replace-match "" nil t))
2914 (setq tag-value (buffer-substring (point-min) (point-max)))))
2915 tag-value))
2916
2917(defcustom image-dired-cmd-rotate-thumbnail-program
2918 (if (executable-find "gm") "gm" "mogrify")
2919 "Executable used to rotate thumbnail.
2920Used together with `image-dired-cmd-rotate-thumbnail-options'."
2921 :type 'file
2922 :version "29.1")
2923(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1")
2924
2925(defcustom image-dired-cmd-rotate-thumbnail-options
2926 (let ((opts '("-rotate" "%d" "%t")))
2927 (if (executable-find "gm") (cons "mogrify" opts) opts))
2928 "Arguments of command used to rotate thumbnail image.
2929Used with `image-dired-cmd-rotate-thumbnail-program'.
2930Available format specifiers are: %d which is replaced by the
2931number of (positive) degrees to rotate the image, normally 90 or 270
2932\(for 90 degrees right and left), %t which is replaced by the file name
2933of the thumbnail file."
2934 :version "29.1"
2935 :type '(repeat (string :tag "Argument")))
2936(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1")
2937
2938(defun image-dired-rotate-thumbnail (degrees)
2939 "Rotate thumbnail DEGREES degrees."
2940 (declare (obsolete image-dired-refresh-thumb "29.1"))
2941 (image-dired--check-executable-exists
2942 'image-dired-cmd-rotate-thumbnail-program)
2943 (if (not (image-dired-image-at-point-p))
2944 (message "No thumbnail at point")
2945 (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
2946 (thumb (expand-file-name file))
2947 (spec (list (cons ?d degrees) (cons ?t thumb))))
2948 (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil
2949 (mapcar (lambda (arg) (format-spec arg spec))
2950 image-dired-cmd-rotate-thumbnail-options))
2951 (clear-image-cache thumb))))
2952
2953(defun image-dired-rotate-thumbnail-left ()
2954 "Rotate thumbnail left (counter clockwise) 90 degrees."
2955 (declare (obsolete image-dired-refresh-thumb "29.1"))
2956 (interactive)
2957 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2958 (image-dired-rotate-thumbnail "270")))
2959
2960(defun image-dired-rotate-thumbnail-right ()
2961 "Rotate thumbnail counter right (clockwise) 90 degrees."
2962 (declare (obsolete image-dired-refresh-thumb "29.1"))
2963 (interactive)
2964 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2965 (image-dired-rotate-thumbnail "90")))
2966
2967(defun image-dired-modify-mark-on-thumb-original-file (command)
2968 "Modify mark in Dired buffer.
2969COMMAND is one of `mark' for marking file in Dired, `unmark' for
2970unmarking file in Dired or `flag' for flagging file for delete in
2971Dired."
2972 (declare (obsolete image-dired--on-file-in-dired-buffer "29.1"))
2973 (let ((file-name (image-dired-original-file-name))
2974 (dired-buf (image-dired-associated-dired-buffer)))
2975 (if (not (and dired-buf file-name))
2976 (message "No image, or image with correct properties, at point")
2977 (with-current-buffer dired-buf
2978 (message "%s" file-name)
2979 (when (dired-goto-file file-name)
2980 (cond ((eq command 'mark) (dired-mark 1))
2981 ((eq command 'unmark) (dired-unmark 1))
2982 ((eq command 'toggle)
2983 (if (image-dired-dired-file-marked-p)
2984 (dired-unmark 1)
2985 (dired-mark 1)))
2986 ((eq command 'flag) (dired-flag-file-deletion 1)))
2987 (image-dired-thumb-update-marks))))))
2988
2989(defun image-dired-display-current-image-full ()
2990 "Display current image in full size."
2991 (declare (obsolete image-transform-original "29.1"))
2992 (interactive nil image-dired-thumbnail-mode)
2993 (let ((file (image-dired-original-file-name)))
2994 (if file
2995 (progn
2996 (image-dired-display-image file)
2997 (with-current-buffer image-dired-display-image-buffer
2998 (image-transform-original)))
2999 (error "No original file name at point"))))
3000
3001(defun image-dired-display-current-image-sized ()
3002 "Display current image in sized to fit window dimensions."
3003 (declare (obsolete image-mode-fit-frame "29.1"))
3004 (interactive nil image-dired-thumbnail-mode)
3005 (let ((file (image-dired-original-file-name)))
3006 (if file
3007 (progn
3008 (image-dired-display-image file))
3009 (error "No original file name at point"))))
3010
3011(defun image-dired-add-to-tag-file-list (tag file)
3012 "Add relation between TAG and FILE."
3013 (declare (obsolete nil "29.1"))
3014 (let (curr)
3015 (if image-dired-tag-file-list
3016 (if (setq curr (assoc tag image-dired-tag-file-list))
3017 (if (not (member file curr))
3018 (setcdr curr (cons file (cdr curr))))
3019 (setcdr image-dired-tag-file-list
3020 (cons (list tag file) (cdr image-dired-tag-file-list))))
3021 (setq image-dired-tag-file-list (list (list tag file))))))
3022
3023(defun image-dired-display-thumb-properties ()
3024 "Display thumbnail properties in the echo area."
3025 (declare (obsolete image-dired-update-header-line "29.1"))
3026 (image-dired-update-header-line))
3027
3028(defvar image-dired-slideshow-count 0
3029 "Keeping track on number of images in slideshow.")
3030(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1")
3031
3032(defvar image-dired-slideshow-times 0
3033 "Number of pictures to display in slideshow.")
3034(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1")
3035
3036(define-obsolete-function-alias 'image-dired-create-display-image-buffer
3037 #'ignore "29.1")
3038(define-obsolete-function-alias 'image-dired-create-gallery-lists
3039 #'image-dired--create-gallery-lists "29.1")
3040(define-obsolete-function-alias 'image-dired-add-to-file-comment-list
3041 #'image-dired--add-to-file-comment-list "29.1")
3042(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists
3043 #'image-dired--add-to-tag-file-lists "29.1")
3044(define-obsolete-function-alias 'image-dired-hidden-p
3045 #'image-dired--hidden-p "29.1")
3046
3047;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3048;;;;;;;;; TEST-SECTION ;;;;;;;;;;;
3049;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3050
3051;; (defvar image-dired-dir-max-size 12300000)
3052
3053;; (defun image-dired-test-clean-old-files ()
3054;; "Clean `image-dired-dir' from old thumbnail files.
3055;; \"Oldness\" measured using last access time. If the total size of all
3056;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size',
3057;; old files are deleted until the max size is reached."
3058;; (let* ((files
3059;; (sort
3060;; (mapcar
3061;; (lambda (f)
3062;; (let ((fattribs (file-attributes f)))
3063;; `(,(file-attribute-access-time fattribs)
3064;; ,(file-attribute-size fattribs) ,f)))
3065;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$"))
3066;; ;; Sort function. Compare time between two files.
3067;; (lambda (l1 l2)
3068;; (time-less-p (car l1) (car l2)))))
3069;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files))))
3070;; (while (> dirsize image-dired-dir-max-size)
3071;; (y-or-n-p
3072;; (format "Size of thumbnail directory: %d, delete old file %s? "
3073;; dirsize (cadr (cdar files))))
3074;; (delete-file (cadr (cdar files)))
3075;; (setq dirsize (- dirsize (car (cdar files))))
3076;; (setq files (cdr files)))))
3077
3078(provide 'image-dired)
3079
3080;;; 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 @@
1;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*-
2
3;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
4
5;; Version: 0.4.11
6;; Keywords: multimedia
7;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; BACKGROUND
27;; ==========
28;;
29;; I needed a program to browse, organize and tag my pictures. I got
30;; tired of the old gallery program I used as it did not allow
31;; multi-file operations easily. Also, it put things out of my
32;; control. Image viewing programs I tested did not allow multi-file
33;; operations or did not do what I wanted it to.
34;;
35;; So, I got the idea to use the wonderful functionality of Emacs and
36;; `dired' to do it. It would allow me to do almost anything I wanted,
37;; which is basically just to browse all my pictures in an easy way,
38;; letting me manipulate and tag them in various ways. `dired' already
39;; provide all the file handling and navigation facilities; I only
40;; needed to add some functions to display the images.
41;;
42;; I briefly tried out thumbs.el, and although it seemed more
43;; powerful than this package, it did not work the way I wanted to. It
44;; was too slow to create thumbnails of all files in a directory (I
45;; currently keep all my 2000+ images in the same directory) and
46;; browsing the thumbnail buffer was slow too. image-dired.el will not
47;; create thumbnails until they are needed and the browsing is done
48;; quickly and easily in Dired. I copied a great deal of ideas and
49;; code from there though... :)
50;;
51;; `image-dired' stores the thumbnail files in `image-dired-dir'
52;; using the file name format ORIGNAME.thumb.ORIGEXT. For example
53;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for
54;; now just a plain text file with the following format:
55;;
56;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN
57;;
58;;
59;; PREREQUISITES
60;; =============
61;;
62;; * The GraphicsMagick or ImageMagick package; Image-Dired uses
63;; whichever is available.
64;;
65;; A) For GraphicsMagick, `gm' is used.
66;; Find it here: http://www.graphicsmagick.org/
67;;
68;; B) For ImageMagick, `convert' and `mogrify' are used.
69;; Find it here: https://www.imagemagick.org.
70;;
71;; * For non-lossy rotation of JPEG images, the JpegTRAN program is
72;; needed.
73;;
74;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is
75;; needed. It can be found here: https://exiftool.org/. This
76;; function is, among other things, used for writing comments to
77;; image files using `image-dired-thumbnail-set-image-description'.
78;;
79;;
80;; USAGE
81;; =====
82;;
83;; This information has been moved to the manual. Type `C-h r' to open
84;; the Emacs manual and go to the node Thumbnails by typing `g
85;; Image-Dired RET'.
86;;
87;; Quickstart: M-x image-dired RET DIRNAME RET
88;;
89;; where DIRNAME is a directory containing image files.
90;;
91;; LIMITATIONS
92;; ===========
93;;
94;; * Supports all image formats that Emacs and convert supports, but
95;; the thumbnails are hard-coded to JPEG or PNG format. It uses
96;; JPEG by default, but can optionally follow the Thumbnail Managing
97;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user
98;; option `image-dired-thumbnail-storage'.
99;;
100;; * WARNING: The "database" format used might be changed so keep a
101;; backup of `image-dired-db-file' when testing new versions.
102;;
103;; TODO
104;; ====
105;;
106;; * Investigate if it is possible to also write the tags to the image
107;; files.
108;;
109;; * From thumbs.el: Add an option for clean-up/max-size functionality
110;; for thumbnail directory.
111;;
112;; * From thumbs.el: Add setroot function.
113;;
114;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out
115;; which is best, saving old batch just before inserting new, or
116;; saving the current batch in the ring when inserting it. Adding
117;; it probably needs rewriting `image-dired-display-thumbs' to be more general.
118;;
119;; * Find some way of toggling on and off really nice keybindings in
120;; Dired (for example, using C-n or <down> instead of C-S-n).
121;; Richard suggested that we could keep C-t as prefix for
122;; image-dired commands as it is currently not used in Dired. He
123;; also suggested that `dired-next-line' and `dired-previous-line'
124;; figure out if image-dired is enabled in the current buffer and,
125;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line',
126;; respectively. Update: This is partly done; some bindings have
127;; now been added to Dired.
128;;
129;; * In some way keep track of buffers and windows and stuff so that
130;; it works as the user expects.
131;;
132;; * More/better documentation.
133
134;;; Code:
135
136(require 'dired)
137(require 'exif)
138(require 'image-mode)
139(require 'widget)
140(require 'xdg)
141
142(eval-when-compile
143 (require 'cl-lib)
144 (require 'wid-edit))
145
146
147;;; Customizable variables
148
149(defgroup image-dired nil
150 "Use Dired to browse your images as thumbnails, and more."
151 :prefix "image-dired-"
152 :link '(info-link "(emacs) Image-Dired")
153 :group 'multimedia)
154
155(defcustom image-dired-dir (locate-user-emacs-file "image-dired/")
156 "Directory where thumbnail images are stored.
157
158The value of this option will be ignored if Image-Dired is
159customized to use the Thumbnail Managing Standard; they will be
160saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See
161`image-dired-thumbnail-storage'."
162 :type 'directory)
163
164(defcustom image-dired-thumbnail-storage 'use-image-dired-dir
165 "How `image-dired' stores thumbnail files.
166There are two ways that Image-Dired can store and generate
167thumbnails. If you set this variable to one of the two following
168values, they will be stored in the JPEG format:
169
170- `use-image-dired-dir' means that the thumbnails are stored in a
171 central directory.
172
173- `per-directory' means that each thumbnail is stored in a
174 subdirectory called \".image-dired\" in the same directory
175 where the image file is.
176
177It can also use the \"Thumbnail Managing Standard\", which allows
178sharing of thumbnails across different programs. Thumbnails will
179be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in
180`image-dired-dir'. Thumbnails are saved in the PNG format, and
181can be one of the following sizes:
182
183- `standard' means use thumbnails sized 128x128.
184- `standard-large' means use thumbnails sized 256x256.
185- `standard-x-large' means use thumbnails sized 512x512.
186- `standard-xx-large' means use thumbnails sized 1024x1024.
187
188For more information on the Thumbnail Managing Standard, see:
189https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html"
190 :type '(choice :tag "How to store thumbnail files"
191 (const :tag "Use image-dired-dir" use-image-dired-dir)
192 (const :tag "Thumbnail Managing Standard (normal 128x128)"
193 standard)
194 (const :tag "Thumbnail Managing Standard (large 256x256)"
195 standard-large)
196 (const :tag "Thumbnail Managing Standard (larger 512x512)"
197 standard-x-large)
198 (const :tag "Thumbnail Managing Standard (extra large 1024x1024)"
199 standard-xx-large)
200 (const :tag "Per-directory" per-directory))
201 :version "29.1")
202
203(defconst image-dired--thumbnail-standard-sizes
204 '( standard standard-large
205 standard-x-large standard-xx-large)
206 "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
207
208(defcustom image-dired-db-file
209 (expand-file-name ".image-dired_db" image-dired-dir)
210 "Database file where file names and their associated tags are stored."
211 :type 'file)
212
213(defcustom image-dired-cmd-create-thumbnail-program
214 (if (executable-find "gm") "gm" "convert")
215 "Executable used to create thumbnail.
216Used together with `image-dired-cmd-create-thumbnail-options'."
217 :type 'file
218 :version "29.1")
219
220(defcustom image-dired-cmd-create-thumbnail-options
221 (let ((opts '("-size" "%wx%h" "%f[0]"
222 "-resize" "%wx%h>"
223 "-strip" "jpeg:%t")))
224 (if (executable-find "gm") (cons "convert" opts) opts))
225 "Options of command used to create thumbnail image.
226Used with `image-dired-cmd-create-thumbnail-program'.
227Available format specifiers are: %w which is replaced by
228`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
229%f which is replaced by the file name of the original image and %t
230which is replaced by the file name of the thumbnail file."
231 :version "29.1"
232 :type '(repeat (string :tag "Argument")))
233
234(defcustom image-dired-cmd-pngnq-program
235 ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
236 ;; The project also seems more active than the alternatives.
237 ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
238 ;; The pngnq project seems dead (?) since 2011 or so.
239 (or (executable-find "pngquant")
240 (executable-find "pngnq-s9")
241 (executable-find "pngnq"))
242 "The file name of the `pngquant' or `pngnq' program.
243It quantizes colors of PNG images down to 256 colors or fewer
244using the NeuQuant algorithm."
245 :version "29.1"
246 :type '(choice (const :tag "Not Set" nil) file))
247
248(defcustom image-dired-cmd-pngnq-options
249 (if (executable-find "pngquant")
250 '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
251 '("-f" "%t"))
252 "Arguments to pass `image-dired-cmd-pngnq-program'.
253Available format specifiers are the same as in
254`image-dired-cmd-create-thumbnail-options'."
255 :type '(repeat (string :tag "Argument"))
256 :version "29.1")
257
258(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
259 "The file name of the `pngcrush' program.
260It optimizes the compression of PNG images. Also it adds PNG textual chunks
261with the information required by the Thumbnail Managing Standard."
262 :type '(choice (const :tag "Not Set" nil) file))
263
264(defcustom image-dired-cmd-pngcrush-options
265 `("-q"
266 "-text" "b" "Description" "Thumbnail of file://%f"
267 "-text" "b" "Software" ,(emacs-version)
268 ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
269 ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
270 ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
271 "-text" "b" "Thumb::MTime" "%m"
272 ;; "-text b \"Thumb::Size\" \"%b\" "
273 "-text" "b" "Thumb::URI" "file://%f"
274 "%q" "%t")
275 "Arguments for `image-dired-cmd-pngcrush-program'.
276Available format specifiers are the same as in
277`image-dired-cmd-create-thumbnail-options', with %q for a
278temporary file name (typically generated by pnqnq)."
279 :version "26.1"
280 :type '(repeat (string :tag "Argument")))
281
282(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
283 "The file name of the `optipng' program."
284 :version "26.1"
285 :type '(choice (const :tag "Not Set" nil) file))
286
287(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
288 "Arguments passed to `image-dired-cmd-optipng-program'.
289Available format specifiers are described in
290`image-dired-cmd-create-thumbnail-options'."
291 :version "26.1"
292 :type '(repeat (string :tag "Argument"))
293 :link '(url-link "man:optipng(1)"))
294
295(defcustom image-dired-cmd-create-standard-thumbnail-options
296 (append '("-size" "%wx%h" "%f[0]")
297 (unless (or image-dired-cmd-pngcrush-program
298 image-dired-cmd-pngnq-program)
299 (list
300 "-set" "Thumb::MTime" "%m"
301 "-set" "Thumb::URI" "file://%f"
302 "-set" "Description" "Thumbnail of file://%f"
303 "-set" "Software" (emacs-version)))
304 '("-thumbnail" "%wx%h>" "png:%t"))
305 "Options for creating thumbnails according to the Thumbnail Managing Standard.
306Available format specifiers are the same as in
307`image-dired-cmd-create-thumbnail-options', with %m for file modification time."
308 :version "26.1"
309 :type '(repeat (string :tag "Argument")))
310
311(defcustom image-dired-cmd-rotate-original-program
312 "jpegtran"
313 "Executable used to rotate original image.
314Used together with `image-dired-cmd-rotate-original-options'."
315 :type 'file)
316
317(defcustom image-dired-cmd-rotate-original-options
318 '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
319 "Arguments of command used to rotate original image.
320Used with `image-dired-cmd-rotate-original-program'.
321Available format specifiers are: %d which is replaced by the
322number of (positive) degrees to rotate the image, normally 90 or
323270 \(for 90 degrees right and left), %o which is replaced by the
324original image file name and %t which is replaced by
325`image-dired-temp-image-file'."
326 :version "26.1"
327 :type '(repeat (string :tag "Argument")))
328
329(defcustom image-dired-temp-rotate-image-file
330 (expand-file-name ".image-dired_rotate_temp" image-dired-dir)
331 "Temporary file for rotate operations."
332 :type 'file)
333
334(defcustom image-dired-rotate-original-ask-before-overwrite t
335 "Confirm overwrite of original file after rotate operation.
336If non-nil, ask user for confirmation before overwriting the
337original file with `image-dired-temp-rotate-image-file'."
338 :type 'boolean)
339
340(defcustom image-dired-cmd-write-exif-data-program
341 "exiftool"
342 "Program used to write EXIF data to image.
343Used together with `image-dired-cmd-write-exif-data-options'."
344 :type 'file)
345
346(defcustom image-dired-cmd-write-exif-data-options
347 '("-%t=%v" "%f")
348 "Arguments of command used to write EXIF data.
349Used with `image-dired-cmd-write-exif-data-program'.
350Available format specifiers are: %f which is replaced by
351the image file name, %t which is replaced by the tag name and %v
352which is replaced by the tag value."
353 :version "26.1"
354 :type '(repeat (string :tag "Argument")))
355
356(defcustom image-dired-thumb-size
357 (cond
358 ((eq 'standard image-dired-thumbnail-storage) 128)
359 ((eq 'standard-large image-dired-thumbnail-storage) 256)
360 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
361 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
362 (t 100))
363 "Size of thumbnails, in pixels.
364This is the default size for both `image-dired-thumb-width'
365and `image-dired-thumb-height'.
366
367The value of this option will be ignored if Image-Dired is
368customized to use the Thumbnail Managing Standard; the standard
369sizes will be used instead. See `image-dired-thumbnail-storage'."
370 :type 'integer)
371
372(defcustom image-dired-thumb-width image-dired-thumb-size
373 "Width of thumbnails, in pixels."
374 :type 'integer)
375
376(defcustom image-dired-thumb-height image-dired-thumb-size
377 "Height of thumbnails, in pixels."
378 :type 'integer)
379
380(defcustom image-dired-thumb-relief 2
381 "Size of button-like border around thumbnails."
382 :type 'integer)
383
384(defcustom image-dired-thumb-margin 2
385 "Size of the margin around thumbnails.
386This is where you see the cursor."
387 :type 'integer)
388
389(defcustom image-dired-thumb-visible-marks t
390 "Make marks and flags visible in thumbnail buffer.
391If non-nil, apply the `image-dired-thumb-mark' face to marked
392images and `image-dired-thumb-flagged' to images flagged for
393deletion."
394 :type 'boolean
395 :version "28.1")
396
397(defface image-dired-thumb-mark
398 '((((class color) (min-colors 16)) :background "DarkOrange")
399 (((class color)) :foreground "yellow"))
400 "Face for marked images in thumbnail buffer."
401 :version "29.1")
402
403(defface image-dired-thumb-flagged
404 '((((class color) (min-colors 88) (background light)) :background "Red3")
405 (((class color) (min-colors 88) (background dark)) :background "Pink")
406 (((class color) (min-colors 16) (background light)) :background "Red3")
407 (((class color) (min-colors 16) (background dark)) :background "Pink")
408 (((class color) (min-colors 8)) :background "red")
409 (t :inverse-video t))
410 "Face for images flagged for deletion in thumbnail buffer."
411 :version "29.1")
412
413(defcustom image-dired-line-up-method 'dynamic
414 "Default method for line-up of thumbnails in thumbnail buffer.
415Used by `image-dired-display-thumbs' and other functions that needs
416to line-up thumbnails. Dynamic means to use the available width of
417the window containing the thumbnail buffer, Fixed means to use
418`image-dired-thumbs-per-row', Interactive is for asking the user,
419and No line-up means that no automatic line-up will be done."
420 :type '(choice :tag "Default line-up method"
421 (const :tag "Dynamic" dynamic)
422 (const :tag "Fixed" fixed)
423 (const :tag "Interactive" interactive)
424 (const :tag "No line-up" none)))
425
426(defcustom image-dired-thumbs-per-row 3
427 "Number of thumbnails to display per row in thumb buffer."
428 :type 'integer)
429
430(defcustom image-dired-track-movement t
431 "The current state of the tracking and mirroring.
432For more information, see the documentation for
433`image-dired-toggle-movement-tracking'."
434 :type 'boolean)
435
436(defcustom image-dired-append-when-browsing nil
437 "Append thumbnails in thumbnail buffer when browsing.
438If non-nil, using `image-dired-next-line-and-display' and
439`image-dired-previous-line-and-display' will leave a trail of thumbnail
440images in the thumbnail buffer. If you enable this and want to clean
441the thumbnail buffer because it is filled with too many thumbnails,
442just call `image-dired-display-thumb' to display only the image at point.
443This value can be toggled using `image-dired-toggle-append-browsing'."
444 :type 'boolean)
445
446(defcustom image-dired-dired-disp-props t
447 "If non-nil, display properties for Dired file when browsing.
448Used by `image-dired-next-line-and-display',
449`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'.
450If the database file is large, this can slow down image browsing in
451Dired and you might want to turn it off."
452 :type 'boolean)
453
454(defcustom image-dired-display-properties-format "%b: %f (%t): %c"
455 "Display format for thumbnail properties.
456%b is replaced with associated Dired buffer name, %f with file
457name (without path) of original image file, %t with the list of
458tags and %c with the comment."
459 :type 'string)
460
461(defcustom image-dired-external-viewer
462 ;; TODO: Use mailcap, dired-guess-shell-alist-default,
463 ;; dired-view-command-alist.
464 (cond ((executable-find "display"))
465 ((executable-find "xli"))
466 ((executable-find "qiv") "qiv -t")
467 ((executable-find "feh") "feh"))
468 "Name of external viewer.
469Including parameters. Used when displaying original image from
470`image-dired-thumbnail-mode'."
471 :version "28.1"
472 :type '(choice string
473 (const :tag "Not Set" nil)))
474
475(defcustom image-dired-main-image-directory
476 (or (xdg-user-dir "PICTURES") "~/pics/")
477 "Name of main image directory, if any.
478Used by `image-dired-copy-with-exif-file-name'."
479 :type 'string
480 :version "29.1")
481
482(defcustom image-dired-show-all-from-dir-max-files 500
483 "Maximum number of files in directory before prompting.
484
485If there are more image files than this in a selected directory,
486the `image-dired-show-all-from-dir' command will ask for
487confirmation before creating the thumbnail buffer. If this
488variable is nil, it will never ask."
489 :type '(choice integer
490 (const :tag "Disable warning" nil))
491 :version "29.1")
492
493(defcustom image-dired-marking-shows-next t
494 "If non-nil, marking, unmarking or flagging an image shows the next image.
495
496This affects the following commands:
497\\<image-dired-thumbnail-mode-map>
498 `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file])
499 `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file])
500 `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])"
501 :type 'boolean
502 :version "29.1")
503
504
505;;; Util functions
506
507(defvar image-dired-debug nil
508 "Non-nil means enable debug messages.")
509
510(defun image-dired-debug-message (&rest args)
511 "Display debug message ARGS when `image-dired-debug' is non-nil."
512 (when image-dired-debug
513 (apply #'message args)))
514
515(defmacro image-dired--with-db-file (&rest body)
516 "Run BODY in a temp buffer containing `image-dired-db-file'.
517Return the last form in BODY."
518 (declare (indent 0) (debug t))
519 `(with-temp-buffer
520 (if (file-exists-p image-dired-db-file)
521 (insert-file-contents image-dired-db-file))
522 ,@body))
523
524(defun image-dired-dir ()
525 "Return the current thumbnail directory (from variable `image-dired-dir').
526Create the thumbnail directory if it does not exist."
527 (let ((image-dired-dir (file-name-as-directory
528 (expand-file-name image-dired-dir))))
529 (unless (file-directory-p image-dired-dir)
530 (with-file-modes #o700
531 (make-directory image-dired-dir t))
532 (message "Thumbnail directory created: %s" image-dired-dir))
533 image-dired-dir))
534
535(defun image-dired-insert-image (file type relief margin)
536 "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point."
537 (let ((i `(image :type ,type
538 :file ,file
539 :relief ,relief
540 :margin ,margin)))
541 (insert-image i)))
542
543(defun image-dired-get-thumbnail-image (file)
544 "Return the image descriptor for a thumbnail of image file FILE."
545 (unless (string-match-p (image-file-name-regexp) file)
546 (error "%s is not a valid image file" file))
547 (let* ((thumb-file (image-dired-thumb-name file))
548 (thumb-attr (file-attributes thumb-file)))
549 (when (or (not thumb-attr)
550 (time-less-p (file-attribute-modification-time thumb-attr)
551 (file-attribute-modification-time
552 (file-attributes file))))
553 (image-dired-create-thumb file thumb-file))
554 (create-image thumb-file)))
555
556(defun image-dired-insert-thumbnail (file original-file-name
557 associated-dired-buffer)
558 "Insert thumbnail image FILE.
559Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
560 (let (beg end)
561 (setq beg (point))
562 (image-dired-insert-image
563 file
564 ;; Thumbnails are created asynchronously, so we might not yet
565 ;; have a file. But if it exists, it might have been cached from
566 ;; before and we should use it instead of our current settings.
567 (or (and (file-exists-p file)
568 (image-type-from-file-header file))
569 (and (memq image-dired-thumbnail-storage
570 image-dired--thumbnail-standard-sizes)
571 'png)
572 'jpeg)
573 image-dired-thumb-relief
574 image-dired-thumb-margin)
575 (setq end (point))
576 (add-text-properties
577 beg end
578 (list 'image-dired-thumbnail t
579 'original-file-name original-file-name
580 'associated-dired-buffer associated-dired-buffer
581 'tags (image-dired-list-tags original-file-name)
582 'mouse-face 'highlight
583 'comment (image-dired-get-comment original-file-name)))))
584
585(defun image-dired-thumb-name (file)
586 "Return absolute file name for thumbnail FILE.
587Depending on the value of `image-dired-thumbnail-storage', the
588file name of the thumbnail will vary:
589- For `use-image-dired-dir', make a SHA1-hash of the image file's
590 directory name and add that to make the thumbnail file name
591 unique.
592- For `per-directory' storage, just add a subdirectory.
593- For `standard' storage, produce the file name according to the
594 Thumbnail Managing Standard. Among other things, an MD5-hash
595 of the image file's directory name will be added to the
596 filename.
597See also `image-dired-thumbnail-storage'."
598 (cond ((memq image-dired-thumbnail-storage
599 image-dired--thumbnail-standard-sizes)
600 (let ((thumbdir (cl-case image-dired-thumbnail-storage
601 (standard "thumbnails/normal")
602 (standard-large "thumbnails/large")
603 (standard-x-large "thumbnails/x-large")
604 (standard-xx-large "thumbnails/xx-large"))))
605 (expand-file-name
606 ;; MD5 is mandated by the Thumbnail Managing Standard.
607 (concat (md5 (concat "file://" (expand-file-name file))) ".png")
608 (expand-file-name thumbdir (xdg-cache-home)))))
609 ((eq 'use-image-dired-dir image-dired-thumbnail-storage)
610 (let* ((f (expand-file-name file))
611 (hash
612 (md5 (file-name-as-directory (file-name-directory f)))))
613 (format "%s%s%s.thumb.%s"
614 (file-name-as-directory (expand-file-name (image-dired-dir)))
615 (file-name-base f)
616 (if hash (concat "_" hash) "")
617 (file-name-extension f))))
618 ((eq 'per-directory image-dired-thumbnail-storage)
619 (let ((f (expand-file-name file)))
620 (format "%s.image-dired/%s.thumb.%s"
621 (file-name-directory f)
622 (file-name-base f)
623 (file-name-extension f))))))
624
625(defun image-dired--check-executable-exists (executable)
626 (unless (executable-find (symbol-value executable))
627 (error "Executable %S not found" executable)))
628
629
630;;; Creating thumbnails
631
632(defun image-dired-thumb-size (dimension)
633 "Return thumb size depending on `image-dired-thumbnail-storage'.
634DIMENSION should be either the symbol `width' or `height'."
635 (cond
636 ((eq 'standard image-dired-thumbnail-storage) 128)
637 ((eq 'standard-large image-dired-thumbnail-storage) 256)
638 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
639 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
640 (t (cl-ecase dimension
641 (width image-dired-thumb-width)
642 (height image-dired-thumb-height)))))
643
644(defvar image-dired--generate-thumbs-start nil
645 "Time when `display-thumbs' was called.")
646
647(defvar image-dired-queue nil
648 "List of items in the queue.
649Each item has the form (ORIGINAL-FILE TARGET-FILE).")
650
651(defvar image-dired-queue-active-jobs 0
652 "Number of active jobs in `image-dired-queue'.")
653
654(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
655 "Maximum number of concurrent jobs permitted for generating images.
656Increase at own risk. If you want to experiment with this,
657consider setting `image-dired-debug' to a non-nil value to see
658the time spent on generating thumbnails. Run `image-clear-cache'
659and remove the cached thumbnail files between each trial run.")
660
661(defun image-dired-pngnq-thumb (spec)
662 "Quantize thumbnail described by format SPEC with pngnq(1)."
663 (let ((process
664 (apply #'start-process "image-dired-pngnq" nil
665 image-dired-cmd-pngnq-program
666 (mapcar (lambda (arg) (format-spec arg spec))
667 image-dired-cmd-pngnq-options))))
668 (setf (process-sentinel process)
669 (lambda (process status)
670 (if (and (eq (process-status process) 'exit)
671 (zerop (process-exit-status process)))
672 ;; Pass off to pngcrush, or just rename the
673 ;; THUMB-nq8.png file back to THUMB.png
674 (if (and image-dired-cmd-pngcrush-program
675 (executable-find image-dired-cmd-pngcrush-program))
676 (image-dired-pngcrush-thumb spec)
677 (let ((nq8 (cdr (assq ?q spec)))
678 (thumb (cdr (assq ?t spec))))
679 (rename-file nq8 thumb t)))
680 (message "command %S %s" (process-command process)
681 (string-replace "\n" "" status)))))
682 process))
683
684(defun image-dired-pngcrush-thumb (spec)
685 "Optimize thumbnail described by format SPEC with pngcrush(1)."
686 ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
687 ;; pngcrush needs an infile and outfile, so we just copy THUMB to
688 ;; THUMB-nq8.png and use the latter as a temp file.
689 (when (not image-dired-cmd-pngnq-program)
690 (let ((temp (cdr (assq ?q spec)))
691 (thumb (cdr (assq ?t spec))))
692 (copy-file thumb temp)))
693 (let ((process
694 (apply #'start-process "image-dired-pngcrush" nil
695 image-dired-cmd-pngcrush-program
696 (mapcar (lambda (arg) (format-spec arg spec))
697 image-dired-cmd-pngcrush-options))))
698 (setf (process-sentinel process)
699 (lambda (process status)
700 (unless (and (eq (process-status process) 'exit)
701 (zerop (process-exit-status process)))
702 (message "command %S %s" (process-command process)
703 (string-replace "\n" "" status)))
704 (when (memq (process-status process) '(exit signal))
705 (let ((temp (cdr (assq ?q spec))))
706 (delete-file temp)))))
707 process))
708
709(defun image-dired-optipng-thumb (spec)
710 "Optimize thumbnail described by format SPEC with optipng(1)."
711 (let ((process
712 (apply #'start-process "image-dired-optipng" nil
713 image-dired-cmd-optipng-program
714 (mapcar (lambda (arg) (format-spec arg spec))
715 image-dired-cmd-optipng-options))))
716 (setf (process-sentinel process)
717 (lambda (process status)
718 (unless (and (eq (process-status process) 'exit)
719 (zerop (process-exit-status process)))
720 (message "command %S %s" (process-command process)
721 (string-replace "\n" "" status)))))
722 process))
723
724(defun image-dired-create-thumb-1 (original-file thumbnail-file)
725 "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
726 (image-dired--check-executable-exists
727 'image-dired-cmd-create-thumbnail-program)
728 (let* ((width (int-to-string (image-dired-thumb-size 'width)))
729 (height (int-to-string (image-dired-thumb-size 'height)))
730 (modif-time (format-time-string
731 "%s" (file-attribute-modification-time
732 (file-attributes original-file))))
733 (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
734 thumbnail-file))
735 (spec
736 (list
737 (cons ?w width)
738 (cons ?h height)
739 (cons ?m modif-time)
740 (cons ?f original-file)
741 (cons ?q thumbnail-nq8-file)
742 (cons ?t thumbnail-file)))
743 (thumbnail-dir (file-name-directory thumbnail-file))
744 process)
745 (when (not (file-exists-p thumbnail-dir))
746 (with-file-modes #o700
747 (make-directory thumbnail-dir t))
748 (message "Thumbnail directory created: %s" thumbnail-dir))
749
750 ;; Thumbnail file creation processes begin here and are marshaled
751 ;; in a queue by `image-dired-create-thumb'.
752 (setq process
753 (apply #'start-process "image-dired-create-thumbnail" nil
754 image-dired-cmd-create-thumbnail-program
755 (mapcar
756 (lambda (arg) (format-spec arg spec))
757 (if (memq image-dired-thumbnail-storage
758 image-dired--thumbnail-standard-sizes)
759 image-dired-cmd-create-standard-thumbnail-options
760 image-dired-cmd-create-thumbnail-options))))
761
762 (setf (process-sentinel process)
763 (lambda (process status)
764 ;; Trigger next in queue once a thumbnail has been created
765 (cl-decf image-dired-queue-active-jobs)
766 (image-dired-thumb-queue-run)
767 (when (= image-dired-queue-active-jobs 0)
768 (image-dired-debug-message
769 (format-time-string
770 "Generated thumbnails in %s.%3N seconds"
771 (time-subtract nil
772 image-dired--generate-thumbs-start))))
773 (if (not (and (eq (process-status process) 'exit)
774 (zerop (process-exit-status process))))
775 (message "Thumb could not be created for %s: %s"
776 (abbreviate-file-name original-file)
777 (string-replace "\n" "" status))
778 (set-file-modes thumbnail-file #o600)
779 (clear-image-cache thumbnail-file)
780 ;; PNG thumbnail has been created since we are
781 ;; following the XDG thumbnail spec, so try to optimize
782 (when (memq image-dired-thumbnail-storage
783 image-dired--thumbnail-standard-sizes)
784 (cond
785 ((and image-dired-cmd-pngnq-program
786 (executable-find image-dired-cmd-pngnq-program))
787 (image-dired-pngnq-thumb spec))
788 ((and image-dired-cmd-pngcrush-program
789 (executable-find image-dired-cmd-pngcrush-program))
790 (image-dired-pngcrush-thumb spec))
791 ((and image-dired-cmd-optipng-program
792 (executable-find image-dired-cmd-optipng-program))
793 (image-dired-optipng-thumb spec)))))))
794 process))
795
796(defun image-dired-thumb-queue-run ()
797 "Run a queued job if one exists and not too many jobs are running.
798Queued items live in `image-dired-queue'."
799 (while (and image-dired-queue
800 (< image-dired-queue-active-jobs
801 image-dired-queue-active-limit))
802 (cl-incf image-dired-queue-active-jobs)
803 (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
804
805(defun image-dired-create-thumb (original-file thumbnail-file)
806 "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'.
807The new file will be named THUMBNAIL-FILE."
808 (setq image-dired-queue
809 (nconc image-dired-queue
810 (list (list original-file thumbnail-file))))
811 (run-at-time 0 nil #'image-dired-thumb-queue-run))
812
813(defmacro image-dired--with-marked (&rest body)
814 "Eval BODY with point on each marked thumbnail.
815If no marked file could be found, execute BODY on the current
816thumbnail."
817 `(with-current-buffer image-dired-thumbnail-buffer
818 (let (found)
819 (save-mark-and-excursion
820 (goto-char (point-min))
821 (while (not (eobp))
822 (when (image-dired-thumb-file-marked-p)
823 (setq found t)
824 ,@body)
825 (forward-char)))
826 (unless found
827 ,@body))))
828
829;;;###autoload
830(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
831 "Toggle thumbnails in front of file names in the Dired buffer.
832If no marked file could be found, insert or hide thumbnails on the
833current line. ARG, if non-nil, specifies the files to use instead
834of the marked files. If ARG is an integer, use the next ARG (or
835previous -ARG, if ARG<0) files."
836 (interactive "P")
837 (dired-map-over-marks
838 (let ((image-pos (dired-move-to-filename))
839 (image-file (dired-get-filename nil t))
840 thumb-file
841 overlay)
842 (when (and image-file
843 (string-match-p (image-file-name-regexp) image-file))
844 (setq thumb-file (image-dired-get-thumbnail-image image-file))
845 ;; If image is not already added, then add it.
846 (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
847 if (overlay-get ov 'thumb-file) return ov)))
848 (if thumb-ov
849 (delete-overlay thumb-ov)
850 (put-image thumb-file image-pos)
851 (setq overlay
852 (cl-loop for ov in (overlays-in (point) (1+ (point)))
853 if (overlay-get ov 'put-image) return ov))
854 (overlay-put overlay 'image-file image-file)
855 (overlay-put overlay 'thumb-file thumb-file)))))
856 arg ; Show or hide image on ARG next files.
857 'show-progress) ; Update dired display after each image is updated.
858 (add-hook 'dired-after-readin-hook
859 'image-dired-dired-after-readin-hook nil t))
860
861(defun image-dired-dired-after-readin-hook ()
862 "Relocate existing thumbnail overlays in Dired buffer after reverting.
863Move them to their corresponding files if they still exist.
864Otherwise, delete overlays."
865 (mapc (lambda (overlay)
866 (when (overlay-get overlay 'put-image)
867 (let* ((image-file (overlay-get overlay 'image-file))
868 (image-pos (dired-goto-file image-file)))
869 (if image-pos
870 (move-overlay overlay image-pos image-pos)
871 (delete-overlay overlay)))))
872 (overlays-in (point-min) (point-max))))
873
874(defun image-dired-next-line-and-display ()
875 "Move to next Dired line and display thumbnail image."
876 (interactive)
877 (dired-next-line 1)
878 (image-dired-display-thumbs
879 t (or image-dired-append-when-browsing nil) t)
880 (if image-dired-dired-disp-props
881 (image-dired-dired-display-properties)))
882
883(defun image-dired-previous-line-and-display ()
884 "Move to previous Dired line and display thumbnail image."
885 (interactive)
886 (dired-previous-line 1)
887 (image-dired-display-thumbs
888 t (or image-dired-append-when-browsing nil) t)
889 (if image-dired-dired-disp-props
890 (image-dired-dired-display-properties)))
891
892(defun image-dired-toggle-append-browsing ()
893 "Toggle `image-dired-append-when-browsing'."
894 (interactive)
895 (setq image-dired-append-when-browsing
896 (not image-dired-append-when-browsing))
897 (message "Append browsing %s"
898 (if image-dired-append-when-browsing
899 "on"
900 "off")))
901
902(defun image-dired-mark-and-display-next ()
903 "Mark current file in Dired and display next thumbnail image."
904 (interactive)
905 (dired-mark 1)
906 (image-dired-display-thumbs
907 t (or image-dired-append-when-browsing nil) t)
908 (if image-dired-dired-disp-props
909 (image-dired-dired-display-properties)))
910
911(defun image-dired-toggle-dired-display-properties ()
912 "Toggle `image-dired-dired-disp-props'."
913 (interactive)
914 (setq image-dired-dired-disp-props
915 (not image-dired-dired-disp-props))
916 (message "Dired display properties %s"
917 (if image-dired-dired-disp-props
918 "on"
919 "off")))
920
921(defvar image-dired-thumbnail-buffer "*image-dired*"
922 "Image-Dired's thumbnail buffer.")
923
924(defun image-dired-create-thumbnail-buffer ()
925 "Create thumb buffer and set `image-dired-thumbnail-mode'."
926 (let ((buf (get-buffer-create image-dired-thumbnail-buffer)))
927 (with-current-buffer buf
928 (setq buffer-read-only t)
929 (if (not (eq major-mode 'image-dired-thumbnail-mode))
930 (image-dired-thumbnail-mode)))
931 buf))
932
933(defvar image-dired-display-image-buffer "*image-dired-display-image*"
934 "Where larger versions of the images are display.")
935
936(defvar image-dired-saved-window-configuration nil
937 "Saved window configuration.")
938
939;;;###autoload
940(defun image-dired-dired-with-window-configuration (dir &optional arg)
941 "Open directory DIR and create a default window configuration.
942
943Convenience command that:
944
945 - Opens Dired in folder DIR
946 - Splits windows in most useful (?) way
947 - Sets `truncate-lines' to t
948
949After the command has finished, you would typically mark some
950image files in Dired and type
951\\[image-dired-display-thumbs] (`image-dired-display-thumbs').
952
953If called with prefix argument ARG, skip splitting of windows.
954
955The current window configuration is saved and can be restored by
956calling `image-dired-restore-window-configuration'."
957 (interactive "DDirectory: \nP")
958 (let ((buf (image-dired-create-thumbnail-buffer))
959 (buf2 (get-buffer-create image-dired-display-image-buffer)))
960 (setq image-dired-saved-window-configuration
961 (current-window-configuration))
962 (dired dir)
963 (delete-other-windows)
964 (when (not arg)
965 (split-window-right)
966 (setq truncate-lines t)
967 (save-excursion
968 (other-window 1)
969 (pop-to-buffer-same-window buf)
970 (select-window (split-window-below))
971 (pop-to-buffer-same-window buf2)
972 (other-window -2)))))
973
974(defun image-dired-restore-window-configuration ()
975 "Restore window configuration.
976Restore any changes to the window configuration made by calling
977`image-dired-dired-with-window-configuration'."
978 (interactive nil image-dired-thumbnail-mode)
979 (if image-dired-saved-window-configuration
980 (set-window-configuration image-dired-saved-window-configuration)
981 (message "No saved window configuration")))
982
983(defun image-dired--line-up-with-method ()
984 "Line up thumbnails according to `image-dired-line-up-method'."
985 (cond ((eq 'dynamic image-dired-line-up-method)
986 (image-dired-line-up-dynamic))
987 ((eq 'fixed image-dired-line-up-method)
988 (image-dired-line-up))
989 ((eq 'interactive image-dired-line-up-method)
990 (image-dired-line-up-interactive))
991 ((eq 'none image-dired-line-up-method)
992 nil)
993 (t
994 (image-dired-line-up-dynamic))))
995
996;;;###autoload
997(defun image-dired-display-thumbs (&optional arg append do-not-pop)
998 "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'.
999If a thumbnail image does not exist for a file, it is created on the
1000fly. With prefix argument ARG, display only thumbnail for file at
1001point (this is useful if you have marked some files but want to show
1002another one).
1003
1004Recommended usage is to split the current frame horizontally so that
1005you have the Dired buffer in the left window and the
1006`image-dired-thumbnail-buffer' buffer in the right window.
1007
1008With optional argument APPEND, append thumbnail to thumbnail buffer
1009instead of erasing it first.
1010
1011Optional argument DO-NOT-POP controls if `pop-to-buffer' should be
1012used or not. If non-nil, use `display-buffer' instead of
1013`pop-to-buffer'. This is used from functions like
1014`image-dired-next-line-and-display' and
1015`image-dired-previous-line-and-display' where we do not want the
1016thumbnail buffer to be selected."
1017 (interactive "P")
1018 (setq image-dired--generate-thumbs-start (current-time))
1019 (let ((buf (image-dired-create-thumbnail-buffer))
1020 thumb-name files dired-buf)
1021 (if arg
1022 (setq files (list (dired-get-filename)))
1023 (setq files (dired-get-marked-files)))
1024 (setq dired-buf (current-buffer))
1025 (with-current-buffer buf
1026 (let ((inhibit-read-only t))
1027 (if (not append)
1028 (erase-buffer)
1029 (goto-char (point-max)))
1030 (dolist (curr-file files)
1031 (setq thumb-name (image-dired-thumb-name curr-file))
1032 (when (not (file-exists-p thumb-name))
1033 (image-dired-create-thumb curr-file thumb-name))
1034 (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
1035 (if do-not-pop
1036 (display-buffer buf)
1037 (pop-to-buffer buf))
1038 (image-dired--line-up-with-method))))
1039
1040;;;###autoload
1041(defun image-dired-show-all-from-dir (dir)
1042 "Make a thumbnail buffer for all images in DIR and display it.
1043Any file matching `image-file-name-regexp' is considered an image
1044file.
1045
1046If the number of image files in DIR exceeds
1047`image-dired-show-all-from-dir-max-files', ask for confirmation
1048before creating the thumbnail buffer. If that variable is nil,
1049never ask for confirmation."
1050 (interactive "DImage-Dired: ")
1051 (dired dir)
1052 (dired-mark-files-regexp (image-file-name-regexp))
1053 (let ((files (dired-get-marked-files nil nil nil t)))
1054 (cond ((and (null (cdr files)))
1055 (message "No image files in directory"))
1056 ((or (not image-dired-show-all-from-dir-max-files)
1057 (<= (length (cdr files)) image-dired-show-all-from-dir-max-files)
1058 (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files)
1059 (y-or-n-p
1060 (format
1061 "Directory contains more than %d image files. Proceed?"
1062 image-dired-show-all-from-dir-max-files))))
1063 (image-dired-display-thumbs)
1064 (pop-to-buffer image-dired-thumbnail-buffer)
1065 (setq default-directory dir)
1066 (image-dired-unmark-all-marks))
1067 (t (message "Image-Dired canceled")))))
1068
1069;;;###autoload
1070(defalias 'image-dired 'image-dired-show-all-from-dir)
1071
1072
1073;;; Tags
1074
1075(defun image-dired-sane-db-file ()
1076 "Check if `image-dired-db-file' exists.
1077If not, try to create it (including any parent directories).
1078Signal error if there are problems creating it."
1079 (or (file-exists-p image-dired-db-file)
1080 (let (dir buf)
1081 (unless (file-directory-p (setq dir (file-name-directory
1082 image-dired-db-file)))
1083 (with-file-modes #o700
1084 (make-directory dir t)))
1085 (with-current-buffer (setq buf (create-file-buffer
1086 image-dired-db-file))
1087 (with-file-modes #o600
1088 (write-file image-dired-db-file)))
1089 (kill-buffer buf)
1090 (file-exists-p image-dired-db-file))
1091 (error "Could not create %s" image-dired-db-file)))
1092
1093(defvar image-dired-tag-history nil "Variable holding the tag history.")
1094
1095(defun image-dired-write-tags (file-tags)
1096 "Write file tags to database.
1097Write each file and tag in FILE-TAGS to the database.
1098FILE-TAGS is an alist in the following form:
1099 ((FILE . TAG) ... )"
1100 (image-dired-sane-db-file)
1101 (let (end file tag)
1102 (image-dired--with-db-file
1103 (setq buffer-file-name image-dired-db-file)
1104 (dolist (elt file-tags)
1105 (setq file (car elt)
1106 tag (cdr elt))
1107 (goto-char (point-min))
1108 (if (search-forward-regexp (format "^%s.*$" file) nil t)
1109 (progn
1110 (setq end (point))
1111 (beginning-of-line)
1112 (when (not (search-forward (format ";%s" tag) end t))
1113 (end-of-line)
1114 (insert (format ";%s" tag))))
1115 (goto-char (point-max))
1116 (insert (format "%s;%s\n" file tag))))
1117 (save-buffer))))
1118
1119(defun image-dired-remove-tag (files tag)
1120 "For all FILES, remove TAG from the image database."
1121 (image-dired-sane-db-file)
1122 (image-dired--with-db-file
1123 (setq buffer-file-name image-dired-db-file)
1124 (let (end)
1125 (unless (listp files)
1126 (if (stringp files)
1127 (setq files (list files))
1128 (error "Files must be a string or a list of strings!")))
1129 (dolist (file files)
1130 (goto-char (point-min))
1131 (when (search-forward-regexp (format "^%s;" file) nil t)
1132 (end-of-line)
1133 (setq end (point))
1134 (beginning-of-line)
1135 (when (search-forward-regexp
1136 (format "\\(;%s\\)\\($\\|;\\)" tag) end t)
1137 (delete-region (match-beginning 1) (match-end 1))
1138 ;; Check if file should still be in the database. If
1139 ;; it has no tags or comments, it will be removed.
1140 (end-of-line)
1141 (setq end (point))
1142 (beginning-of-line)
1143 (when (not (search-forward ";" end t))
1144 (kill-line 1))))))
1145 (save-buffer)))
1146
1147(defun image-dired-list-tags (file)
1148 "Read all tags for image FILE from the image database."
1149 (image-dired-sane-db-file)
1150 (image-dired--with-db-file
1151 (let (end (tags ""))
1152 (when (search-forward-regexp (format "^%s" file) nil t)
1153 (end-of-line)
1154 (setq end (point))
1155 (beginning-of-line)
1156 (if (search-forward ";" end t)
1157 (if (search-forward "comment:" end t)
1158 (if (search-forward ";" end t)
1159 (setq tags (buffer-substring (point) end)))
1160 (setq tags (buffer-substring (point) end)))))
1161 (split-string tags ";"))))
1162
1163;;;###autoload
1164(defun image-dired-tag-files (arg)
1165 "Tag marked file(s) in Dired. With prefix ARG, tag file at point."
1166 (interactive "P")
1167 (let ((tag (completing-read
1168 "Tags to add (separate tags with a semicolon): "
1169 image-dired-tag-history nil nil nil 'image-dired-tag-history))
1170 files)
1171 (if arg
1172 (setq files (list (dired-get-filename)))
1173 (setq files (dired-get-marked-files)))
1174 (image-dired-write-tags
1175 (mapcar
1176 (lambda (x)
1177 (cons x tag))
1178 files))))
1179
1180(defun image-dired-tag-thumbnail ()
1181 "Tag current or marked thumbnails."
1182 (interactive)
1183 (let ((tag (completing-read
1184 "Tags to add (separate tags with a semicolon): "
1185 image-dired-tag-history nil nil nil 'image-dired-tag-history)))
1186 (image-dired--with-marked
1187 (image-dired-write-tags
1188 (list (cons (image-dired-original-file-name) tag)))
1189 (image-dired-update-property
1190 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1191
1192;;;###autoload
1193(defun image-dired-delete-tag (arg)
1194 "Remove tag for selected file(s).
1195With prefix argument ARG, remove tag from file at point."
1196 (interactive "P")
1197 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1198 nil nil nil 'image-dired-tag-history))
1199 files)
1200 (if arg
1201 (setq files (list (dired-get-filename)))
1202 (setq files (dired-get-marked-files)))
1203 (image-dired-remove-tag files tag)))
1204
1205(defun image-dired-tag-thumbnail-remove ()
1206 "Remove tag from current or marked thumbnails."
1207 (interactive)
1208 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1209 nil nil nil 'image-dired-tag-history)))
1210 (image-dired--with-marked
1211 (image-dired-remove-tag (image-dired-original-file-name) tag)
1212 (image-dired-update-property
1213 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1214
1215
1216;;; Thumbnail mode (cont.)
1217
1218(defun image-dired-original-file-name ()
1219 "Get original file name for thumbnail or display image at point."
1220 (get-text-property (point) 'original-file-name))
1221
1222(defun image-dired-file-name-at-point ()
1223 "Get abbreviated file name for thumbnail or display image at point."
1224 (let ((f (image-dired-original-file-name)))
1225 (when f
1226 (abbreviate-file-name f))))
1227
1228(defun image-dired-associated-dired-buffer ()
1229 "Get associated Dired buffer at point."
1230 (get-text-property (point) 'associated-dired-buffer))
1231
1232(defun image-dired-get-buffer-window (buf)
1233 "Return window where buffer BUF is."
1234 (get-window-with-predicate
1235 (lambda (window)
1236 (equal (window-buffer window) buf))
1237 nil t))
1238
1239(defun image-dired-track-original-file ()
1240 "Track the original file in the associated Dired buffer.
1241See documentation for `image-dired-toggle-movement-tracking'.
1242Interactive use only useful if `image-dired-track-movement' is nil."
1243 (interactive)
1244 (let* ((dired-buf (image-dired-associated-dired-buffer))
1245 (file-name (image-dired-original-file-name))
1246 (window (image-dired-get-buffer-window dired-buf)))
1247 (and (buffer-live-p dired-buf) file-name
1248 (with-current-buffer dired-buf
1249 (if (not (dired-goto-file file-name))
1250 (message "Could not track file")
1251 (if window (set-window-point window (point))))))))
1252
1253(defun image-dired-toggle-movement-tracking ()
1254 "Turn on and off `image-dired-track-movement'.
1255Tracking of the movements between thumbnail and Dired buffer so that
1256they are \"mirrored\" in the dired buffer. When this is on, moving
1257around in the thumbnail or dired buffer will find the matching
1258position in the other buffer."
1259 (interactive)
1260 (setq image-dired-track-movement (not image-dired-track-movement))
1261 (message "Movement tracking %s" (if image-dired-track-movement "on" "off")))
1262
1263(defun image-dired-track-thumbnail ()
1264 "Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
1265This is almost the same as what `image-dired-track-original-file' does,
1266but the other way around."
1267 (let ((file (dired-get-filename))
1268 prop-val found window)
1269 (when (get-buffer image-dired-thumbnail-buffer)
1270 (with-current-buffer image-dired-thumbnail-buffer
1271 (goto-char (point-min))
1272 (while (and (not (eobp))
1273 (not found))
1274 (if (and (setq prop-val
1275 (get-text-property (point) 'original-file-name))
1276 (string= prop-val file))
1277 (setq found t))
1278 (if (not found)
1279 (forward-char 1)))
1280 (when found
1281 (if (setq window (image-dired-thumbnail-window))
1282 (set-window-point window (point)))
1283 (image-dired-update-header-line))))))
1284
1285(defun image-dired-dired-next-line (&optional arg)
1286 "Call `dired-next-line', then track thumbnail.
1287This can safely replace `dired-next-line'.
1288With prefix argument, move ARG lines."
1289 (interactive "P")
1290 (dired-next-line (or arg 1))
1291 (if image-dired-track-movement
1292 (image-dired-track-thumbnail)))
1293
1294(defun image-dired-dired-previous-line (&optional arg)
1295 "Call `dired-previous-line', then track thumbnail.
1296This can safely replace `dired-previous-line'.
1297With prefix argument, move ARG lines."
1298 (interactive "P")
1299 (dired-previous-line (or arg 1))
1300 (if image-dired-track-movement
1301 (image-dired-track-thumbnail)))
1302
1303(defun image-dired--display-thumb-properties-fun ()
1304 (let ((old-buf (current-buffer))
1305 (old-point (point)))
1306 (lambda ()
1307 (when (and (equal (current-buffer) old-buf)
1308 (= (point) old-point))
1309 (ignore-errors
1310 (image-dired-update-header-line))))))
1311
1312(defun image-dired-forward-image (&optional arg wrap-around)
1313 "Move to next image and display properties.
1314Optional prefix ARG says how many images to move; the default is
1315one image. Negative means move backwards.
1316On reaching end or beginning of buffer, stop and show a message.
1317
1318If optional argument WRAP-AROUND is non-nil, wrap around: if
1319point is on the last image, move to the last one and vice versa."
1320 (interactive "p")
1321 (setq arg (or arg 1))
1322 (let (pos)
1323 (dotimes (_ (abs arg))
1324 (if (and (not (if (> arg 0) (eobp) (bobp)))
1325 (save-excursion
1326 (forward-char (if (> arg 0) 1 -1))
1327 (while (and (not (if (> arg 0) (eobp) (bobp)))
1328 (not (image-dired-image-at-point-p)))
1329 (forward-char (if (> arg 0) 1 -1)))
1330 (setq pos (point))
1331 (image-dired-image-at-point-p)))
1332 (progn (goto-char pos)
1333 (image-dired-update-header-line))
1334 (if wrap-around
1335 (progn (goto-char (if (> arg 0)
1336 (point-min)
1337 ;; There are two spaces after the last image.
1338 (- (point-max) 2)))
1339 (image-dired-update-header-line))
1340 (message "At %s image" (if (> arg 0) "last" "first"))
1341 (run-at-time 1 nil (image-dired--display-thumb-properties-fun))))))
1342 (when image-dired-track-movement
1343 (image-dired-track-original-file)))
1344
1345(defun image-dired-backward-image (&optional arg)
1346 "Move to previous image and display properties.
1347Optional prefix ARG says how many images to move; the default is
1348one image. Negative means move forward.
1349On reaching end or beginning of buffer, stop and show a message."
1350 (interactive "p")
1351 (image-dired-forward-image (- (or arg 1))))
1352
1353(defun image-dired-next-line ()
1354 "Move to next line and display properties."
1355 (interactive nil image-dired-thumbnail-mode)
1356 (let ((goal-column (current-column)))
1357 (forward-line 1)
1358 (move-to-column goal-column))
1359 ;; If we end up in an empty spot, back up to the next thumbnail.
1360 (if (not (image-dired-image-at-point-p))
1361 (image-dired-backward-image))
1362 (if image-dired-track-movement
1363 (image-dired-track-original-file))
1364 (image-dired-update-header-line))
1365
1366
1367(defun image-dired-previous-line ()
1368 "Move to previous line and display properties."
1369 (interactive nil image-dired-thumbnail-mode)
1370 (let ((goal-column (current-column)))
1371 (forward-line -1)
1372 (move-to-column goal-column))
1373 ;; If we end up in an empty spot, back up to the next
1374 ;; thumbnail. This should only happen if the user deleted a
1375 ;; thumbnail and did not refresh, so it is not very common. But we
1376 ;; can handle it in a good manner, so why not?
1377 (if (not (image-dired-image-at-point-p))
1378 (image-dired-backward-image))
1379 (if image-dired-track-movement
1380 (image-dired-track-original-file))
1381 (image-dired-update-header-line))
1382
1383(defun image-dired-beginning-of-buffer ()
1384 "Move to the first image in the buffer and display properties."
1385 (interactive nil image-dired-thumbnail-mode)
1386 (goto-char (point-min))
1387 (while (and (not (image-at-point-p))
1388 (not (eobp)))
1389 (forward-char 1))
1390 (when image-dired-track-movement
1391 (image-dired-track-original-file))
1392 (image-dired-update-header-line))
1393
1394(defun image-dired-end-of-buffer ()
1395 "Move to the last image in the buffer and display properties."
1396 (interactive nil image-dired-thumbnail-mode)
1397 (goto-char (point-max))
1398 (while (and (not (image-at-point-p))
1399 (not (bobp)))
1400 (forward-char -1))
1401 (when image-dired-track-movement
1402 (image-dired-track-original-file))
1403 (image-dired-update-header-line))
1404
1405(defun image-dired-format-properties-string (buf file props comment)
1406 "Format display properties.
1407BUF is the associated Dired buffer, FILE is the original image file
1408name, PROPS is a stringified list of tags and COMMENT is the image file's
1409comment."
1410 (format-spec
1411 image-dired-display-properties-format
1412 (list
1413 (cons ?b (or buf ""))
1414 (cons ?f file)
1415 (cons ?t (or props ""))
1416 (cons ?c (or comment "")))))
1417
1418(defun image-dired-update-header-line ()
1419 "Update image information in the header line."
1420 (when (and (not (eobp))
1421 (memq major-mode '(image-dired-thumbnail-mode
1422 image-dired-display-image-mode)))
1423 (let ((file-name (file-name-nondirectory (image-dired-original-file-name)))
1424 (dired-buf (buffer-name (image-dired-associated-dired-buffer)))
1425 (props (mapconcat #'identity (get-text-property (point) 'tags) ", "))
1426 (comment (get-text-property (point) 'comment))
1427 (message-log-max nil))
1428 (if file-name
1429 (setq header-line-format
1430 (image-dired-format-properties-string
1431 dired-buf
1432 file-name
1433 props
1434 comment))))))
1435
1436(defun image-dired-dired-file-marked-p (&optional marker)
1437 "In Dired, return t if file on current line is marked.
1438If optional argument MARKER is non-nil, it is a character to look
1439for. The default is to look for `dired-marker-char'."
1440 (setq marker (or marker dired-marker-char))
1441 (save-excursion
1442 (beginning-of-line)
1443 (and (looking-at dired-re-mark)
1444 (= (aref (match-string 0) 0) marker))))
1445
1446(defun image-dired-dired-file-flagged-p ()
1447 "In Dired, return t if file on current line is flagged for deletion."
1448 (image-dired-dired-file-marked-p dired-del-marker))
1449
1450(defmacro image-dired--with-thumbnail-buffer (&rest body)
1451 (declare (indent defun) (debug t))
1452 `(if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1453 (with-current-buffer buf
1454 (if-let ((win (get-buffer-window buf)))
1455 (with-selected-window win
1456 ,@body)
1457 ,@body))
1458 (user-error "No such buffer: %s" image-dired-thumbnail-buffer)))
1459
1460(defmacro image-dired--on-file-in-dired-buffer (&rest body)
1461 "Run BODY with point on file at point in Dired buffer.
1462Should be called from commands in `image-dired-thumbnail-mode'."
1463 (declare (indent defun) (debug t))
1464 `(let ((file-name (image-dired-original-file-name))
1465 (dired-buf (image-dired-associated-dired-buffer)))
1466 (if (not (and dired-buf file-name))
1467 (message "No image, or image with correct properties, at point")
1468 (with-current-buffer dired-buf
1469 (when (dired-goto-file file-name)
1470 ,@body
1471 (image-dired-thumb-update-marks))))))
1472
1473(defmacro image-dired--do-mark-command (maybe-next &rest body)
1474 "Helper macro for the mark, unmark and flag commands.
1475Run BODY in Dired buffer.
1476If optional argument MAYBE-NEXT is non-nil, show next image
1477according to `image-dired-marking-shows-next'."
1478 (declare (indent defun) (debug t))
1479 `(image-dired--with-thumbnail-buffer
1480 (image-dired--on-file-in-dired-buffer
1481 ,@body)
1482 ,(when maybe-next
1483 '(if image-dired-marking-shows-next
1484 (image-dired-display-next-thumbnail-original)
1485 (image-dired-next-line)))))
1486
1487(defun image-dired-mark-thumb-original-file ()
1488 "Mark original image file in associated Dired buffer."
1489 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1490 (image-dired--do-mark-command t
1491 (dired-mark 1)))
1492
1493(defun image-dired-unmark-thumb-original-file ()
1494 "Unmark original image file in associated Dired buffer."
1495 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1496 (image-dired--do-mark-command t
1497 (dired-unmark 1)))
1498
1499(defun image-dired-flag-thumb-original-file ()
1500 "Flag original image file for deletion in associated Dired buffer."
1501 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1502 (image-dired--do-mark-command t
1503 (dired-flag-file-deletion 1)))
1504
1505(defun image-dired-toggle-mark-thumb-original-file ()
1506 "Toggle mark on original image file in associated Dired buffer."
1507 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1508 (image-dired--do-mark-command nil
1509 (if (image-dired-dired-file-marked-p)
1510 (dired-unmark 1)
1511 (dired-mark 1))))
1512
1513(defun image-dired-unmark-all-marks ()
1514 "Remove all marks from all files in associated Dired buffer.
1515Also update the marks in the thumbnail buffer."
1516 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1517 (image-dired--do-mark-command nil
1518 (dired-unmark-all-marks))
1519 (image-dired--with-thumbnail-buffer
1520 (image-dired-thumb-update-marks)))
1521
1522(defun image-dired-jump-original-dired-buffer ()
1523 "Jump to the Dired buffer associated with the current image file.
1524You probably want to use this together with
1525`image-dired-track-original-file'."
1526 (interactive nil image-dired-thumbnail-mode)
1527 (let ((buf (image-dired-associated-dired-buffer))
1528 window frame)
1529 (setq window (image-dired-get-buffer-window buf))
1530 (if window
1531 (progn
1532 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1533 (select-frame-set-input-focus frame))
1534 (select-window window))
1535 (message "Associated dired buffer not visible"))))
1536
1537;;;###autoload
1538(defun image-dired-jump-thumbnail-buffer ()
1539 "Jump to thumbnail buffer."
1540 (interactive)
1541 (let ((window (image-dired-thumbnail-window))
1542 frame)
1543 (if window
1544 (progn
1545 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1546 (select-frame-set-input-focus frame))
1547 (select-window window))
1548 (message "Thumbnail buffer not visible"))))
1549
1550(defvar image-dired-thumbnail-mode-line-up-map
1551 (let ((map (make-sparse-keymap)))
1552 ;; map it to "g" so that the user can press it more quickly
1553 (define-key map "g" #'image-dired-line-up-dynamic)
1554 ;; "f" for "fixed" number of thumbs per row
1555 (define-key map "f" #'image-dired-line-up)
1556 ;; "i" for "interactive"
1557 (define-key map "i" #'image-dired-line-up-interactive)
1558 map)
1559 "Keymap for line-up commands in `image-dired-thumbnail-mode'.")
1560
1561(defvar image-dired-thumbnail-mode-tag-map
1562 (let ((map (make-sparse-keymap)))
1563 ;; map it to "t" so that the user can press it more quickly
1564 (define-key map "t" #'image-dired-tag-thumbnail)
1565 ;; "r" for "remove"
1566 (define-key map "r" #'image-dired-tag-thumbnail-remove)
1567 map)
1568 "Keymap for tag commands in `image-dired-thumbnail-mode'.")
1569
1570(defvar image-dired-thumbnail-mode-map
1571 (let ((map (make-sparse-keymap)))
1572 (define-key map [right] #'image-dired-forward-image)
1573 (define-key map [left] #'image-dired-backward-image)
1574 (define-key map [up] #'image-dired-previous-line)
1575 (define-key map [down] #'image-dired-next-line)
1576 (define-key map "\C-f" #'image-dired-forward-image)
1577 (define-key map "\C-b" #'image-dired-backward-image)
1578 (define-key map "\C-p" #'image-dired-previous-line)
1579 (define-key map "\C-n" #'image-dired-next-line)
1580
1581 (define-key map "<" #'image-dired-beginning-of-buffer)
1582 (define-key map ">" #'image-dired-end-of-buffer)
1583 (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer)
1584 (define-key map (kbd "M->") #'image-dired-end-of-buffer)
1585
1586 (define-key map "d" #'image-dired-flag-thumb-original-file)
1587 (define-key map [delete] #'image-dired-flag-thumb-original-file)
1588 (define-key map "m" #'image-dired-mark-thumb-original-file)
1589 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1590 (define-key map "U" #'image-dired-unmark-all-marks)
1591 (define-key map "." #'image-dired-track-original-file)
1592 (define-key map [tab] #'image-dired-jump-original-dired-buffer)
1593
1594 ;; add line-up map
1595 (define-key map "g" image-dired-thumbnail-mode-line-up-map)
1596 ;; add tag map
1597 (define-key map "t" image-dired-thumbnail-mode-tag-map)
1598
1599 (define-key map "\C-m" #'image-dired-display-thumbnail-original-image)
1600 (define-key map [C-return] #'image-dired-thumbnail-display-external)
1601
1602 (define-key map "L" #'image-dired-rotate-original-left)
1603 (define-key map "R" #'image-dired-rotate-original-right)
1604
1605 (define-key map "D" #'image-dired-thumbnail-set-image-description)
1606 (define-key map "S" #'image-dired-slideshow-start)
1607 (define-key map "\C-d" #'image-dired-delete-char)
1608 (define-key map " " #'image-dired-display-next-thumbnail-original)
1609 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1610 (define-key map "c" #'image-dired-comment-thumbnail)
1611
1612 ;; Mouse
1613 (define-key map [mouse-2] #'image-dired-mouse-display-image)
1614 (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail)
1615 (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail)
1616 (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail)
1617 (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail)
1618 (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail)
1619 ;; Seems I must first set C-down-mouse-1 to undefined, or else it
1620 ;; will trigger the buffer menu. If I try to instead bind
1621 ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
1622 ;; about C-mouse-1 not being defined afterwards. Annoying, but I
1623 ;; probably do not completely understand mouse events.
1624 (define-key map [C-down-mouse-1] #'undefined)
1625 (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark)
1626 map)
1627 "Keymap for `image-dired-thumbnail-mode'.")
1628
1629(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map
1630 "Menu for `image-dired-thumbnail-mode'."
1631 '("Image-Dired"
1632 ["Display image" image-dired-display-thumbnail-original-image]
1633 ["Display in external viewer" image-dired-thumbnail-display-external]
1634 ["Jump to Dired buffer" image-dired-jump-original-dired-buffer]
1635 "---"
1636 ["Mark image" image-dired-mark-thumb-original-file]
1637 ["Unmark image" image-dired-unmark-thumb-original-file]
1638 ["Unmark all images" image-dired-unmark-all-marks]
1639 ["Flag for deletion" image-dired-flag-thumb-original-file]
1640 ["Delete marked images" image-dired-delete-marked]
1641 "---"
1642 ["Rotate original right" image-dired-rotate-original-right]
1643 ["Rotate original left" image-dired-rotate-original-left]
1644 "---"
1645 ["Comment thumbnail" image-dired-comment-thumbnail]
1646 ["Tag current or marked thumbnails" image-dired-tag-thumbnail]
1647 ["Remove tag from current or marked thumbnails"
1648 image-dired-tag-thumbnail-remove]
1649 ["Start slideshow" image-dired-slideshow-start]
1650 "---"
1651 ("View Options"
1652 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1653 :style toggle
1654 :selected image-dired-track-movement]
1655 "---"
1656 ["Line up thumbnails" image-dired-line-up]
1657 ["Dynamic line up" image-dired-line-up-dynamic]
1658 ["Refresh thumb" image-dired-refresh-thumb])
1659 ["Quit" quit-window]))
1660
1661(defvar image-dired-display-image-mode-map
1662 (let ((map (make-sparse-keymap)))
1663 (define-key map "S" #'image-dired-slideshow-start)
1664 (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original)
1665 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1666 (define-key map "n" #'image-dired-display-next-thumbnail-original)
1667 (define-key map "p" #'image-dired-display-previous-thumbnail-original)
1668 (define-key map "m" #'image-dired-mark-thumb-original-file)
1669 (define-key map "d" #'image-dired-flag-thumb-original-file)
1670 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1671 (define-key map "U" #'image-dired-unmark-all-marks)
1672 ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
1673 (define-key map "o" nil) ; image-save
1674 map)
1675 "Keymap for `image-dired-display-image-mode'.")
1676
1677(define-derived-mode image-dired-thumbnail-mode
1678 special-mode "image-dired-thumbnail"
1679 "Browse and manipulate thumbnail images using Dired.
1680Use `image-dired-minor-mode' to get a nice setup."
1681 :interactive nil
1682 (buffer-disable-undo)
1683 (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)
1684 (setq-local window-resize-pixelwise t)
1685 (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record)
1686 ;; Use approximately as much vertical spacing as horizontal.
1687 (setq-local line-spacing (frame-char-width)))
1688
1689
1690;;; Display image mode
1691
1692(define-derived-mode image-dired-display-image-mode
1693 image-mode "image-dired-image-display"
1694 "Mode for displaying and manipulating original image.
1695Resized or in full-size."
1696 :interactive nil
1697 (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t))
1698
1699(defvar image-dired-minor-mode-map
1700 (let ((map (make-sparse-keymap)))
1701 ;; (set-keymap-parent map dired-mode-map)
1702 ;; Hijack previous and next line movement. Let C-p and C-b be
1703 ;; though...
1704 (define-key map "p" #'image-dired-dired-previous-line)
1705 (define-key map "n" #'image-dired-dired-next-line)
1706 (define-key map [up] #'image-dired-dired-previous-line)
1707 (define-key map [down] #'image-dired-dired-next-line)
1708
1709 (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display)
1710 (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display)
1711 (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next)
1712
1713 (define-key map "\C-td" #'image-dired-display-thumbs)
1714 (define-key map [tab] #'image-dired-jump-thumbnail-buffer)
1715 (define-key map "\C-ti" #'image-dired-dired-display-image)
1716 (define-key map "\C-tx" #'image-dired-dired-display-external)
1717 (define-key map "\C-ta" #'image-dired-display-thumbs-append)
1718 (define-key map "\C-t." #'image-dired-display-thumb)
1719 (define-key map "\C-tc" #'image-dired-dired-comment-files)
1720 (define-key map "\C-tf" #'image-dired-mark-tagged-files)
1721 map)
1722 "Keymap for `image-dired-minor-mode'.")
1723
1724(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
1725 "Menu for `image-dired-minor-mode'."
1726 '("Image-dired"
1727 ["Display thumb for next file" image-dired-next-line-and-display]
1728 ["Display thumb for previous file" image-dired-previous-line-and-display]
1729 ["Mark and display next" image-dired-mark-and-display-next]
1730 "---"
1731 ["Create thumbnails for marked files" image-dired-create-thumbs]
1732 "---"
1733 ["Display thumbnails append" image-dired-display-thumbs-append]
1734 ["Display this thumbnail" image-dired-display-thumb]
1735 ["Display image" image-dired-dired-display-image]
1736 ["Display in external viewer" image-dired-dired-display-external]
1737 "---"
1738 ["Toggle display properties" image-dired-toggle-dired-display-properties
1739 :style toggle
1740 :selected image-dired-dired-disp-props]
1741 ["Toggle append browsing" image-dired-toggle-append-browsing
1742 :style toggle
1743 :selected image-dired-append-when-browsing]
1744 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1745 :style toggle
1746 :selected image-dired-track-movement]
1747 "---"
1748 ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
1749 ["Mark tagged files" image-dired-mark-tagged-files]
1750 ["Comment files" image-dired-dired-comment-files]
1751 ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
1752
1753;;;###autoload
1754(define-minor-mode image-dired-minor-mode
1755 "Setup easy-to-use keybindings for the commands to be used in Dired mode.
1756Note that n, p and <down> and <up> will be hijacked and bound to
1757`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
1758 :keymap image-dired-minor-mode-map)
1759
1760(declare-function clear-image-cache "image.c" (&optional filter))
1761
1762(defun image-dired-create-thumbs (&optional arg)
1763 "Create thumbnail images for all marked files in Dired.
1764With prefix argument ARG, create thumbnails even if they already exist
1765\(i.e. use this to refresh your thumbnails)."
1766 (interactive "P")
1767 (let (thumb-name)
1768 (dolist (curr-file (dired-get-marked-files))
1769 (setq thumb-name (image-dired-thumb-name curr-file))
1770 ;; If the user overrides the exist check, we must clear the
1771 ;; image cache so that if the user wants to display the
1772 ;; thumbnail, it is not fetched from cache.
1773 (when arg
1774 (clear-image-cache (expand-file-name thumb-name)))
1775 (when (or (not (file-exists-p thumb-name))
1776 arg)
1777 (image-dired-create-thumb curr-file thumb-name)))))
1778
1779
1780;;; Slideshow
1781
1782(defcustom image-dired-slideshow-delay 5.0
1783 "Seconds to wait before showing the next image in a slideshow.
1784This is used by `image-dired-slideshow-start'."
1785 :type 'float
1786 :version "29.1")
1787
1788(define-obsolete-variable-alias 'image-dired-slideshow-timer
1789 'image-dired--slideshow-timer "29.1")
1790(defvar image-dired--slideshow-timer nil
1791 "Slideshow timer.")
1792
1793(defvar image-dired--slideshow-initial nil)
1794
1795(defun image-dired-slideshow-step ()
1796 "Step to next image in a slideshow."
1797 (if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1798 (with-current-buffer buf
1799 (image-dired-display-next-thumbnail-original))
1800 (image-dired-slideshow-stop)))
1801
1802(defun image-dired-slideshow-start (&optional arg)
1803 "Start a slideshow, waiting `image-dired-slideshow-delay' between images.
1804
1805With prefix argument ARG, wait that many seconds before going to
1806the next image.
1807
1808With a negative prefix argument, prompt user for the delay."
1809 (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode)
1810 (let ((delay (if (not arg)
1811 image-dired-slideshow-delay
1812 (if (> arg 0)
1813 arg
1814 (string-to-number
1815 (let ((delay (number-to-string image-dired-slideshow-delay)))
1816 (read-string
1817 (format-prompt "Delay, in seconds. Decimals are accepted" delay))
1818 delay))))))
1819 (setq image-dired--slideshow-timer
1820 (run-with-timer
1821 0 delay
1822 'image-dired-slideshow-step))
1823 (add-hook 'post-command-hook 'image-dired-slideshow-stop)
1824 (setq image-dired--slideshow-initial t)
1825 (message "Running slideshow; use any command to stop")))
1826
1827(defun image-dired-slideshow-stop ()
1828 "Cancel slideshow."
1829 ;; Make sure we don't immediately stop after
1830 ;; `image-dired-slideshow-start'.
1831 (unless image-dired--slideshow-initial
1832 (remove-hook 'post-command-hook 'image-dired-slideshow-stop)
1833 (cancel-timer image-dired--slideshow-timer))
1834 (setq image-dired--slideshow-initial nil))
1835
1836
1837;;; Thumbnail mode (cont. 3)
1838
1839(defun image-dired-delete-char ()
1840 "Remove current thumbnail from thumbnail buffer and line up."
1841 (interactive nil image-dired-thumbnail-mode)
1842 (let ((inhibit-read-only t))
1843 (delete-char 1)
1844 (when (= (following-char) ?\s)
1845 (delete-char 1))))
1846
1847;;;###autoload
1848(defun image-dired-display-thumbs-append ()
1849 "Append thumbnails to `image-dired-thumbnail-buffer'."
1850 (interactive)
1851 (image-dired-display-thumbs nil t t))
1852
1853;;;###autoload
1854(defun image-dired-display-thumb ()
1855 "Shorthand for `image-dired-display-thumbs' with prefix argument."
1856 (interactive)
1857 (image-dired-display-thumbs t nil t))
1858
1859(defun image-dired-line-up ()
1860 "Line up thumbnails according to `image-dired-thumbs-per-row'.
1861See also `image-dired-line-up-dynamic'."
1862 (interactive)
1863 (let ((inhibit-read-only t))
1864 (goto-char (point-min))
1865 (while (and (not (image-dired-image-at-point-p))
1866 (not (eobp)))
1867 (delete-char 1))
1868 (while (not (eobp))
1869 (forward-char)
1870 (while (and (not (image-dired-image-at-point-p))
1871 (not (eobp)))
1872 (delete-char 1)))
1873 (goto-char (point-min))
1874 (let ((seen 0)
1875 (thumb-prev-pos 0)
1876 (thumb-width-chars
1877 (ceiling (/ (+ (* 2 image-dired-thumb-relief)
1878 (* 2 image-dired-thumb-margin)
1879 (image-dired-thumb-size 'width))
1880 (float (frame-char-width))))))
1881 (while (not (eobp))
1882 (forward-char)
1883 (if (= image-dired-thumbs-per-row 1)
1884 (insert "\n")
1885 (cl-incf thumb-prev-pos thumb-width-chars)
1886 (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos)))
1887 (cl-incf seen)
1888 (when (and (= seen (- image-dired-thumbs-per-row 1))
1889 (not (eobp)))
1890 (forward-char)
1891 (insert "\n")
1892 (setq seen 0)
1893 (setq thumb-prev-pos 0)))))
1894 (goto-char (point-min))))
1895
1896(defun image-dired-line-up-dynamic ()
1897 "Line up thumbnails images dynamically.
1898Calculate how many thumbnails fit."
1899 (interactive)
1900 (let* ((char-width (frame-char-width))
1901 (width (image-dired-window-width-pixels (image-dired-thumbnail-window)))
1902 (image-dired-thumbs-per-row
1903 (/ width
1904 (+ (* 2 image-dired-thumb-relief)
1905 (* 2 image-dired-thumb-margin)
1906 (image-dired-thumb-size 'width)
1907 char-width))))
1908 (image-dired-line-up)))
1909
1910(defun image-dired-line-up-interactive ()
1911 "Line up thumbnails interactively.
1912Ask user how many thumbnails should be displayed per row."
1913 (interactive)
1914 (let ((image-dired-thumbs-per-row
1915 (string-to-number (read-string "How many thumbs per row: "))))
1916 (if (not (> image-dired-thumbs-per-row 0))
1917 (message "Number must be greater than 0")
1918 (image-dired-line-up))))
1919
1920(defun image-dired-thumbnail-display-external ()
1921 "Display original image for thumbnail at point using external viewer."
1922 (interactive)
1923 (let ((file (image-dired-original-file-name)))
1924 (if (not (image-dired-image-at-point-p))
1925 (message "No thumbnail at point")
1926 (if (not file)
1927 (message "No original file name found")
1928 (start-process "image-dired-thumb-external" nil
1929 image-dired-external-viewer file)))))
1930
1931;;;###autoload
1932(defun image-dired-dired-display-external ()
1933 "Display file at point using an external viewer."
1934 (interactive)
1935 (let ((file (dired-get-filename)))
1936 (start-process "image-dired-external" nil
1937 image-dired-external-viewer file)))
1938
1939(defun image-dired-window-width-pixels (window)
1940 "Calculate WINDOW width in pixels."
1941 (* (window-width window) (frame-char-width)))
1942
1943(defun image-dired-display-window ()
1944 "Return window where `image-dired-display-image-buffer' is visible."
1945 (get-window-with-predicate
1946 (lambda (window)
1947 (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer))
1948 nil t))
1949
1950(defun image-dired-thumbnail-window ()
1951 "Return window where `image-dired-thumbnail-buffer' is visible."
1952 (get-window-with-predicate
1953 (lambda (window)
1954 (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer))
1955 nil t))
1956
1957(defun image-dired-associated-dired-buffer-window ()
1958 "Return window where associated Dired buffer is visible."
1959 (let (buf)
1960 (if (image-dired-image-at-point-p)
1961 (progn
1962 (setq buf (image-dired-associated-dired-buffer))
1963 (get-window-with-predicate
1964 (lambda (window)
1965 (equal (window-buffer window) buf))))
1966 (error "No thumbnail image at point"))))
1967
1968(defun image-dired-display-image (file &optional _ignored)
1969 "Display image FILE in image buffer.
1970Use this when you want to display the image, in a new window.
1971The window will use `image-dired-display-image-mode' which is
1972based on `image-mode'."
1973 (declare (advertised-calling-convention (file) "29.1"))
1974 (setq file (expand-file-name file))
1975 (when (not (file-exists-p file))
1976 (error "No such file: %s" file))
1977 (let ((buf (get-buffer image-dired-display-image-buffer))
1978 (cur-win (selected-window)))
1979 (when buf
1980 (kill-buffer buf))
1981 (when-let ((buf (find-file-noselect file nil t)))
1982 (pop-to-buffer buf)
1983 (rename-buffer image-dired-display-image-buffer)
1984 (image-dired-display-image-mode)
1985 (select-window cur-win))))
1986
1987(defun image-dired-display-thumbnail-original-image (&optional arg)
1988 "Display current thumbnail's original image in display buffer.
1989See documentation for `image-dired-display-image' for more information.
1990With prefix argument ARG, display image in its original size."
1991 (interactive "P")
1992 (let ((file (image-dired-original-file-name)))
1993 (if (not (string-equal major-mode "image-dired-thumbnail-mode"))
1994 (message "Not in image-dired-thumbnail-mode")
1995 (if (not (image-dired-image-at-point-p))
1996 (message "No thumbnail at point")
1997 (if (not file)
1998 (message "No original file name found")
1999 (image-dired-display-image file arg))))))
2000
2001
2002;;;###autoload
2003(defun image-dired-dired-display-image (&optional arg)
2004 "Display current image file.
2005See documentation for `image-dired-display-image' for more information.
2006With prefix argument ARG, display image in its original size."
2007 (interactive "P")
2008 (image-dired-display-image (dired-get-filename) arg))
2009
2010(defun image-dired-image-at-point-p ()
2011 "Return non-nil if there is an `image-dired' thumbnail at point."
2012 (get-text-property (point) 'image-dired-thumbnail))
2013
2014(defun image-dired-refresh-thumb ()
2015 "Force creation of new image for current thumbnail."
2016 (interactive nil image-dired-thumbnail-mode)
2017 (let* ((file (image-dired-original-file-name))
2018 (thumb (expand-file-name (image-dired-thumb-name file))))
2019 (clear-image-cache (expand-file-name thumb))
2020 (image-dired-create-thumb file thumb)))
2021
2022(defun image-dired-rotate-original (degrees)
2023 "Rotate original image DEGREES degrees."
2024 (image-dired--check-executable-exists
2025 'image-dired-cmd-rotate-original-program)
2026 (if (not (image-dired-image-at-point-p))
2027 (message "No image at point")
2028 (let* ((file (image-dired-original-file-name))
2029 (spec
2030 (list
2031 (cons ?d degrees)
2032 (cons ?o (expand-file-name file))
2033 (cons ?t image-dired-temp-rotate-image-file))))
2034 (unless (eq 'jpeg (image-type file))
2035 (user-error "Only JPEG images can be rotated"))
2036 (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
2037 nil nil nil
2038 (mapcar (lambda (arg) (format-spec arg spec))
2039 image-dired-cmd-rotate-original-options))))
2040 (error "Could not rotate image")
2041 (image-dired-display-image image-dired-temp-rotate-image-file)
2042 (if (or (and image-dired-rotate-original-ask-before-overwrite
2043 (y-or-n-p
2044 "Rotate to temp file OK. Overwrite original image? "))
2045 (not image-dired-rotate-original-ask-before-overwrite))
2046 (progn
2047 (copy-file image-dired-temp-rotate-image-file file t)
2048 (image-dired-refresh-thumb))
2049 (image-dired-display-image file))))))
2050
2051(defun image-dired-rotate-original-left ()
2052 "Rotate original image left (counter clockwise) 90 degrees.
2053The result of the rotation is displayed in the image display area
2054and a confirmation is needed before the original image files is
2055overwritten. This confirmation can be turned off using
2056`image-dired-rotate-original-ask-before-overwrite'."
2057 (interactive)
2058 (image-dired-rotate-original "270"))
2059
2060(defun image-dired-rotate-original-right ()
2061 "Rotate original image right (clockwise) 90 degrees.
2062The result of the rotation is displayed in the image display area
2063and a confirmation is needed before the original image files is
2064overwritten. This confirmation can be turned off using
2065`image-dired-rotate-original-ask-before-overwrite'."
2066 (interactive)
2067 (image-dired-rotate-original "90"))
2068
2069
2070;;; EXIF support
2071
2072(defun image-dired-get-exif-file-name (file)
2073 "Use the image's EXIF information to return a unique file name.
2074The file name should be unique as long as you do not take more than
2075one picture per second. The original file name is suffixed at the end
2076for traceability. The format of the returned file name is
2077YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
2078`image-dired-copy-with-exif-file-name'."
2079 (let (data no-exif-data-found)
2080 (if (not (eq 'jpeg (image-type (expand-file-name file))))
2081 (setq no-exif-data-found t
2082 data (format-time-string
2083 "%Y:%m:%d %H:%M:%S"
2084 (file-attribute-modification-time
2085 (file-attributes (expand-file-name file)))))
2086 (setq data (exif-field 'date-time (exif-parse-file
2087 (expand-file-name file)))))
2088 (while (string-match "[ :]" data)
2089 (setq data (replace-match "_" nil nil data)))
2090 (format "%s%s%s" data
2091 (if no-exif-data-found
2092 "_noexif_"
2093 "_")
2094 (file-name-nondirectory file))))
2095
2096(defun image-dired-thumbnail-set-image-description ()
2097 "Set the ImageDescription EXIF tag for the original image.
2098If the image already has a value for this tag, it is used as the
2099default value at the prompt."
2100 (interactive)
2101 (if (not (image-dired-image-at-point-p))
2102 (message "No thumbnail at point")
2103 (let* ((file (image-dired-original-file-name))
2104 (old-value (or (exif-field 'description (exif-parse-file file)) "")))
2105 (if (eq 0
2106 (image-dired-set-exif-data file "ImageDescription"
2107 (read-string "Value of ImageDescription: "
2108 old-value)))
2109 (message "Successfully wrote ImageDescription tag")
2110 (error "Could not write ImageDescription tag")))))
2111
2112(defun image-dired-set-exif-data (file tag-name tag-value)
2113 "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
2114 (image-dired--check-executable-exists
2115 'image-dired-cmd-write-exif-data-program)
2116 (let ((spec
2117 (list
2118 (cons ?f (expand-file-name file))
2119 (cons ?t tag-name)
2120 (cons ?v tag-value))))
2121 (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
2122 (mapcar (lambda (arg) (format-spec arg spec))
2123 image-dired-cmd-write-exif-data-options))))
2124
2125(defun image-dired-copy-with-exif-file-name ()
2126 "Copy file with unique name to main image directory.
2127Copy current or all marked files in Dired to a new file in your
2128main image directory, using a file name generated by
2129`image-dired-get-exif-file-name'. A typical usage for this if when
2130copying images from a digital camera into the image directory.
2131
2132 Typically, you would open up the folder with the incoming
2133digital images, mark the files to be copied, and execute this
2134function. The result is a couple of new files in
2135`image-dired-main-image-directory' called
21362005_05_08_12_52_00_dscn0319.jpg,
21372005_05_08_14_27_45_dscn0320.jpg etc."
2138 (interactive)
2139 (let (new-name
2140 (files (dired-get-marked-files)))
2141 (mapc
2142 (lambda (curr-file)
2143 (setq new-name
2144 (format "%s/%s"
2145 (file-name-as-directory
2146 (expand-file-name image-dired-main-image-directory))
2147 (image-dired-get-exif-file-name curr-file)))
2148 (message "Copying %s to %s" curr-file new-name)
2149 (copy-file curr-file new-name))
2150 files)))
2151
2152;;; Thumbnail mode (cont.)
2153
2154(defun image-dired-display-next-thumbnail-original (&optional arg)
2155 "Move to the next image in the thumbnail buffer and display it.
2156With prefix ARG, move that many thumbnails."
2157 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2158 (image-dired--with-thumbnail-buffer
2159 (image-dired-forward-image arg t)
2160 (image-dired-display-thumbnail-original-image)))
2161
2162(defun image-dired-display-previous-thumbnail-original (arg)
2163 "Move to the previous image in the thumbnail buffer and display it.
2164With prefix ARG, move that many thumbnails."
2165 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2166 (image-dired-display-next-thumbnail-original (- arg)))
2167
2168
2169;;; Image Comments
2170
2171(defun image-dired-write-comments (file-comments)
2172 "Write file comments to database.
2173Write file comments to one or more files.
2174FILE-COMMENTS is an alist on the following form:
2175 ((FILE . COMMENT) ... )"
2176 (image-dired-sane-db-file)
2177 (let (end comment-beg-pos comment-end-pos file comment)
2178 (image-dired--with-db-file
2179 (setq buffer-file-name image-dired-db-file)
2180 (dolist (elt file-comments)
2181 (setq file (car elt)
2182 comment (cdr elt))
2183 (goto-char (point-min))
2184 (if (search-forward-regexp (format "^%s.*$" file) nil t)
2185 (progn
2186 (setq end (point))
2187 (beginning-of-line)
2188 ;; Delete old comment, if any
2189 (when (search-forward ";comment:" end t)
2190 (setq comment-beg-pos (match-beginning 0))
2191 ;; Any tags after the comment?
2192 (if (search-forward ";" end t)
2193 (setq comment-end-pos (- (point) 1))
2194 (setq comment-end-pos end))
2195 ;; Delete comment tag and comment
2196 (delete-region comment-beg-pos comment-end-pos))
2197 ;; Insert new comment
2198 (beginning-of-line)
2199 (unless (search-forward ";" end t)
2200 (end-of-line)
2201 (insert ";"))
2202 (insert (format "comment:%s;" comment)))
2203 ;; File does not exist in database - add it.
2204 (goto-char (point-max))
2205 (insert (format "%s;comment:%s\n" file comment))))
2206 (save-buffer))))
2207
2208(defun image-dired-update-property (prop value)
2209 "Update text property PROP with value VALUE at point."
2210 (let ((inhibit-read-only t))
2211 (put-text-property
2212 (point) (1+ (point))
2213 prop
2214 value)))
2215
2216;;;###autoload
2217(defun image-dired-dired-comment-files ()
2218 "Add comment to current or marked files in Dired."
2219 (interactive)
2220 (let ((comment (image-dired-read-comment)))
2221 (image-dired-write-comments
2222 (mapcar
2223 (lambda (curr-file)
2224 (cons curr-file comment))
2225 (dired-get-marked-files)))))
2226
2227(defun image-dired-comment-thumbnail ()
2228 "Add comment to current thumbnail in thumbnail buffer."
2229 (interactive)
2230 (let* ((file (image-dired-original-file-name))
2231 (comment (image-dired-read-comment file)))
2232 (image-dired-write-comments (list (cons file comment)))
2233 (image-dired-update-property 'comment comment))
2234 (image-dired-update-header-line))
2235
2236(defun image-dired-read-comment (&optional file)
2237 "Read comment for an image.
2238Optionally use old comment from FILE as initial value."
2239 (let ((comment
2240 (read-string
2241 "Comment: "
2242 (if file (image-dired-get-comment file)))))
2243 comment))
2244
2245(defun image-dired-get-comment (file)
2246 "Get comment for file FILE."
2247 (image-dired-sane-db-file)
2248 (image-dired--with-db-file
2249 (let (end comment-beg-pos comment-end-pos comment)
2250 (when (search-forward-regexp (format "^%s" file) nil t)
2251 (end-of-line)
2252 (setq end (point))
2253 (beginning-of-line)
2254 (when (search-forward ";comment:" end t)
2255 (setq comment-beg-pos (point))
2256 (if (search-forward ";" end t)
2257 (setq comment-end-pos (- (point) 1))
2258 (setq comment-end-pos end))
2259 (setq comment (buffer-substring
2260 comment-beg-pos comment-end-pos))))
2261 comment)))
2262
2263;;;###autoload
2264(defun image-dired-mark-tagged-files (regexp)
2265 "Use REGEXP to mark files with matching tag.
2266A `tag' is a keyword, a piece of meta data, associated with an
2267image file and stored in image-dired's database file. This command
2268lets you input a regexp and this will be matched against all tags
2269on all image files in the database file. The files that have a
2270matching tag will be marked in the Dired buffer."
2271 (interactive "sMark tagged files (regexp): ")
2272 (image-dired-sane-db-file)
2273 (let ((hits 0)
2274 files)
2275 (image-dired--with-db-file
2276 ;; Collect matches
2277 (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t)
2278 (let ((file (match-string 1))
2279 (tags (split-string (match-string 2) ";")))
2280 (when (seq-find (lambda (tag)
2281 (string-match-p regexp tag))
2282 tags)
2283 (push file files)))))
2284 ;; Mark files
2285 (dolist (curr-file files)
2286 ;; I tried using `dired-mark-files-regexp' but it was waaaay to
2287 ;; slow. Don't bother about hits found in other directories
2288 ;; than the current one.
2289 (when (string= (file-name-as-directory
2290 (expand-file-name default-directory))
2291 (file-name-as-directory
2292 (file-name-directory curr-file)))
2293 (setq curr-file (file-name-nondirectory curr-file))
2294 (goto-char (point-min))
2295 (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
2296 (setq hits (+ hits 1))
2297 (dired-mark 1))))
2298 (message "%d files with matching tag marked" hits)))
2299
2300
2301
2302;;; Mouse support
2303
2304(defun image-dired-mouse-display-image (event)
2305 "Use mouse EVENT, call `image-dired-display-image' to display image.
2306Track this in associated Dired buffer if `image-dired-track-movement' is
2307non-nil."
2308 (interactive "e")
2309 (mouse-set-point event)
2310 (goto-char (posn-point (event-end event)))
2311 (unless (image-at-point-p)
2312 (image-dired-backward-image))
2313 (let ((file (image-dired-original-file-name)))
2314 (when file
2315 (if image-dired-track-movement
2316 (image-dired-track-original-file))
2317 (image-dired-display-image file))))
2318
2319(defun image-dired-mouse-select-thumbnail (event)
2320 "Use mouse EVENT to select thumbnail image.
2321Track this in associated Dired buffer if `image-dired-track-movement' is
2322non-nil."
2323 (interactive "e")
2324 (mouse-set-point event)
2325 (goto-char (posn-point (event-end event)))
2326 (unless (image-at-point-p)
2327 (image-dired-backward-image))
2328 (if image-dired-track-movement
2329 (image-dired-track-original-file))
2330 (image-dired-update-header-line))
2331
2332
2333
2334;;; Dired marks and tags
2335
2336(defun image-dired-thumb-file-marked-p (&optional flagged)
2337 "Check if file is marked in associated Dired buffer.
2338If optional argument FLAGGED is non-nil, check if file is flagged
2339for deletion instead."
2340 (let ((file-name (image-dired-original-file-name))
2341 (dired-buf (image-dired-associated-dired-buffer)))
2342 (when (and dired-buf file-name)
2343 (with-current-buffer dired-buf
2344 (save-excursion
2345 (when (dired-goto-file file-name)
2346 (if flagged
2347 (image-dired-dired-file-flagged-p)
2348 (image-dired-dired-file-marked-p))))))))
2349
2350(defun image-dired-thumb-file-flagged-p ()
2351 "Check if file is flagged for deletion in associated Dired buffer."
2352 (image-dired-thumb-file-marked-p t))
2353
2354(defun image-dired-delete-marked ()
2355 "Delete current or marked thumbnails and associated images."
2356 (interactive)
2357 (image-dired--with-marked
2358 (image-dired-delete-char)
2359 (unless (bobp)
2360 (backward-char)))
2361 (image-dired--line-up-with-method)
2362 (with-current-buffer (image-dired-associated-dired-buffer)
2363 (dired-do-delete)))
2364
2365(defun image-dired-thumb-update-marks ()
2366 "Update the marks in the thumbnail buffer."
2367 (when image-dired-thumb-visible-marks
2368 (with-current-buffer image-dired-thumbnail-buffer
2369 (save-mark-and-excursion
2370 (goto-char (point-min))
2371 (let ((inhibit-read-only t))
2372 (while (not (eobp))
2373 (with-silent-modifications
2374 (cond ((image-dired-thumb-file-marked-p)
2375 (add-face-text-property (point) (1+ (point))
2376 'image-dired-thumb-mark))
2377 ((image-dired-thumb-file-flagged-p)
2378 (add-face-text-property (point) (1+ (point))
2379 'image-dired-thumb-flagged))
2380 (t (remove-text-properties (point) (1+ (point))
2381 '(face image-dired-thumb-mark)))))
2382 (forward-char)))))))
2383
2384(defun image-dired-mouse-toggle-mark-1 ()
2385 "Toggle Dired mark for current thumbnail.
2386Track this in associated Dired buffer if
2387`image-dired-track-movement' is non-nil."
2388 (when image-dired-track-movement
2389 (image-dired-track-original-file))
2390 (image-dired-toggle-mark-thumb-original-file))
2391
2392(defun image-dired-mouse-toggle-mark (event)
2393 "Use mouse EVENT to toggle Dired mark for thumbnail.
2394Toggle marks of all thumbnails in region, if it's active.
2395Track this in associated Dired buffer if
2396`image-dired-track-movement' is non-nil."
2397 (interactive "e")
2398 (if (use-region-p)
2399 (let ((end (region-end)))
2400 (save-excursion
2401 (goto-char (region-beginning))
2402 (while (<= (point) end)
2403 (when (image-dired-image-at-point-p)
2404 (image-dired-mouse-toggle-mark-1))
2405 (forward-char))))
2406 (mouse-set-point event)
2407 (goto-char (posn-point (event-end event)))
2408 (image-dired-mouse-toggle-mark-1))
2409 (image-dired-thumb-update-marks))
2410
2411(defun image-dired-dired-display-properties ()
2412 "Display properties for Dired file in the echo area."
2413 (interactive)
2414 (let* ((file (dired-get-filename))
2415 (file-name (file-name-nondirectory file))
2416 (dired-buf (buffer-name (current-buffer)))
2417 (props (mapconcat #'identity (image-dired-list-tags file) ", "))
2418 (comment (image-dired-get-comment file))
2419 (message-log-max nil))
2420 (if file-name
2421 (message "%s"
2422 (image-dired-format-properties-string
2423 dired-buf
2424 file-name
2425 props
2426 comment)))))
2427
2428
2429
2430;;; Gallery support
2431
2432;; TODO:
2433;; * Support gallery creation when using per-directory thumbnail
2434;; storage.
2435;; * Enhanced gallery creation with basic CSS-support and pagination
2436;; of tag pages with many pictures.
2437
2438(defgroup image-dired-gallery nil
2439 "Image-Dired support for generating a HTML gallery."
2440 :prefix "image-dired-"
2441 :group 'image-dired
2442 :version "29.1")
2443
2444(defcustom image-dired-gallery-dir
2445 (expand-file-name ".image-dired_gallery" image-dired-dir)
2446 "Directory to store generated gallery html pages.
2447The name of this directory needs to be \"shared\" to the public
2448so that it can access the index.html page that image-dired creates."
2449 :type 'directory)
2450
2451(defcustom image-dired-gallery-image-root-url
2452 "https://example.org/image-diredpics"
2453 "URL where the full size images are to be found on your web server.
2454Note that this URL has to be configured on your web server.
2455Image-Dired expects to find pictures in this directory.
2456This is used by `image-dired-gallery-generate'."
2457 :type 'string
2458 :version "29.1")
2459
2460(defcustom image-dired-gallery-thumb-image-root-url
2461 "https://example.org/image-diredthumbs"
2462 "URL where the thumbnail images are to be found on your web server.
2463Note that URL path has to be configured on your web server.
2464Image-Dired expects to find pictures in this directory.
2465This is used by `image-dired-gallery-generate'."
2466 :type 'string
2467 :version "29.1")
2468
2469(defcustom image-dired-gallery-hidden-tags
2470 (list "private" "hidden" "pending")
2471 "List of \"hidden\" tags.
2472Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
2473 :type '(repeat string))
2474
2475(defvar image-dired-tag-file-list nil
2476 "List to store tag-file structure.")
2477
2478(defvar image-dired-file-tag-list nil
2479 "List to store file-tag structure.")
2480
2481(defvar image-dired-file-comment-list nil
2482 "List to store file comments.")
2483
2484(defun image-dired--add-to-tag-file-lists (tag file)
2485 "Helper function used from `image-dired--create-gallery-lists'.
2486
2487Add TAG to FILE in one list and FILE to TAG in the other.
2488
2489Lisp structures look like the following:
2490
2491image-dired-file-tag-list:
2492
2493 ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...)
2494 (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...)
2495 ...)
2496
2497image-dired-tag-file-list:
2498
2499 ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...)
2500 (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...)
2501 ...)"
2502 ;; Add tag to file list
2503 (let (curr)
2504 (if image-dired-file-tag-list
2505 (if (setq curr (assoc file image-dired-file-tag-list))
2506 (setcdr curr (cons tag (cdr curr)))
2507 (setcdr image-dired-file-tag-list
2508 (cons (list file tag) (cdr image-dired-file-tag-list))))
2509 (setq image-dired-file-tag-list (list (list file tag))))
2510 ;; Add file to tag list
2511 (if image-dired-tag-file-list
2512 (if (setq curr (assoc tag image-dired-tag-file-list))
2513 (if (not (member file curr))
2514 (setcdr curr (cons file (cdr curr))))
2515 (setcdr image-dired-tag-file-list
2516 (cons (list tag file) (cdr image-dired-tag-file-list))))
2517 (setq image-dired-tag-file-list (list (list tag file))))))
2518
2519(defun image-dired--add-to-file-comment-list (file comment)
2520 "Helper function used from `image-dired--create-gallery-lists'.
2521
2522For FILE, add COMMENT to list.
2523
2524Lisp structure looks like the following:
2525
2526image-dired-file-comment-list:
2527
2528 ((\"filename1\" . \"comment1\")
2529 (\"filename2\" . \"comment2\")
2530 ...)"
2531 (if image-dired-file-comment-list
2532 (if (not (assoc file image-dired-file-comment-list))
2533 (setcdr image-dired-file-comment-list
2534 (cons (cons file comment)
2535 (cdr image-dired-file-comment-list))))
2536 (setq image-dired-file-comment-list (list (cons file comment)))))
2537
2538(defun image-dired--create-gallery-lists ()
2539 "Create temporary lists used by `image-dired-gallery-generate'."
2540 (image-dired-sane-db-file)
2541 (image-dired--with-db-file
2542 (let (end beg file row-tags)
2543 (setq image-dired-tag-file-list nil)
2544 (setq image-dired-file-tag-list nil)
2545 (setq image-dired-file-comment-list nil)
2546 (goto-char (point-min))
2547 (while (search-forward-regexp "^." nil t)
2548 (end-of-line)
2549 (setq end (point))
2550 (beginning-of-line)
2551 (setq beg (point))
2552 (unless (search-forward ";" end nil)
2553 (error "Something is really wrong, check format of database"))
2554 (setq row-tags (split-string
2555 (buffer-substring beg end) ";"))
2556 (setq file (car row-tags))
2557 (dolist (x (cdr row-tags))
2558 (if (not (string-match "^comment:\\(.*\\)" x))
2559 (image-dired--add-to-tag-file-lists x file)
2560 (image-dired--add-to-file-comment-list file (match-string 1 x)))))))
2561 ;; Sort tag-file list
2562 (setq image-dired-tag-file-list
2563 (sort image-dired-tag-file-list
2564 (lambda (x y)
2565 (string< (car x) (car y))))))
2566
2567(defun image-dired--hidden-p (file)
2568 "Return t if image FILE has a \"hidden\" tag."
2569 (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
2570 if (member tag image-dired-gallery-hidden-tags) return t))
2571
2572(defun image-dired-gallery-generate ()
2573 "Generate gallery pages.
2574First we create a couple of Lisp structures from the database to make
2575it easier to generate, then HTML-files are created in
2576`image-dired-gallery-dir'."
2577 (interactive)
2578 (if (eq 'per-directory image-dired-thumbnail-storage)
2579 (error "Currently, gallery generation is not supported \
2580when using per-directory thumbnail file storage"))
2581 (image-dired--create-gallery-lists)
2582 (let ((tags image-dired-tag-file-list)
2583 (index-file (format "%s/index.html" image-dired-gallery-dir))
2584 count tag tag-file
2585 comment file-tags tag-link tag-link-list)
2586 ;; Make sure gallery root exist
2587 (if (file-exists-p image-dired-gallery-dir)
2588 (if (not (file-directory-p image-dired-gallery-dir))
2589 (error "Variable image-dired-gallery-dir is not a directory"))
2590 ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
2591 (make-directory image-dired-gallery-dir))
2592 ;; Open index file
2593 (with-temp-file index-file
2594 (if (file-exists-p index-file)
2595 (insert-file-contents index-file))
2596 (insert "<html>\n")
2597 (insert " <body>\n")
2598 (insert " <h2>Image-Dired Gallery</h2>\n")
2599 (insert (format "<p>\n Gallery generated %s\n <p>\n"
2600 (current-time-string)))
2601 (insert " <h3>Tag index</h3>\n")
2602 (setq count 1)
2603 ;; Pre-generate list of all tag links
2604 (dolist (curr tags)
2605 (setq tag (car curr))
2606 (when (not (member tag image-dired-gallery-hidden-tags))
2607 (setq tag-link (format "<a href=\"%d.html\">%s</a>" count tag))
2608 (if tag-link-list
2609 (setq tag-link-list
2610 (append tag-link-list (list (cons tag tag-link))))
2611 (setq tag-link-list (list (cons tag tag-link))))
2612 (setq count (1+ count))))
2613 (setq count 1)
2614 ;; Main loop where we generated thumbnail pages per tag
2615 (dolist (curr tags)
2616 (setq tag (car curr))
2617 ;; Don't display hidden tags
2618 (when (not (member tag image-dired-gallery-hidden-tags))
2619 ;; Insert link to tag page in index
2620 (insert (format " %s<br>\n" (cdr (assoc tag tag-link-list))))
2621 ;; Open per-tag file
2622 (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count))
2623 (with-temp-file tag-file
2624 (if (file-exists-p tag-file)
2625 (insert-file-contents tag-file))
2626 (erase-buffer)
2627 (insert "<html>\n")
2628 (insert " <body>\n")
2629 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2630 (insert (format " <h2>Images with tag &quot;%s&quot;</h2>" tag))
2631 ;; Main loop for files per tag page
2632 (dolist (file (cdr curr))
2633 (unless (image-dired-hidden-p file)
2634 ;; Insert thumbnail with link to full image
2635 (insert
2636 (format "<a href=\"%s/%s\"><img src=\"%s/%s\"%s></a>\n"
2637 image-dired-gallery-image-root-url
2638 (file-name-nondirectory file)
2639 image-dired-gallery-thumb-image-root-url
2640 (file-name-nondirectory (image-dired-thumb-name file)) file))
2641 ;; Insert comment, if any
2642 (if (setq comment (cdr (assoc file image-dired-file-comment-list)))
2643 (insert (format "<br>\n%s<br>\n" comment))
2644 (insert "<br>\n"))
2645 ;; Insert links to other tags, if any
2646 (when (> (length
2647 (setq file-tags (assoc file image-dired-file-tag-list))) 2)
2648 (insert "[ ")
2649 (dolist (extra-tag file-tags)
2650 ;; Only insert if not file name or the main tag
2651 (if (and (not (equal extra-tag tag))
2652 (not (equal extra-tag file)))
2653 (insert
2654 (format "%s " (cdr (assoc extra-tag tag-link-list))))))
2655 (insert "]<br>\n"))))
2656 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2657 (insert " </body>\n")
2658 (insert "</html>\n"))
2659 (setq count (1+ count))))
2660 (insert " </body>\n")
2661 (insert "</html>"))))
2662
2663
2664;;; Tag support
2665
2666(defvar image-dired-widget-list nil
2667 "List to keep track of meta data in edit buffer.")
2668
2669(declare-function widget-forward "wid-edit" (arg))
2670
2671;;;###autoload
2672(defun image-dired-dired-edit-comment-and-tags ()
2673 "Edit comment and tags of current or marked image files.
2674Edit comment and tags for all marked image files in an
2675easy-to-use form."
2676 (interactive)
2677 (setq image-dired-widget-list nil)
2678 ;; Setup buffer.
2679 (let ((files (dired-get-marked-files)))
2680 (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
2681 (kill-all-local-variables)
2682 (let ((inhibit-read-only t))
2683 (erase-buffer))
2684 (remove-overlays)
2685 ;; Some help for the user.
2686 (widget-insert
2687"\nEdit comments and tags for each image. Separate multiple tags
2688with a comma. Move forward between fields using TAB or RET.
2689Move to the previous field using backtab (S-TAB). Save by
2690activating the Save button at the bottom of the form or cancel
2691the operation by activating the Cancel button.\n\n")
2692 ;; Here comes all images and a comment and tag field for each
2693 ;; image.
2694 (let (thumb-file img comment-widget tag-widget)
2695
2696 (dolist (file files)
2697
2698 (setq thumb-file (image-dired-thumb-name file)
2699 img (create-image thumb-file))
2700
2701 (insert-image img)
2702 (widget-insert "\n\nComment: ")
2703 (setq comment-widget
2704 (widget-create 'editable-field
2705 :size 60
2706 :format "%v "
2707 :value (or (image-dired-get-comment file) "")))
2708 (widget-insert "\nTags: ")
2709 (setq tag-widget
2710 (widget-create 'editable-field
2711 :size 60
2712 :format "%v "
2713 :value (or (mapconcat
2714 #'identity
2715 (image-dired-list-tags file)
2716 ",") "")))
2717 ;; Save information in all widgets so that we can use it when
2718 ;; the user saves the form.
2719 (setq image-dired-widget-list
2720 (append image-dired-widget-list
2721 (list (list file comment-widget tag-widget))))
2722 (widget-insert "\n\n")))
2723
2724 ;; Footer with Save and Cancel button.
2725 (widget-insert "\n")
2726 (widget-create 'push-button
2727 :notify
2728 (lambda (&rest _ignore)
2729 (image-dired-save-information-from-widgets)
2730 (bury-buffer)
2731 (message "Done"))
2732 "Save")
2733 (widget-insert " ")
2734 (widget-create 'push-button
2735 :notify
2736 (lambda (&rest _ignore)
2737 (bury-buffer)
2738 (message "Operation canceled"))
2739 "Cancel")
2740 (widget-insert "\n")
2741 (use-local-map widget-keymap)
2742 (widget-setup)
2743 ;; Jump to the first widget.
2744 (widget-forward 1)))
2745
2746(defun image-dired-save-information-from-widgets ()
2747 "Save information found in `image-dired-widget-list'.
2748Use the information in `image-dired-widget-list' to save comments and
2749tags to their respective image file. Internal function used by
2750`image-dired-dired-edit-comment-and-tags'."
2751 (let (file comment tag-string tag-list lst)
2752 (image-dired-write-comments
2753 (mapcar
2754 (lambda (widget)
2755 (setq file (car widget)
2756 comment (widget-value (cadr widget)))
2757 (cons file comment))
2758 image-dired-widget-list))
2759 (image-dired-write-tags
2760 (dolist (widget image-dired-widget-list lst)
2761 (setq file (car widget)
2762 tag-string (widget-value (car (cddr widget)))
2763 tag-list (split-string tag-string ","))
2764 (dolist (tag tag-list)
2765 (push (cons file tag) lst))))))
2766
2767
2768;;; bookmark.el support
2769
2770(declare-function bookmark-make-record-default
2771 "bookmark" (&optional no-file no-context posn))
2772(declare-function bookmark-prop-get "bookmark" (bookmark prop))
2773
2774(defun image-dired-bookmark-name ()
2775 "Create a default bookmark name for the current EWW buffer."
2776 (file-name-nondirectory
2777 (directory-file-name
2778 (file-name-directory (image-dired-original-file-name)))))
2779
2780(defun image-dired-bookmark-make-record ()
2781 "Create a bookmark for the current EWW buffer."
2782 `(,(image-dired-bookmark-name)
2783 ,@(bookmark-make-record-default t)
2784 (location . ,(file-name-directory (image-dired-original-file-name)))
2785 (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name)))
2786 (handler . image-dired-bookmark-jump)))
2787
2788;;;###autoload
2789(defun image-dired-bookmark-jump (bookmark)
2790 "Default bookmark handler for Image-Dired buffers."
2791 ;; User already cached thumbnails, so disable any checking.
2792 (let ((image-dired-show-all-from-dir-max-files nil))
2793 (image-dired (bookmark-prop-get bookmark 'location))
2794 ;; TODO: Go to the bookmarked file, if it exists.
2795 ;; (bookmark-prop-get bookmark 'image-dired-file)
2796 (goto-char (point-min))))
2797
2798(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired")
2799
2800;;; Obsolete
2801
2802;;;###autoload
2803(define-obsolete-function-alias 'tumme #'image-dired "24.4")
2804
2805;;;###autoload
2806(define-obsolete-function-alias 'image-dired-setup-dired-keybindings
2807 #'image-dired-minor-mode "26.1")
2808
2809(defcustom image-dired-temp-image-file
2810 (expand-file-name ".image-dired_temp" image-dired-dir)
2811 "Name of temporary image file used by various commands."
2812 :type 'file)
2813(make-obsolete-variable 'image-dired-temp-image-file
2814 "no longer used." "29.1")
2815
2816(defcustom image-dired-cmd-create-temp-image-program
2817 (if (executable-find "gm") "gm" "convert")
2818 "Executable used to create temporary image.
2819Used together with `image-dired-cmd-create-temp-image-options'."
2820 :type 'file
2821 :version "29.1")
2822(make-obsolete-variable 'image-dired-cmd-create-temp-image-program
2823 "no longer used." "29.1")
2824
2825(defcustom image-dired-cmd-create-temp-image-options
2826 (let ((opts '("-size" "%wx%h" "%f[0]"
2827 "-resize" "%wx%h>"
2828 "-strip" "jpeg:%t")))
2829 (if (executable-find "gm") (cons "convert" opts) opts))
2830 "Options of command used to create temporary image for display window.
2831Used together with `image-dired-cmd-create-temp-image-program',
2832Available format specifiers are: %w and %h which are replaced by
2833the calculated max size for width and height in the image display window,
2834%f which is replaced by the file name of the original image and %t which
2835is replaced by the file name of the temporary file."
2836 :version "29.1"
2837 :type '(repeat (string :tag "Argument")))
2838(make-obsolete-variable 'image-dired-cmd-create-temp-image-options
2839 "no longer used." "29.1")
2840
2841(defcustom image-dired-display-window-width-correction 1
2842 "Number to be used to correct image display window width.
2843Change if the default (1) does not work (i.e. if the image does not
2844completely fit)."
2845 :type 'integer)
2846(make-obsolete-variable 'image-dired-display-window-width-correction
2847 "no longer used." "29.1")
2848
2849(defcustom image-dired-display-window-height-correction 0
2850 "Number to be used to correct image display window height.
2851Change if the default (0) does not work (i.e. if the image does not
2852completely fit)."
2853 :type 'integer)
2854(make-obsolete-variable 'image-dired-display-window-height-correction
2855 "no longer used." "29.1")
2856
2857(defun image-dired-display-window-width (window)
2858 "Return width, in pixels, of WINDOW."
2859 (declare (obsolete nil "29.1"))
2860 (- (image-dired-window-width-pixels window)
2861 image-dired-display-window-width-correction))
2862
2863(defun image-dired-display-window-height (window)
2864 "Return height, in pixels, of WINDOW."
2865 (declare (obsolete nil "29.1"))
2866 (- (image-dired-window-height-pixels window)
2867 image-dired-display-window-height-correction))
2868
2869(defun image-dired-window-height-pixels (window)
2870 "Calculate WINDOW height in pixels."
2871 (declare (obsolete nil "29.1"))
2872 ;; Note: The mode-line consumes one line
2873 (* (- (window-height window) 1) (frame-char-height)))
2874
2875(defcustom image-dired-cmd-read-exif-data-program "exiftool"
2876 "Program used to read EXIF data to image.
2877Used together with `image-dired-cmd-read-exif-data-options'."
2878 :type 'file)
2879(make-obsolete-variable 'image-dired-cmd-read-exif-data-program
2880 "use `exif-parse-file' and `exif-field' instead." "29.1")
2881
2882(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f")
2883 "Arguments of command used to read EXIF data.
2884Used with `image-dired-cmd-read-exif-data-program'.
2885Available format specifiers are: %f which is replaced
2886by the image file name and %t which is replaced by the tag name."
2887 :version "26.1"
2888 :type '(repeat (string :tag "Argument")))
2889(make-obsolete-variable 'image-dired-cmd-read-exif-data-options
2890 "use `exif-parse-file' and `exif-field' instead." "29.1")
2891
2892(defun image-dired-get-exif-data (file tag-name)
2893 "From FILE, return EXIF tag TAG-NAME."
2894 (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1"))
2895 (image-dired--check-executable-exists
2896 'image-dired-cmd-read-exif-data-program)
2897 (let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
2898 (spec (list (cons ?f file) (cons ?t tag-name)))
2899 tag-value)
2900 (with-current-buffer buf
2901 (delete-region (point-min) (point-max))
2902 (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
2903 nil t nil
2904 (mapcar
2905 (lambda (arg) (format-spec arg spec))
2906 image-dired-cmd-read-exif-data-options))
2907 0))
2908 (error "Could not get EXIF tag")
2909 (goto-char (point-min))
2910 ;; Clean buffer from newlines and carriage returns before
2911 ;; getting final info
2912 (while (search-forward-regexp "[\n\r]" nil t)
2913 (replace-match "" nil t))
2914 (setq tag-value (buffer-substring (point-min) (point-max)))))
2915 tag-value))
2916
2917(defcustom image-dired-cmd-rotate-thumbnail-program
2918 (if (executable-find "gm") "gm" "mogrify")
2919 "Executable used to rotate thumbnail.
2920Used together with `image-dired-cmd-rotate-thumbnail-options'."
2921 :type 'file
2922 :version "29.1")
2923(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1")
2924
2925(defcustom image-dired-cmd-rotate-thumbnail-options
2926 (let ((opts '("-rotate" "%d" "%t")))
2927 (if (executable-find "gm") (cons "mogrify" opts) opts))
2928 "Arguments of command used to rotate thumbnail image.
2929Used with `image-dired-cmd-rotate-thumbnail-program'.
2930Available format specifiers are: %d which is replaced by the
2931number of (positive) degrees to rotate the image, normally 90 or 270
2932\(for 90 degrees right and left), %t which is replaced by the file name
2933of the thumbnail file."
2934 :version "29.1"
2935 :type '(repeat (string :tag "Argument")))
2936(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1")
2937
2938(defun image-dired-rotate-thumbnail (degrees)
2939 "Rotate thumbnail DEGREES degrees."
2940 (declare (obsolete image-dired-refresh-thumb "29.1"))
2941 (image-dired--check-executable-exists
2942 'image-dired-cmd-rotate-thumbnail-program)
2943 (if (not (image-dired-image-at-point-p))
2944 (message "No thumbnail at point")
2945 (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
2946 (thumb (expand-file-name file))
2947 (spec (list (cons ?d degrees) (cons ?t thumb))))
2948 (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil
2949 (mapcar (lambda (arg) (format-spec arg spec))
2950 image-dired-cmd-rotate-thumbnail-options))
2951 (clear-image-cache thumb))))
2952
2953(defun image-dired-rotate-thumbnail-left ()
2954 "Rotate thumbnail left (counter clockwise) 90 degrees."
2955 (declare (obsolete image-dired-refresh-thumb "29.1"))
2956 (interactive)
2957 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2958 (image-dired-rotate-thumbnail "270")))
2959
2960(defun image-dired-rotate-thumbnail-right ()
2961 "Rotate thumbnail counter right (clockwise) 90 degrees."
2962 (declare (obsolete image-dired-refresh-thumb "29.1"))
2963 (interactive)
2964 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2965 (image-dired-rotate-thumbnail "90")))
2966
2967(defun image-dired-modify-mark-on-thumb-original-file (command)
2968 "Modify mark in Dired buffer.
2969COMMAND is one of `mark' for marking file in Dired, `unmark' for
2970unmarking file in Dired or `flag' for flagging file for delete in
2971Dired."
2972 (declare (obsolete image-dired--on-file-in-dired-buffer "29.1"))
2973 (let ((file-name (image-dired-original-file-name))
2974 (dired-buf (image-dired-associated-dired-buffer)))
2975 (if (not (and dired-buf file-name))
2976 (message "No image, or image with correct properties, at point")
2977 (with-current-buffer dired-buf
2978 (message "%s" file-name)
2979 (when (dired-goto-file file-name)
2980 (cond ((eq command 'mark) (dired-mark 1))
2981 ((eq command 'unmark) (dired-unmark 1))
2982 ((eq command 'toggle)
2983 (if (image-dired-dired-file-marked-p)
2984 (dired-unmark 1)
2985 (dired-mark 1)))
2986 ((eq command 'flag) (dired-flag-file-deletion 1)))
2987 (image-dired-thumb-update-marks))))))
2988
2989(defun image-dired-display-current-image-full ()
2990 "Display current image in full size."
2991 (declare (obsolete image-transform-original "29.1"))
2992 (interactive nil image-dired-thumbnail-mode)
2993 (let ((file (image-dired-original-file-name)))
2994 (if file
2995 (progn
2996 (image-dired-display-image file)
2997 (with-current-buffer image-dired-display-image-buffer
2998 (image-transform-original)))
2999 (error "No original file name at point"))))
3000
3001(defun image-dired-display-current-image-sized ()
3002 "Display current image in sized to fit window dimensions."
3003 (declare (obsolete image-mode-fit-frame "29.1"))
3004 (interactive nil image-dired-thumbnail-mode)
3005 (let ((file (image-dired-original-file-name)))
3006 (if file
3007 (progn
3008 (image-dired-display-image file))
3009 (error "No original file name at point"))))
3010
3011(defun image-dired-add-to-tag-file-list (tag file)
3012 "Add relation between TAG and FILE."
3013 (declare (obsolete nil "29.1"))
3014 (let (curr)
3015 (if image-dired-tag-file-list
3016 (if (setq curr (assoc tag image-dired-tag-file-list))
3017 (if (not (member file curr))
3018 (setcdr curr (cons file (cdr curr))))
3019 (setcdr image-dired-tag-file-list
3020 (cons (list tag file) (cdr image-dired-tag-file-list))))
3021 (setq image-dired-tag-file-list (list (list tag file))))))
3022
3023(defun image-dired-display-thumb-properties ()
3024 "Display thumbnail properties in the echo area."
3025 (declare (obsolete image-dired-update-header-line "29.1"))
3026 (image-dired-update-header-line))
3027
3028(defvar image-dired-slideshow-count 0
3029 "Keeping track on number of images in slideshow.")
3030(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1")
3031
3032(defvar image-dired-slideshow-times 0
3033 "Number of pictures to display in slideshow.")
3034(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1")
3035
3036(define-obsolete-function-alias 'image-dired-create-display-image-buffer
3037 #'ignore "29.1")
3038(define-obsolete-function-alias 'image-dired-create-gallery-lists
3039 #'image-dired--create-gallery-lists "29.1")
3040(define-obsolete-function-alias 'image-dired-add-to-file-comment-list
3041 #'image-dired--add-to-file-comment-list "29.1")
3042(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists
3043 #'image-dired--add-to-tag-file-lists "29.1")
3044(define-obsolete-function-alias 'image-dired-hidden-p
3045 #'image-dired--hidden-p "29.1")
3046
3047;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3048;;;;;;;;; TEST-SECTION ;;;;;;;;;;;
3049;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3050
3051;; (defvar image-dired-dir-max-size 12300000)
3052
3053;; (defun image-dired-test-clean-old-files ()
3054;; "Clean `image-dired-dir' from old thumbnail files.
3055;; \"Oldness\" measured using last access time. If the total size of all
3056;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size',
3057;; old files are deleted until the max size is reached."
3058;; (let* ((files
3059;; (sort
3060;; (mapcar
3061;; (lambda (f)
3062;; (let ((fattribs (file-attributes f)))
3063;; `(,(file-attribute-access-time fattribs)
3064;; ,(file-attribute-size fattribs) ,f)))
3065;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$"))
3066;; ;; Sort function. Compare time between two files.
3067;; (lambda (l1 l2)
3068;; (time-less-p (car l1) (car l2)))))
3069;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files))))
3070;; (while (> dirsize image-dired-dir-max-size)
3071;; (y-or-n-p
3072;; (format "Size of thumbnail directory: %d, delete old file %s? "
3073;; dirsize (cadr (cdar files))))
3074;; (delete-file (cadr (cdar files)))
3075;; (setq dirsize (- dirsize (car (cdar files))))
3076;; (setq files (cdr files)))))
3077
3078(provide 'image-dired)
3079
3080;;; 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 @@
1;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*-
2
3;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
4
5;; Version: 0.4.11
6;; Keywords: multimedia
7;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; BACKGROUND
27;; ==========
28;;
29;; I needed a program to browse, organize and tag my pictures. I got
30;; tired of the old gallery program I used as it did not allow
31;; multi-file operations easily. Also, it put things out of my
32;; control. Image viewing programs I tested did not allow multi-file
33;; operations or did not do what I wanted it to.
34;;
35;; So, I got the idea to use the wonderful functionality of Emacs and
36;; `dired' to do it. It would allow me to do almost anything I wanted,
37;; which is basically just to browse all my pictures in an easy way,
38;; letting me manipulate and tag them in various ways. `dired' already
39;; provide all the file handling and navigation facilities; I only
40;; needed to add some functions to display the images.
41;;
42;; I briefly tried out thumbs.el, and although it seemed more
43;; powerful than this package, it did not work the way I wanted to. It
44;; was too slow to create thumbnails of all files in a directory (I
45;; currently keep all my 2000+ images in the same directory) and
46;; browsing the thumbnail buffer was slow too. image-dired.el will not
47;; create thumbnails until they are needed and the browsing is done
48;; quickly and easily in Dired. I copied a great deal of ideas and
49;; code from there though... :)
50;;
51;; `image-dired' stores the thumbnail files in `image-dired-dir'
52;; using the file name format ORIGNAME.thumb.ORIGEXT. For example
53;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for
54;; now just a plain text file with the following format:
55;;
56;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN
57;;
58;;
59;; PREREQUISITES
60;; =============
61;;
62;; * The GraphicsMagick or ImageMagick package; Image-Dired uses
63;; whichever is available.
64;;
65;; A) For GraphicsMagick, `gm' is used.
66;; Find it here: http://www.graphicsmagick.org/
67;;
68;; B) For ImageMagick, `convert' and `mogrify' are used.
69;; Find it here: https://www.imagemagick.org.
70;;
71;; * For non-lossy rotation of JPEG images, the JpegTRAN program is
72;; needed.
73;;
74;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is
75;; needed. It can be found here: https://exiftool.org/. This
76;; function is, among other things, used for writing comments to
77;; image files using `image-dired-thumbnail-set-image-description'.
78;;
79;;
80;; USAGE
81;; =====
82;;
83;; This information has been moved to the manual. Type `C-h r' to open
84;; the Emacs manual and go to the node Thumbnails by typing `g
85;; Image-Dired RET'.
86;;
87;; Quickstart: M-x image-dired RET DIRNAME RET
88;;
89;; where DIRNAME is a directory containing image files.
90;;
91;; LIMITATIONS
92;; ===========
93;;
94;; * Supports all image formats that Emacs and convert supports, but
95;; the thumbnails are hard-coded to JPEG or PNG format. It uses
96;; JPEG by default, but can optionally follow the Thumbnail Managing
97;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user
98;; option `image-dired-thumbnail-storage'.
99;;
100;; * WARNING: The "database" format used might be changed so keep a
101;; backup of `image-dired-db-file' when testing new versions.
102;;
103;; TODO
104;; ====
105;;
106;; * Investigate if it is possible to also write the tags to the image
107;; files.
108;;
109;; * From thumbs.el: Add an option for clean-up/max-size functionality
110;; for thumbnail directory.
111;;
112;; * From thumbs.el: Add setroot function.
113;;
114;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out
115;; which is best, saving old batch just before inserting new, or
116;; saving the current batch in the ring when inserting it. Adding
117;; it probably needs rewriting `image-dired-display-thumbs' to be more general.
118;;
119;; * Find some way of toggling on and off really nice keybindings in
120;; Dired (for example, using C-n or <down> instead of C-S-n).
121;; Richard suggested that we could keep C-t as prefix for
122;; image-dired commands as it is currently not used in Dired. He
123;; also suggested that `dired-next-line' and `dired-previous-line'
124;; figure out if image-dired is enabled in the current buffer and,
125;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line',
126;; respectively. Update: This is partly done; some bindings have
127;; now been added to Dired.
128;;
129;; * In some way keep track of buffers and windows and stuff so that
130;; it works as the user expects.
131;;
132;; * More/better documentation.
133
134;;; Code:
135
136(require 'dired)
137(require 'exif)
138(require 'image-mode)
139(require 'widget)
140(require 'xdg)
141
142(eval-when-compile
143 (require 'cl-lib)
144 (require 'wid-edit))
145
146
147;;; Customizable variables
148
149(defgroup image-dired nil
150 "Use Dired to browse your images as thumbnails, and more."
151 :prefix "image-dired-"
152 :link '(info-link "(emacs) Image-Dired")
153 :group 'multimedia)
154
155(defcustom image-dired-dir (locate-user-emacs-file "image-dired/")
156 "Directory where thumbnail images are stored.
157
158The value of this option will be ignored if Image-Dired is
159customized to use the Thumbnail Managing Standard; they will be
160saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See
161`image-dired-thumbnail-storage'."
162 :type 'directory)
163
164(defcustom image-dired-thumbnail-storage 'use-image-dired-dir
165 "How `image-dired' stores thumbnail files.
166There are two ways that Image-Dired can store and generate
167thumbnails. If you set this variable to one of the two following
168values, they will be stored in the JPEG format:
169
170- `use-image-dired-dir' means that the thumbnails are stored in a
171 central directory.
172
173- `per-directory' means that each thumbnail is stored in a
174 subdirectory called \".image-dired\" in the same directory
175 where the image file is.
176
177It can also use the \"Thumbnail Managing Standard\", which allows
178sharing of thumbnails across different programs. Thumbnails will
179be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in
180`image-dired-dir'. Thumbnails are saved in the PNG format, and
181can be one of the following sizes:
182
183- `standard' means use thumbnails sized 128x128.
184- `standard-large' means use thumbnails sized 256x256.
185- `standard-x-large' means use thumbnails sized 512x512.
186- `standard-xx-large' means use thumbnails sized 1024x1024.
187
188For more information on the Thumbnail Managing Standard, see:
189https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html"
190 :type '(choice :tag "How to store thumbnail files"
191 (const :tag "Use image-dired-dir" use-image-dired-dir)
192 (const :tag "Thumbnail Managing Standard (normal 128x128)"
193 standard)
194 (const :tag "Thumbnail Managing Standard (large 256x256)"
195 standard-large)
196 (const :tag "Thumbnail Managing Standard (larger 512x512)"
197 standard-x-large)
198 (const :tag "Thumbnail Managing Standard (extra large 1024x1024)"
199 standard-xx-large)
200 (const :tag "Per-directory" per-directory))
201 :version "29.1")
202
203(defconst image-dired--thumbnail-standard-sizes
204 '( standard standard-large
205 standard-x-large standard-xx-large)
206 "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
207
208(defcustom image-dired-db-file
209 (expand-file-name ".image-dired_db" image-dired-dir)
210 "Database file where file names and their associated tags are stored."
211 :type 'file)
212
213(defcustom image-dired-cmd-create-thumbnail-program
214 (if (executable-find "gm") "gm" "convert")
215 "Executable used to create thumbnail.
216Used together with `image-dired-cmd-create-thumbnail-options'."
217 :type 'file
218 :version "29.1")
219
220(defcustom image-dired-cmd-create-thumbnail-options
221 (let ((opts '("-size" "%wx%h" "%f[0]"
222 "-resize" "%wx%h>"
223 "-strip" "jpeg:%t")))
224 (if (executable-find "gm") (cons "convert" opts) opts))
225 "Options of command used to create thumbnail image.
226Used with `image-dired-cmd-create-thumbnail-program'.
227Available format specifiers are: %w which is replaced by
228`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
229%f which is replaced by the file name of the original image and %t
230which is replaced by the file name of the thumbnail file."
231 :version "29.1"
232 :type '(repeat (string :tag "Argument")))
233
234(defcustom image-dired-cmd-pngnq-program
235 ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
236 ;; The project also seems more active than the alternatives.
237 ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
238 ;; The pngnq project seems dead (?) since 2011 or so.
239 (or (executable-find "pngquant")
240 (executable-find "pngnq-s9")
241 (executable-find "pngnq"))
242 "The file name of the `pngquant' or `pngnq' program.
243It quantizes colors of PNG images down to 256 colors or fewer
244using the NeuQuant algorithm."
245 :version "29.1"
246 :type '(choice (const :tag "Not Set" nil) file))
247
248(defcustom image-dired-cmd-pngnq-options
249 (if (executable-find "pngquant")
250 '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
251 '("-f" "%t"))
252 "Arguments to pass `image-dired-cmd-pngnq-program'.
253Available format specifiers are the same as in
254`image-dired-cmd-create-thumbnail-options'."
255 :type '(repeat (string :tag "Argument"))
256 :version "29.1")
257
258(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
259 "The file name of the `pngcrush' program.
260It optimizes the compression of PNG images. Also it adds PNG textual chunks
261with the information required by the Thumbnail Managing Standard."
262 :type '(choice (const :tag "Not Set" nil) file))
263
264(defcustom image-dired-cmd-pngcrush-options
265 `("-q"
266 "-text" "b" "Description" "Thumbnail of file://%f"
267 "-text" "b" "Software" ,(emacs-version)
268 ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
269 ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
270 ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
271 "-text" "b" "Thumb::MTime" "%m"
272 ;; "-text b \"Thumb::Size\" \"%b\" "
273 "-text" "b" "Thumb::URI" "file://%f"
274 "%q" "%t")
275 "Arguments for `image-dired-cmd-pngcrush-program'.
276Available format specifiers are the same as in
277`image-dired-cmd-create-thumbnail-options', with %q for a
278temporary file name (typically generated by pnqnq)."
279 :version "26.1"
280 :type '(repeat (string :tag "Argument")))
281
282(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
283 "The file name of the `optipng' program."
284 :version "26.1"
285 :type '(choice (const :tag "Not Set" nil) file))
286
287(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
288 "Arguments passed to `image-dired-cmd-optipng-program'.
289Available format specifiers are described in
290`image-dired-cmd-create-thumbnail-options'."
291 :version "26.1"
292 :type '(repeat (string :tag "Argument"))
293 :link '(url-link "man:optipng(1)"))
294
295(defcustom image-dired-cmd-create-standard-thumbnail-options
296 (append '("-size" "%wx%h" "%f[0]")
297 (unless (or image-dired-cmd-pngcrush-program
298 image-dired-cmd-pngnq-program)
299 (list
300 "-set" "Thumb::MTime" "%m"
301 "-set" "Thumb::URI" "file://%f"
302 "-set" "Description" "Thumbnail of file://%f"
303 "-set" "Software" (emacs-version)))
304 '("-thumbnail" "%wx%h>" "png:%t"))
305 "Options for creating thumbnails according to the Thumbnail Managing Standard.
306Available format specifiers are the same as in
307`image-dired-cmd-create-thumbnail-options', with %m for file modification time."
308 :version "26.1"
309 :type '(repeat (string :tag "Argument")))
310
311(defcustom image-dired-cmd-rotate-original-program
312 "jpegtran"
313 "Executable used to rotate original image.
314Used together with `image-dired-cmd-rotate-original-options'."
315 :type 'file)
316
317(defcustom image-dired-cmd-rotate-original-options
318 '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
319 "Arguments of command used to rotate original image.
320Used with `image-dired-cmd-rotate-original-program'.
321Available format specifiers are: %d which is replaced by the
322number of (positive) degrees to rotate the image, normally 90 or
323270 \(for 90 degrees right and left), %o which is replaced by the
324original image file name and %t which is replaced by
325`image-dired-temp-image-file'."
326 :version "26.1"
327 :type '(repeat (string :tag "Argument")))
328
329(defcustom image-dired-temp-rotate-image-file
330 (expand-file-name ".image-dired_rotate_temp" image-dired-dir)
331 "Temporary file for rotate operations."
332 :type 'file)
333
334(defcustom image-dired-rotate-original-ask-before-overwrite t
335 "Confirm overwrite of original file after rotate operation.
336If non-nil, ask user for confirmation before overwriting the
337original file with `image-dired-temp-rotate-image-file'."
338 :type 'boolean)
339
340(defcustom image-dired-cmd-write-exif-data-program
341 "exiftool"
342 "Program used to write EXIF data to image.
343Used together with `image-dired-cmd-write-exif-data-options'."
344 :type 'file)
345
346(defcustom image-dired-cmd-write-exif-data-options
347 '("-%t=%v" "%f")
348 "Arguments of command used to write EXIF data.
349Used with `image-dired-cmd-write-exif-data-program'.
350Available format specifiers are: %f which is replaced by
351the image file name, %t which is replaced by the tag name and %v
352which is replaced by the tag value."
353 :version "26.1"
354 :type '(repeat (string :tag "Argument")))
355
356(defcustom image-dired-thumb-size
357 (cond
358 ((eq 'standard image-dired-thumbnail-storage) 128)
359 ((eq 'standard-large image-dired-thumbnail-storage) 256)
360 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
361 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
362 (t 100))
363 "Size of thumbnails, in pixels.
364This is the default size for both `image-dired-thumb-width'
365and `image-dired-thumb-height'.
366
367The value of this option will be ignored if Image-Dired is
368customized to use the Thumbnail Managing Standard; the standard
369sizes will be used instead. See `image-dired-thumbnail-storage'."
370 :type 'integer)
371
372(defcustom image-dired-thumb-width image-dired-thumb-size
373 "Width of thumbnails, in pixels."
374 :type 'integer)
375
376(defcustom image-dired-thumb-height image-dired-thumb-size
377 "Height of thumbnails, in pixels."
378 :type 'integer)
379
380(defcustom image-dired-thumb-relief 2
381 "Size of button-like border around thumbnails."
382 :type 'integer)
383
384(defcustom image-dired-thumb-margin 2
385 "Size of the margin around thumbnails.
386This is where you see the cursor."
387 :type 'integer)
388
389(defcustom image-dired-thumb-visible-marks t
390 "Make marks and flags visible in thumbnail buffer.
391If non-nil, apply the `image-dired-thumb-mark' face to marked
392images and `image-dired-thumb-flagged' to images flagged for
393deletion."
394 :type 'boolean
395 :version "28.1")
396
397(defface image-dired-thumb-mark
398 '((((class color) (min-colors 16)) :background "DarkOrange")
399 (((class color)) :foreground "yellow"))
400 "Face for marked images in thumbnail buffer."
401 :version "29.1")
402
403(defface image-dired-thumb-flagged
404 '((((class color) (min-colors 88) (background light)) :background "Red3")
405 (((class color) (min-colors 88) (background dark)) :background "Pink")
406 (((class color) (min-colors 16) (background light)) :background "Red3")
407 (((class color) (min-colors 16) (background dark)) :background "Pink")
408 (((class color) (min-colors 8)) :background "red")
409 (t :inverse-video t))
410 "Face for images flagged for deletion in thumbnail buffer."
411 :version "29.1")
412
413(defcustom image-dired-line-up-method 'dynamic
414 "Default method for line-up of thumbnails in thumbnail buffer.
415Used by `image-dired-display-thumbs' and other functions that needs
416to line-up thumbnails. Dynamic means to use the available width of
417the window containing the thumbnail buffer, Fixed means to use
418`image-dired-thumbs-per-row', Interactive is for asking the user,
419and No line-up means that no automatic line-up will be done."
420 :type '(choice :tag "Default line-up method"
421 (const :tag "Dynamic" dynamic)
422 (const :tag "Fixed" fixed)
423 (const :tag "Interactive" interactive)
424 (const :tag "No line-up" none)))
425
426(defcustom image-dired-thumbs-per-row 3
427 "Number of thumbnails to display per row in thumb buffer."
428 :type 'integer)
429
430(defcustom image-dired-track-movement t
431 "The current state of the tracking and mirroring.
432For more information, see the documentation for
433`image-dired-toggle-movement-tracking'."
434 :type 'boolean)
435
436(defcustom image-dired-append-when-browsing nil
437 "Append thumbnails in thumbnail buffer when browsing.
438If non-nil, using `image-dired-next-line-and-display' and
439`image-dired-previous-line-and-display' will leave a trail of thumbnail
440images in the thumbnail buffer. If you enable this and want to clean
441the thumbnail buffer because it is filled with too many thumbnails,
442just call `image-dired-display-thumb' to display only the image at point.
443This value can be toggled using `image-dired-toggle-append-browsing'."
444 :type 'boolean)
445
446(defcustom image-dired-dired-disp-props t
447 "If non-nil, display properties for Dired file when browsing.
448Used by `image-dired-next-line-and-display',
449`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'.
450If the database file is large, this can slow down image browsing in
451Dired and you might want to turn it off."
452 :type 'boolean)
453
454(defcustom image-dired-display-properties-format "%b: %f (%t): %c"
455 "Display format for thumbnail properties.
456%b is replaced with associated Dired buffer name, %f with file
457name (without path) of original image file, %t with the list of
458tags and %c with the comment."
459 :type 'string)
460
461(defcustom image-dired-external-viewer
462 ;; TODO: Use mailcap, dired-guess-shell-alist-default,
463 ;; dired-view-command-alist.
464 (cond ((executable-find "display"))
465 ((executable-find "xli"))
466 ((executable-find "qiv") "qiv -t")
467 ((executable-find "feh") "feh"))
468 "Name of external viewer.
469Including parameters. Used when displaying original image from
470`image-dired-thumbnail-mode'."
471 :version "28.1"
472 :type '(choice string
473 (const :tag "Not Set" nil)))
474
475(defcustom image-dired-main-image-directory
476 (or (xdg-user-dir "PICTURES") "~/pics/")
477 "Name of main image directory, if any.
478Used by `image-dired-copy-with-exif-file-name'."
479 :type 'string
480 :version "29.1")
481
482(defcustom image-dired-show-all-from-dir-max-files 500
483 "Maximum number of files in directory before prompting.
484
485If there are more image files than this in a selected directory,
486the `image-dired-show-all-from-dir' command will ask for
487confirmation before creating the thumbnail buffer. If this
488variable is nil, it will never ask."
489 :type '(choice integer
490 (const :tag "Disable warning" nil))
491 :version "29.1")
492
493(defcustom image-dired-marking-shows-next t
494 "If non-nil, marking, unmarking or flagging an image shows the next image.
495
496This affects the following commands:
497\\<image-dired-thumbnail-mode-map>
498 `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file])
499 `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file])
500 `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])"
501 :type 'boolean
502 :version "29.1")
503
504
505;;; Util functions
506
507(defvar image-dired-debug nil
508 "Non-nil means enable debug messages.")
509
510(defun image-dired-debug-message (&rest args)
511 "Display debug message ARGS when `image-dired-debug' is non-nil."
512 (when image-dired-debug
513 (apply #'message args)))
514
515(defmacro image-dired--with-db-file (&rest body)
516 "Run BODY in a temp buffer containing `image-dired-db-file'.
517Return the last form in BODY."
518 (declare (indent 0) (debug t))
519 `(with-temp-buffer
520 (if (file-exists-p image-dired-db-file)
521 (insert-file-contents image-dired-db-file))
522 ,@body))
523
524(defun image-dired-dir ()
525 "Return the current thumbnail directory (from variable `image-dired-dir').
526Create the thumbnail directory if it does not exist."
527 (let ((image-dired-dir (file-name-as-directory
528 (expand-file-name image-dired-dir))))
529 (unless (file-directory-p image-dired-dir)
530 (with-file-modes #o700
531 (make-directory image-dired-dir t))
532 (message "Thumbnail directory created: %s" image-dired-dir))
533 image-dired-dir))
534
535(defun image-dired-insert-image (file type relief margin)
536 "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point."
537 (let ((i `(image :type ,type
538 :file ,file
539 :relief ,relief
540 :margin ,margin)))
541 (insert-image i)))
542
543(defun image-dired-get-thumbnail-image (file)
544 "Return the image descriptor for a thumbnail of image file FILE."
545 (unless (string-match-p (image-file-name-regexp) file)
546 (error "%s is not a valid image file" file))
547 (let* ((thumb-file (image-dired-thumb-name file))
548 (thumb-attr (file-attributes thumb-file)))
549 (when (or (not thumb-attr)
550 (time-less-p (file-attribute-modification-time thumb-attr)
551 (file-attribute-modification-time
552 (file-attributes file))))
553 (image-dired-create-thumb file thumb-file))
554 (create-image thumb-file)))
555
556(defun image-dired-insert-thumbnail (file original-file-name
557 associated-dired-buffer)
558 "Insert thumbnail image FILE.
559Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
560 (let (beg end)
561 (setq beg (point))
562 (image-dired-insert-image
563 file
564 ;; Thumbnails are created asynchronously, so we might not yet
565 ;; have a file. But if it exists, it might have been cached from
566 ;; before and we should use it instead of our current settings.
567 (or (and (file-exists-p file)
568 (image-type-from-file-header file))
569 (and (memq image-dired-thumbnail-storage
570 image-dired--thumbnail-standard-sizes)
571 'png)
572 'jpeg)
573 image-dired-thumb-relief
574 image-dired-thumb-margin)
575 (setq end (point))
576 (add-text-properties
577 beg end
578 (list 'image-dired-thumbnail t
579 'original-file-name original-file-name
580 'associated-dired-buffer associated-dired-buffer
581 'tags (image-dired-list-tags original-file-name)
582 'mouse-face 'highlight
583 'comment (image-dired-get-comment original-file-name)))))
584
585(defun image-dired-thumb-name (file)
586 "Return absolute file name for thumbnail FILE.
587Depending on the value of `image-dired-thumbnail-storage', the
588file name of the thumbnail will vary:
589- For `use-image-dired-dir', make a SHA1-hash of the image file's
590 directory name and add that to make the thumbnail file name
591 unique.
592- For `per-directory' storage, just add a subdirectory.
593- For `standard' storage, produce the file name according to the
594 Thumbnail Managing Standard. Among other things, an MD5-hash
595 of the image file's directory name will be added to the
596 filename.
597See also `image-dired-thumbnail-storage'."
598 (cond ((memq image-dired-thumbnail-storage
599 image-dired--thumbnail-standard-sizes)
600 (let ((thumbdir (cl-case image-dired-thumbnail-storage
601 (standard "thumbnails/normal")
602 (standard-large "thumbnails/large")
603 (standard-x-large "thumbnails/x-large")
604 (standard-xx-large "thumbnails/xx-large"))))
605 (expand-file-name
606 ;; MD5 is mandated by the Thumbnail Managing Standard.
607 (concat (md5 (concat "file://" (expand-file-name file))) ".png")
608 (expand-file-name thumbdir (xdg-cache-home)))))
609 ((eq 'use-image-dired-dir image-dired-thumbnail-storage)
610 (let* ((f (expand-file-name file))
611 (hash
612 (md5 (file-name-as-directory (file-name-directory f)))))
613 (format "%s%s%s.thumb.%s"
614 (file-name-as-directory (expand-file-name (image-dired-dir)))
615 (file-name-base f)
616 (if hash (concat "_" hash) "")
617 (file-name-extension f))))
618 ((eq 'per-directory image-dired-thumbnail-storage)
619 (let ((f (expand-file-name file)))
620 (format "%s.image-dired/%s.thumb.%s"
621 (file-name-directory f)
622 (file-name-base f)
623 (file-name-extension f))))))
624
625(defun image-dired--check-executable-exists (executable)
626 (unless (executable-find (symbol-value executable))
627 (error "Executable %S not found" executable)))
628
629
630;;; Creating thumbnails
631
632(defun image-dired-thumb-size (dimension)
633 "Return thumb size depending on `image-dired-thumbnail-storage'.
634DIMENSION should be either the symbol `width' or `height'."
635 (cond
636 ((eq 'standard image-dired-thumbnail-storage) 128)
637 ((eq 'standard-large image-dired-thumbnail-storage) 256)
638 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
639 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
640 (t (cl-ecase dimension
641 (width image-dired-thumb-width)
642 (height image-dired-thumb-height)))))
643
644(defvar image-dired--generate-thumbs-start nil
645 "Time when `display-thumbs' was called.")
646
647(defvar image-dired-queue nil
648 "List of items in the queue.
649Each item has the form (ORIGINAL-FILE TARGET-FILE).")
650
651(defvar image-dired-queue-active-jobs 0
652 "Number of active jobs in `image-dired-queue'.")
653
654(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
655 "Maximum number of concurrent jobs permitted for generating images.
656Increase at own risk. If you want to experiment with this,
657consider setting `image-dired-debug' to a non-nil value to see
658the time spent on generating thumbnails. Run `image-clear-cache'
659and remove the cached thumbnail files between each trial run.")
660
661(defun image-dired-pngnq-thumb (spec)
662 "Quantize thumbnail described by format SPEC with pngnq(1)."
663 (let ((process
664 (apply #'start-process "image-dired-pngnq" nil
665 image-dired-cmd-pngnq-program
666 (mapcar (lambda (arg) (format-spec arg spec))
667 image-dired-cmd-pngnq-options))))
668 (setf (process-sentinel process)
669 (lambda (process status)
670 (if (and (eq (process-status process) 'exit)
671 (zerop (process-exit-status process)))
672 ;; Pass off to pngcrush, or just rename the
673 ;; THUMB-nq8.png file back to THUMB.png
674 (if (and image-dired-cmd-pngcrush-program
675 (executable-find image-dired-cmd-pngcrush-program))
676 (image-dired-pngcrush-thumb spec)
677 (let ((nq8 (cdr (assq ?q spec)))
678 (thumb (cdr (assq ?t spec))))
679 (rename-file nq8 thumb t)))
680 (message "command %S %s" (process-command process)
681 (string-replace "\n" "" status)))))
682 process))
683
684(defun image-dired-pngcrush-thumb (spec)
685 "Optimize thumbnail described by format SPEC with pngcrush(1)."
686 ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
687 ;; pngcrush needs an infile and outfile, so we just copy THUMB to
688 ;; THUMB-nq8.png and use the latter as a temp file.
689 (when (not image-dired-cmd-pngnq-program)
690 (let ((temp (cdr (assq ?q spec)))
691 (thumb (cdr (assq ?t spec))))
692 (copy-file thumb temp)))
693 (let ((process
694 (apply #'start-process "image-dired-pngcrush" nil
695 image-dired-cmd-pngcrush-program
696 (mapcar (lambda (arg) (format-spec arg spec))
697 image-dired-cmd-pngcrush-options))))
698 (setf (process-sentinel process)
699 (lambda (process status)
700 (unless (and (eq (process-status process) 'exit)
701 (zerop (process-exit-status process)))
702 (message "command %S %s" (process-command process)
703 (string-replace "\n" "" status)))
704 (when (memq (process-status process) '(exit signal))
705 (let ((temp (cdr (assq ?q spec))))
706 (delete-file temp)))))
707 process))
708
709(defun image-dired-optipng-thumb (spec)
710 "Optimize thumbnail described by format SPEC with optipng(1)."
711 (let ((process
712 (apply #'start-process "image-dired-optipng" nil
713 image-dired-cmd-optipng-program
714 (mapcar (lambda (arg) (format-spec arg spec))
715 image-dired-cmd-optipng-options))))
716 (setf (process-sentinel process)
717 (lambda (process status)
718 (unless (and (eq (process-status process) 'exit)
719 (zerop (process-exit-status process)))
720 (message "command %S %s" (process-command process)
721 (string-replace "\n" "" status)))))
722 process))
723
724(defun image-dired-create-thumb-1 (original-file thumbnail-file)
725 "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
726 (image-dired--check-executable-exists
727 'image-dired-cmd-create-thumbnail-program)
728 (let* ((width (int-to-string (image-dired-thumb-size 'width)))
729 (height (int-to-string (image-dired-thumb-size 'height)))
730 (modif-time (format-time-string
731 "%s" (file-attribute-modification-time
732 (file-attributes original-file))))
733 (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
734 thumbnail-file))
735 (spec
736 (list
737 (cons ?w width)
738 (cons ?h height)
739 (cons ?m modif-time)
740 (cons ?f original-file)
741 (cons ?q thumbnail-nq8-file)
742 (cons ?t thumbnail-file)))
743 (thumbnail-dir (file-name-directory thumbnail-file))
744 process)
745 (when (not (file-exists-p thumbnail-dir))
746 (with-file-modes #o700
747 (make-directory thumbnail-dir t))
748 (message "Thumbnail directory created: %s" thumbnail-dir))
749
750 ;; Thumbnail file creation processes begin here and are marshaled
751 ;; in a queue by `image-dired-create-thumb'.
752 (setq process
753 (apply #'start-process "image-dired-create-thumbnail" nil
754 image-dired-cmd-create-thumbnail-program
755 (mapcar
756 (lambda (arg) (format-spec arg spec))
757 (if (memq image-dired-thumbnail-storage
758 image-dired--thumbnail-standard-sizes)
759 image-dired-cmd-create-standard-thumbnail-options
760 image-dired-cmd-create-thumbnail-options))))
761
762 (setf (process-sentinel process)
763 (lambda (process status)
764 ;; Trigger next in queue once a thumbnail has been created
765 (cl-decf image-dired-queue-active-jobs)
766 (image-dired-thumb-queue-run)
767 (when (= image-dired-queue-active-jobs 0)
768 (image-dired-debug-message
769 (format-time-string
770 "Generated thumbnails in %s.%3N seconds"
771 (time-subtract nil
772 image-dired--generate-thumbs-start))))
773 (if (not (and (eq (process-status process) 'exit)
774 (zerop (process-exit-status process))))
775 (message "Thumb could not be created for %s: %s"
776 (abbreviate-file-name original-file)
777 (string-replace "\n" "" status))
778 (set-file-modes thumbnail-file #o600)
779 (clear-image-cache thumbnail-file)
780 ;; PNG thumbnail has been created since we are
781 ;; following the XDG thumbnail spec, so try to optimize
782 (when (memq image-dired-thumbnail-storage
783 image-dired--thumbnail-standard-sizes)
784 (cond
785 ((and image-dired-cmd-pngnq-program
786 (executable-find image-dired-cmd-pngnq-program))
787 (image-dired-pngnq-thumb spec))
788 ((and image-dired-cmd-pngcrush-program
789 (executable-find image-dired-cmd-pngcrush-program))
790 (image-dired-pngcrush-thumb spec))
791 ((and image-dired-cmd-optipng-program
792 (executable-find image-dired-cmd-optipng-program))
793 (image-dired-optipng-thumb spec)))))))
794 process))
795
796(defun image-dired-thumb-queue-run ()
797 "Run a queued job if one exists and not too many jobs are running.
798Queued items live in `image-dired-queue'."
799 (while (and image-dired-queue
800 (< image-dired-queue-active-jobs
801 image-dired-queue-active-limit))
802 (cl-incf image-dired-queue-active-jobs)
803 (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
804
805(defun image-dired-create-thumb (original-file thumbnail-file)
806 "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'.
807The new file will be named THUMBNAIL-FILE."
808 (setq image-dired-queue
809 (nconc image-dired-queue
810 (list (list original-file thumbnail-file))))
811 (run-at-time 0 nil #'image-dired-thumb-queue-run))
812
813(defmacro image-dired--with-marked (&rest body)
814 "Eval BODY with point on each marked thumbnail.
815If no marked file could be found, execute BODY on the current
816thumbnail."
817 `(with-current-buffer image-dired-thumbnail-buffer
818 (let (found)
819 (save-mark-and-excursion
820 (goto-char (point-min))
821 (while (not (eobp))
822 (when (image-dired-thumb-file-marked-p)
823 (setq found t)
824 ,@body)
825 (forward-char)))
826 (unless found
827 ,@body))))
828
829;;;###autoload
830(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
831 "Toggle thumbnails in front of file names in the Dired buffer.
832If no marked file could be found, insert or hide thumbnails on the
833current line. ARG, if non-nil, specifies the files to use instead
834of the marked files. If ARG is an integer, use the next ARG (or
835previous -ARG, if ARG<0) files."
836 (interactive "P")
837 (dired-map-over-marks
838 (let ((image-pos (dired-move-to-filename))
839 (image-file (dired-get-filename nil t))
840 thumb-file
841 overlay)
842 (when (and image-file
843 (string-match-p (image-file-name-regexp) image-file))
844 (setq thumb-file (image-dired-get-thumbnail-image image-file))
845 ;; If image is not already added, then add it.
846 (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
847 if (overlay-get ov 'thumb-file) return ov)))
848 (if thumb-ov
849 (delete-overlay thumb-ov)
850 (put-image thumb-file image-pos)
851 (setq overlay
852 (cl-loop for ov in (overlays-in (point) (1+ (point)))
853 if (overlay-get ov 'put-image) return ov))
854 (overlay-put overlay 'image-file image-file)
855 (overlay-put overlay 'thumb-file thumb-file)))))
856 arg ; Show or hide image on ARG next files.
857 'show-progress) ; Update dired display after each image is updated.
858 (add-hook 'dired-after-readin-hook
859 'image-dired-dired-after-readin-hook nil t))
860
861(defun image-dired-dired-after-readin-hook ()
862 "Relocate existing thumbnail overlays in Dired buffer after reverting.
863Move them to their corresponding files if they still exist.
864Otherwise, delete overlays."
865 (mapc (lambda (overlay)
866 (when (overlay-get overlay 'put-image)
867 (let* ((image-file (overlay-get overlay 'image-file))
868 (image-pos (dired-goto-file image-file)))
869 (if image-pos
870 (move-overlay overlay image-pos image-pos)
871 (delete-overlay overlay)))))
872 (overlays-in (point-min) (point-max))))
873
874(defun image-dired-next-line-and-display ()
875 "Move to next Dired line and display thumbnail image."
876 (interactive)
877 (dired-next-line 1)
878 (image-dired-display-thumbs
879 t (or image-dired-append-when-browsing nil) t)
880 (if image-dired-dired-disp-props
881 (image-dired-dired-display-properties)))
882
883(defun image-dired-previous-line-and-display ()
884 "Move to previous Dired line and display thumbnail image."
885 (interactive)
886 (dired-previous-line 1)
887 (image-dired-display-thumbs
888 t (or image-dired-append-when-browsing nil) t)
889 (if image-dired-dired-disp-props
890 (image-dired-dired-display-properties)))
891
892(defun image-dired-toggle-append-browsing ()
893 "Toggle `image-dired-append-when-browsing'."
894 (interactive)
895 (setq image-dired-append-when-browsing
896 (not image-dired-append-when-browsing))
897 (message "Append browsing %s"
898 (if image-dired-append-when-browsing
899 "on"
900 "off")))
901
902(defun image-dired-mark-and-display-next ()
903 "Mark current file in Dired and display next thumbnail image."
904 (interactive)
905 (dired-mark 1)
906 (image-dired-display-thumbs
907 t (or image-dired-append-when-browsing nil) t)
908 (if image-dired-dired-disp-props
909 (image-dired-dired-display-properties)))
910
911(defun image-dired-toggle-dired-display-properties ()
912 "Toggle `image-dired-dired-disp-props'."
913 (interactive)
914 (setq image-dired-dired-disp-props
915 (not image-dired-dired-disp-props))
916 (message "Dired display properties %s"
917 (if image-dired-dired-disp-props
918 "on"
919 "off")))
920
921(defvar image-dired-thumbnail-buffer "*image-dired*"
922 "Image-Dired's thumbnail buffer.")
923
924(defun image-dired-create-thumbnail-buffer ()
925 "Create thumb buffer and set `image-dired-thumbnail-mode'."
926 (let ((buf (get-buffer-create image-dired-thumbnail-buffer)))
927 (with-current-buffer buf
928 (setq buffer-read-only t)
929 (if (not (eq major-mode 'image-dired-thumbnail-mode))
930 (image-dired-thumbnail-mode)))
931 buf))
932
933(defvar image-dired-display-image-buffer "*image-dired-display-image*"
934 "Where larger versions of the images are display.")
935
936(defvar image-dired-saved-window-configuration nil
937 "Saved window configuration.")
938
939;;;###autoload
940(defun image-dired-dired-with-window-configuration (dir &optional arg)
941 "Open directory DIR and create a default window configuration.
942
943Convenience command that:
944
945 - Opens Dired in folder DIR
946 - Splits windows in most useful (?) way
947 - Sets `truncate-lines' to t
948
949After the command has finished, you would typically mark some
950image files in Dired and type
951\\[image-dired-display-thumbs] (`image-dired-display-thumbs').
952
953If called with prefix argument ARG, skip splitting of windows.
954
955The current window configuration is saved and can be restored by
956calling `image-dired-restore-window-configuration'."
957 (interactive "DDirectory: \nP")
958 (let ((buf (image-dired-create-thumbnail-buffer))
959 (buf2 (get-buffer-create image-dired-display-image-buffer)))
960 (setq image-dired-saved-window-configuration
961 (current-window-configuration))
962 (dired dir)
963 (delete-other-windows)
964 (when (not arg)
965 (split-window-right)
966 (setq truncate-lines t)
967 (save-excursion
968 (other-window 1)
969 (pop-to-buffer-same-window buf)
970 (select-window (split-window-below))
971 (pop-to-buffer-same-window buf2)
972 (other-window -2)))))
973
974(defun image-dired-restore-window-configuration ()
975 "Restore window configuration.
976Restore any changes to the window configuration made by calling
977`image-dired-dired-with-window-configuration'."
978 (interactive nil image-dired-thumbnail-mode)
979 (if image-dired-saved-window-configuration
980 (set-window-configuration image-dired-saved-window-configuration)
981 (message "No saved window configuration")))
982
983(defun image-dired--line-up-with-method ()
984 "Line up thumbnails according to `image-dired-line-up-method'."
985 (cond ((eq 'dynamic image-dired-line-up-method)
986 (image-dired-line-up-dynamic))
987 ((eq 'fixed image-dired-line-up-method)
988 (image-dired-line-up))
989 ((eq 'interactive image-dired-line-up-method)
990 (image-dired-line-up-interactive))
991 ((eq 'none image-dired-line-up-method)
992 nil)
993 (t
994 (image-dired-line-up-dynamic))))
995
996;;;###autoload
997(defun image-dired-display-thumbs (&optional arg append do-not-pop)
998 "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'.
999If a thumbnail image does not exist for a file, it is created on the
1000fly. With prefix argument ARG, display only thumbnail for file at
1001point (this is useful if you have marked some files but want to show
1002another one).
1003
1004Recommended usage is to split the current frame horizontally so that
1005you have the Dired buffer in the left window and the
1006`image-dired-thumbnail-buffer' buffer in the right window.
1007
1008With optional argument APPEND, append thumbnail to thumbnail buffer
1009instead of erasing it first.
1010
1011Optional argument DO-NOT-POP controls if `pop-to-buffer' should be
1012used or not. If non-nil, use `display-buffer' instead of
1013`pop-to-buffer'. This is used from functions like
1014`image-dired-next-line-and-display' and
1015`image-dired-previous-line-and-display' where we do not want the
1016thumbnail buffer to be selected."
1017 (interactive "P")
1018 (setq image-dired--generate-thumbs-start (current-time))
1019 (let ((buf (image-dired-create-thumbnail-buffer))
1020 thumb-name files dired-buf)
1021 (if arg
1022 (setq files (list (dired-get-filename)))
1023 (setq files (dired-get-marked-files)))
1024 (setq dired-buf (current-buffer))
1025 (with-current-buffer buf
1026 (let ((inhibit-read-only t))
1027 (if (not append)
1028 (erase-buffer)
1029 (goto-char (point-max)))
1030 (dolist (curr-file files)
1031 (setq thumb-name (image-dired-thumb-name curr-file))
1032 (when (not (file-exists-p thumb-name))
1033 (image-dired-create-thumb curr-file thumb-name))
1034 (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
1035 (if do-not-pop
1036 (display-buffer buf)
1037 (pop-to-buffer buf))
1038 (image-dired--line-up-with-method))))
1039
1040;;;###autoload
1041(defun image-dired-show-all-from-dir (dir)
1042 "Make a thumbnail buffer for all images in DIR and display it.
1043Any file matching `image-file-name-regexp' is considered an image
1044file.
1045
1046If the number of image files in DIR exceeds
1047`image-dired-show-all-from-dir-max-files', ask for confirmation
1048before creating the thumbnail buffer. If that variable is nil,
1049never ask for confirmation."
1050 (interactive "DImage-Dired: ")
1051 (dired dir)
1052 (dired-mark-files-regexp (image-file-name-regexp))
1053 (let ((files (dired-get-marked-files nil nil nil t)))
1054 (cond ((and (null (cdr files)))
1055 (message "No image files in directory"))
1056 ((or (not image-dired-show-all-from-dir-max-files)
1057 (<= (length (cdr files)) image-dired-show-all-from-dir-max-files)
1058 (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files)
1059 (y-or-n-p
1060 (format
1061 "Directory contains more than %d image files. Proceed?"
1062 image-dired-show-all-from-dir-max-files))))
1063 (image-dired-display-thumbs)
1064 (pop-to-buffer image-dired-thumbnail-buffer)
1065 (setq default-directory dir)
1066 (image-dired-unmark-all-marks))
1067 (t (message "Image-Dired canceled")))))
1068
1069;;;###autoload
1070(defalias 'image-dired 'image-dired-show-all-from-dir)
1071
1072
1073;;; Tags
1074
1075(defun image-dired-sane-db-file ()
1076 "Check if `image-dired-db-file' exists.
1077If not, try to create it (including any parent directories).
1078Signal error if there are problems creating it."
1079 (or (file-exists-p image-dired-db-file)
1080 (let (dir buf)
1081 (unless (file-directory-p (setq dir (file-name-directory
1082 image-dired-db-file)))
1083 (with-file-modes #o700
1084 (make-directory dir t)))
1085 (with-current-buffer (setq buf (create-file-buffer
1086 image-dired-db-file))
1087 (with-file-modes #o600
1088 (write-file image-dired-db-file)))
1089 (kill-buffer buf)
1090 (file-exists-p image-dired-db-file))
1091 (error "Could not create %s" image-dired-db-file)))
1092
1093(defvar image-dired-tag-history nil "Variable holding the tag history.")
1094
1095(defun image-dired-write-tags (file-tags)
1096 "Write file tags to database.
1097Write each file and tag in FILE-TAGS to the database.
1098FILE-TAGS is an alist in the following form:
1099 ((FILE . TAG) ... )"
1100 (image-dired-sane-db-file)
1101 (let (end file tag)
1102 (image-dired--with-db-file
1103 (setq buffer-file-name image-dired-db-file)
1104 (dolist (elt file-tags)
1105 (setq file (car elt)
1106 tag (cdr elt))
1107 (goto-char (point-min))
1108 (if (search-forward-regexp (format "^%s.*$" file) nil t)
1109 (progn
1110 (setq end (point))
1111 (beginning-of-line)
1112 (when (not (search-forward (format ";%s" tag) end t))
1113 (end-of-line)
1114 (insert (format ";%s" tag))))
1115 (goto-char (point-max))
1116 (insert (format "%s;%s\n" file tag))))
1117 (save-buffer))))
1118
1119(defun image-dired-remove-tag (files tag)
1120 "For all FILES, remove TAG from the image database."
1121 (image-dired-sane-db-file)
1122 (image-dired--with-db-file
1123 (setq buffer-file-name image-dired-db-file)
1124 (let (end)
1125 (unless (listp files)
1126 (if (stringp files)
1127 (setq files (list files))
1128 (error "Files must be a string or a list of strings!")))
1129 (dolist (file files)
1130 (goto-char (point-min))
1131 (when (search-forward-regexp (format "^%s;" file) nil t)
1132 (end-of-line)
1133 (setq end (point))
1134 (beginning-of-line)
1135 (when (search-forward-regexp
1136 (format "\\(;%s\\)\\($\\|;\\)" tag) end t)
1137 (delete-region (match-beginning 1) (match-end 1))
1138 ;; Check if file should still be in the database. If
1139 ;; it has no tags or comments, it will be removed.
1140 (end-of-line)
1141 (setq end (point))
1142 (beginning-of-line)
1143 (when (not (search-forward ";" end t))
1144 (kill-line 1))))))
1145 (save-buffer)))
1146
1147(defun image-dired-list-tags (file)
1148 "Read all tags for image FILE from the image database."
1149 (image-dired-sane-db-file)
1150 (image-dired--with-db-file
1151 (let (end (tags ""))
1152 (when (search-forward-regexp (format "^%s" file) nil t)
1153 (end-of-line)
1154 (setq end (point))
1155 (beginning-of-line)
1156 (if (search-forward ";" end t)
1157 (if (search-forward "comment:" end t)
1158 (if (search-forward ";" end t)
1159 (setq tags (buffer-substring (point) end)))
1160 (setq tags (buffer-substring (point) end)))))
1161 (split-string tags ";"))))
1162
1163;;;###autoload
1164(defun image-dired-tag-files (arg)
1165 "Tag marked file(s) in Dired. With prefix ARG, tag file at point."
1166 (interactive "P")
1167 (let ((tag (completing-read
1168 "Tags to add (separate tags with a semicolon): "
1169 image-dired-tag-history nil nil nil 'image-dired-tag-history))
1170 files)
1171 (if arg
1172 (setq files (list (dired-get-filename)))
1173 (setq files (dired-get-marked-files)))
1174 (image-dired-write-tags
1175 (mapcar
1176 (lambda (x)
1177 (cons x tag))
1178 files))))
1179
1180(defun image-dired-tag-thumbnail ()
1181 "Tag current or marked thumbnails."
1182 (interactive)
1183 (let ((tag (completing-read
1184 "Tags to add (separate tags with a semicolon): "
1185 image-dired-tag-history nil nil nil 'image-dired-tag-history)))
1186 (image-dired--with-marked
1187 (image-dired-write-tags
1188 (list (cons (image-dired-original-file-name) tag)))
1189 (image-dired-update-property
1190 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1191
1192;;;###autoload
1193(defun image-dired-delete-tag (arg)
1194 "Remove tag for selected file(s).
1195With prefix argument ARG, remove tag from file at point."
1196 (interactive "P")
1197 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1198 nil nil nil 'image-dired-tag-history))
1199 files)
1200 (if arg
1201 (setq files (list (dired-get-filename)))
1202 (setq files (dired-get-marked-files)))
1203 (image-dired-remove-tag files tag)))
1204
1205(defun image-dired-tag-thumbnail-remove ()
1206 "Remove tag from current or marked thumbnails."
1207 (interactive)
1208 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1209 nil nil nil 'image-dired-tag-history)))
1210 (image-dired--with-marked
1211 (image-dired-remove-tag (image-dired-original-file-name) tag)
1212 (image-dired-update-property
1213 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1214
1215
1216;;; Thumbnail mode (cont.)
1217
1218(defun image-dired-original-file-name ()
1219 "Get original file name for thumbnail or display image at point."
1220 (get-text-property (point) 'original-file-name))
1221
1222(defun image-dired-file-name-at-point ()
1223 "Get abbreviated file name for thumbnail or display image at point."
1224 (let ((f (image-dired-original-file-name)))
1225 (when f
1226 (abbreviate-file-name f))))
1227
1228(defun image-dired-associated-dired-buffer ()
1229 "Get associated Dired buffer at point."
1230 (get-text-property (point) 'associated-dired-buffer))
1231
1232(defun image-dired-get-buffer-window (buf)
1233 "Return window where buffer BUF is."
1234 (get-window-with-predicate
1235 (lambda (window)
1236 (equal (window-buffer window) buf))
1237 nil t))
1238
1239(defun image-dired-track-original-file ()
1240 "Track the original file in the associated Dired buffer.
1241See documentation for `image-dired-toggle-movement-tracking'.
1242Interactive use only useful if `image-dired-track-movement' is nil."
1243 (interactive)
1244 (let* ((dired-buf (image-dired-associated-dired-buffer))
1245 (file-name (image-dired-original-file-name))
1246 (window (image-dired-get-buffer-window dired-buf)))
1247 (and (buffer-live-p dired-buf) file-name
1248 (with-current-buffer dired-buf
1249 (if (not (dired-goto-file file-name))
1250 (message "Could not track file")
1251 (if window (set-window-point window (point))))))))
1252
1253(defun image-dired-toggle-movement-tracking ()
1254 "Turn on and off `image-dired-track-movement'.
1255Tracking of the movements between thumbnail and Dired buffer so that
1256they are \"mirrored\" in the dired buffer. When this is on, moving
1257around in the thumbnail or dired buffer will find the matching
1258position in the other buffer."
1259 (interactive)
1260 (setq image-dired-track-movement (not image-dired-track-movement))
1261 (message "Movement tracking %s" (if image-dired-track-movement "on" "off")))
1262
1263(defun image-dired-track-thumbnail ()
1264 "Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
1265This is almost the same as what `image-dired-track-original-file' does,
1266but the other way around."
1267 (let ((file (dired-get-filename))
1268 prop-val found window)
1269 (when (get-buffer image-dired-thumbnail-buffer)
1270 (with-current-buffer image-dired-thumbnail-buffer
1271 (goto-char (point-min))
1272 (while (and (not (eobp))
1273 (not found))
1274 (if (and (setq prop-val
1275 (get-text-property (point) 'original-file-name))
1276 (string= prop-val file))
1277 (setq found t))
1278 (if (not found)
1279 (forward-char 1)))
1280 (when found
1281 (if (setq window (image-dired-thumbnail-window))
1282 (set-window-point window (point)))
1283 (image-dired-update-header-line))))))
1284
1285(defun image-dired-dired-next-line (&optional arg)
1286 "Call `dired-next-line', then track thumbnail.
1287This can safely replace `dired-next-line'.
1288With prefix argument, move ARG lines."
1289 (interactive "P")
1290 (dired-next-line (or arg 1))
1291 (if image-dired-track-movement
1292 (image-dired-track-thumbnail)))
1293
1294(defun image-dired-dired-previous-line (&optional arg)
1295 "Call `dired-previous-line', then track thumbnail.
1296This can safely replace `dired-previous-line'.
1297With prefix argument, move ARG lines."
1298 (interactive "P")
1299 (dired-previous-line (or arg 1))
1300 (if image-dired-track-movement
1301 (image-dired-track-thumbnail)))
1302
1303(defun image-dired--display-thumb-properties-fun ()
1304 (let ((old-buf (current-buffer))
1305 (old-point (point)))
1306 (lambda ()
1307 (when (and (equal (current-buffer) old-buf)
1308 (= (point) old-point))
1309 (ignore-errors
1310 (image-dired-update-header-line))))))
1311
1312(defun image-dired-forward-image (&optional arg wrap-around)
1313 "Move to next image and display properties.
1314Optional prefix ARG says how many images to move; the default is
1315one image. Negative means move backwards.
1316On reaching end or beginning of buffer, stop and show a message.
1317
1318If optional argument WRAP-AROUND is non-nil, wrap around: if
1319point is on the last image, move to the last one and vice versa."
1320 (interactive "p")
1321 (setq arg (or arg 1))
1322 (let (pos)
1323 (dotimes (_ (abs arg))
1324 (if (and (not (if (> arg 0) (eobp) (bobp)))
1325 (save-excursion
1326 (forward-char (if (> arg 0) 1 -1))
1327 (while (and (not (if (> arg 0) (eobp) (bobp)))
1328 (not (image-dired-image-at-point-p)))
1329 (forward-char (if (> arg 0) 1 -1)))
1330 (setq pos (point))
1331 (image-dired-image-at-point-p)))
1332 (progn (goto-char pos)
1333 (image-dired-update-header-line))
1334 (if wrap-around
1335 (progn (goto-char (if (> arg 0)
1336 (point-min)
1337 ;; There are two spaces after the last image.
1338 (- (point-max) 2)))
1339 (image-dired-update-header-line))
1340 (message "At %s image" (if (> arg 0) "last" "first"))
1341 (run-at-time 1 nil (image-dired--display-thumb-properties-fun))))))
1342 (when image-dired-track-movement
1343 (image-dired-track-original-file)))
1344
1345(defun image-dired-backward-image (&optional arg)
1346 "Move to previous image and display properties.
1347Optional prefix ARG says how many images to move; the default is
1348one image. Negative means move forward.
1349On reaching end or beginning of buffer, stop and show a message."
1350 (interactive "p")
1351 (image-dired-forward-image (- (or arg 1))))
1352
1353(defun image-dired-next-line ()
1354 "Move to next line and display properties."
1355 (interactive nil image-dired-thumbnail-mode)
1356 (let ((goal-column (current-column)))
1357 (forward-line 1)
1358 (move-to-column goal-column))
1359 ;; If we end up in an empty spot, back up to the next thumbnail.
1360 (if (not (image-dired-image-at-point-p))
1361 (image-dired-backward-image))
1362 (if image-dired-track-movement
1363 (image-dired-track-original-file))
1364 (image-dired-update-header-line))
1365
1366
1367(defun image-dired-previous-line ()
1368 "Move to previous line and display properties."
1369 (interactive nil image-dired-thumbnail-mode)
1370 (let ((goal-column (current-column)))
1371 (forward-line -1)
1372 (move-to-column goal-column))
1373 ;; If we end up in an empty spot, back up to the next
1374 ;; thumbnail. This should only happen if the user deleted a
1375 ;; thumbnail and did not refresh, so it is not very common. But we
1376 ;; can handle it in a good manner, so why not?
1377 (if (not (image-dired-image-at-point-p))
1378 (image-dired-backward-image))
1379 (if image-dired-track-movement
1380 (image-dired-track-original-file))
1381 (image-dired-update-header-line))
1382
1383(defun image-dired-beginning-of-buffer ()
1384 "Move to the first image in the buffer and display properties."
1385 (interactive nil image-dired-thumbnail-mode)
1386 (goto-char (point-min))
1387 (while (and (not (image-at-point-p))
1388 (not (eobp)))
1389 (forward-char 1))
1390 (when image-dired-track-movement
1391 (image-dired-track-original-file))
1392 (image-dired-update-header-line))
1393
1394(defun image-dired-end-of-buffer ()
1395 "Move to the last image in the buffer and display properties."
1396 (interactive nil image-dired-thumbnail-mode)
1397 (goto-char (point-max))
1398 (while (and (not (image-at-point-p))
1399 (not (bobp)))
1400 (forward-char -1))
1401 (when image-dired-track-movement
1402 (image-dired-track-original-file))
1403 (image-dired-update-header-line))
1404
1405(defun image-dired-format-properties-string (buf file props comment)
1406 "Format display properties.
1407BUF is the associated Dired buffer, FILE is the original image file
1408name, PROPS is a stringified list of tags and COMMENT is the image file's
1409comment."
1410 (format-spec
1411 image-dired-display-properties-format
1412 (list
1413 (cons ?b (or buf ""))
1414 (cons ?f file)
1415 (cons ?t (or props ""))
1416 (cons ?c (or comment "")))))
1417
1418(defun image-dired-update-header-line ()
1419 "Update image information in the header line."
1420 (when (and (not (eobp))
1421 (memq major-mode '(image-dired-thumbnail-mode
1422 image-dired-display-image-mode)))
1423 (let ((file-name (file-name-nondirectory (image-dired-original-file-name)))
1424 (dired-buf (buffer-name (image-dired-associated-dired-buffer)))
1425 (props (mapconcat #'identity (get-text-property (point) 'tags) ", "))
1426 (comment (get-text-property (point) 'comment))
1427 (message-log-max nil))
1428 (if file-name
1429 (setq header-line-format
1430 (image-dired-format-properties-string
1431 dired-buf
1432 file-name
1433 props
1434 comment))))))
1435
1436(defun image-dired-dired-file-marked-p (&optional marker)
1437 "In Dired, return t if file on current line is marked.
1438If optional argument MARKER is non-nil, it is a character to look
1439for. The default is to look for `dired-marker-char'."
1440 (setq marker (or marker dired-marker-char))
1441 (save-excursion
1442 (beginning-of-line)
1443 (and (looking-at dired-re-mark)
1444 (= (aref (match-string 0) 0) marker))))
1445
1446(defun image-dired-dired-file-flagged-p ()
1447 "In Dired, return t if file on current line is flagged for deletion."
1448 (image-dired-dired-file-marked-p dired-del-marker))
1449
1450(defmacro image-dired--with-thumbnail-buffer (&rest body)
1451 (declare (indent defun) (debug t))
1452 `(if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1453 (with-current-buffer buf
1454 (if-let ((win (get-buffer-window buf)))
1455 (with-selected-window win
1456 ,@body)
1457 ,@body))
1458 (user-error "No such buffer: %s" image-dired-thumbnail-buffer)))
1459
1460(defmacro image-dired--on-file-in-dired-buffer (&rest body)
1461 "Run BODY with point on file at point in Dired buffer.
1462Should be called from commands in `image-dired-thumbnail-mode'."
1463 (declare (indent defun) (debug t))
1464 `(let ((file-name (image-dired-original-file-name))
1465 (dired-buf (image-dired-associated-dired-buffer)))
1466 (if (not (and dired-buf file-name))
1467 (message "No image, or image with correct properties, at point")
1468 (with-current-buffer dired-buf
1469 (when (dired-goto-file file-name)
1470 ,@body
1471 (image-dired-thumb-update-marks))))))
1472
1473(defmacro image-dired--do-mark-command (maybe-next &rest body)
1474 "Helper macro for the mark, unmark and flag commands.
1475Run BODY in Dired buffer.
1476If optional argument MAYBE-NEXT is non-nil, show next image
1477according to `image-dired-marking-shows-next'."
1478 (declare (indent defun) (debug t))
1479 `(image-dired--with-thumbnail-buffer
1480 (image-dired--on-file-in-dired-buffer
1481 ,@body)
1482 ,(when maybe-next
1483 '(if image-dired-marking-shows-next
1484 (image-dired-display-next-thumbnail-original)
1485 (image-dired-next-line)))))
1486
1487(defun image-dired-mark-thumb-original-file ()
1488 "Mark original image file in associated Dired buffer."
1489 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1490 (image-dired--do-mark-command t
1491 (dired-mark 1)))
1492
1493(defun image-dired-unmark-thumb-original-file ()
1494 "Unmark original image file in associated Dired buffer."
1495 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1496 (image-dired--do-mark-command t
1497 (dired-unmark 1)))
1498
1499(defun image-dired-flag-thumb-original-file ()
1500 "Flag original image file for deletion in associated Dired buffer."
1501 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1502 (image-dired--do-mark-command t
1503 (dired-flag-file-deletion 1)))
1504
1505(defun image-dired-toggle-mark-thumb-original-file ()
1506 "Toggle mark on original image file in associated Dired buffer."
1507 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1508 (image-dired--do-mark-command nil
1509 (if (image-dired-dired-file-marked-p)
1510 (dired-unmark 1)
1511 (dired-mark 1))))
1512
1513(defun image-dired-unmark-all-marks ()
1514 "Remove all marks from all files in associated Dired buffer.
1515Also update the marks in the thumbnail buffer."
1516 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1517 (image-dired--do-mark-command nil
1518 (dired-unmark-all-marks))
1519 (image-dired--with-thumbnail-buffer
1520 (image-dired-thumb-update-marks)))
1521
1522(defun image-dired-jump-original-dired-buffer ()
1523 "Jump to the Dired buffer associated with the current image file.
1524You probably want to use this together with
1525`image-dired-track-original-file'."
1526 (interactive nil image-dired-thumbnail-mode)
1527 (let ((buf (image-dired-associated-dired-buffer))
1528 window frame)
1529 (setq window (image-dired-get-buffer-window buf))
1530 (if window
1531 (progn
1532 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1533 (select-frame-set-input-focus frame))
1534 (select-window window))
1535 (message "Associated dired buffer not visible"))))
1536
1537;;;###autoload
1538(defun image-dired-jump-thumbnail-buffer ()
1539 "Jump to thumbnail buffer."
1540 (interactive)
1541 (let ((window (image-dired-thumbnail-window))
1542 frame)
1543 (if window
1544 (progn
1545 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1546 (select-frame-set-input-focus frame))
1547 (select-window window))
1548 (message "Thumbnail buffer not visible"))))
1549
1550(defvar image-dired-thumbnail-mode-line-up-map
1551 (let ((map (make-sparse-keymap)))
1552 ;; map it to "g" so that the user can press it more quickly
1553 (define-key map "g" #'image-dired-line-up-dynamic)
1554 ;; "f" for "fixed" number of thumbs per row
1555 (define-key map "f" #'image-dired-line-up)
1556 ;; "i" for "interactive"
1557 (define-key map "i" #'image-dired-line-up-interactive)
1558 map)
1559 "Keymap for line-up commands in `image-dired-thumbnail-mode'.")
1560
1561(defvar image-dired-thumbnail-mode-tag-map
1562 (let ((map (make-sparse-keymap)))
1563 ;; map it to "t" so that the user can press it more quickly
1564 (define-key map "t" #'image-dired-tag-thumbnail)
1565 ;; "r" for "remove"
1566 (define-key map "r" #'image-dired-tag-thumbnail-remove)
1567 map)
1568 "Keymap for tag commands in `image-dired-thumbnail-mode'.")
1569
1570(defvar image-dired-thumbnail-mode-map
1571 (let ((map (make-sparse-keymap)))
1572 (define-key map [right] #'image-dired-forward-image)
1573 (define-key map [left] #'image-dired-backward-image)
1574 (define-key map [up] #'image-dired-previous-line)
1575 (define-key map [down] #'image-dired-next-line)
1576 (define-key map "\C-f" #'image-dired-forward-image)
1577 (define-key map "\C-b" #'image-dired-backward-image)
1578 (define-key map "\C-p" #'image-dired-previous-line)
1579 (define-key map "\C-n" #'image-dired-next-line)
1580
1581 (define-key map "<" #'image-dired-beginning-of-buffer)
1582 (define-key map ">" #'image-dired-end-of-buffer)
1583 (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer)
1584 (define-key map (kbd "M->") #'image-dired-end-of-buffer)
1585
1586 (define-key map "d" #'image-dired-flag-thumb-original-file)
1587 (define-key map [delete] #'image-dired-flag-thumb-original-file)
1588 (define-key map "m" #'image-dired-mark-thumb-original-file)
1589 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1590 (define-key map "U" #'image-dired-unmark-all-marks)
1591 (define-key map "." #'image-dired-track-original-file)
1592 (define-key map [tab] #'image-dired-jump-original-dired-buffer)
1593
1594 ;; add line-up map
1595 (define-key map "g" image-dired-thumbnail-mode-line-up-map)
1596 ;; add tag map
1597 (define-key map "t" image-dired-thumbnail-mode-tag-map)
1598
1599 (define-key map "\C-m" #'image-dired-display-thumbnail-original-image)
1600 (define-key map [C-return] #'image-dired-thumbnail-display-external)
1601
1602 (define-key map "L" #'image-dired-rotate-original-left)
1603 (define-key map "R" #'image-dired-rotate-original-right)
1604
1605 (define-key map "D" #'image-dired-thumbnail-set-image-description)
1606 (define-key map "S" #'image-dired-slideshow-start)
1607 (define-key map "\C-d" #'image-dired-delete-char)
1608 (define-key map " " #'image-dired-display-next-thumbnail-original)
1609 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1610 (define-key map "c" #'image-dired-comment-thumbnail)
1611
1612 ;; Mouse
1613 (define-key map [mouse-2] #'image-dired-mouse-display-image)
1614 (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail)
1615 (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail)
1616 (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail)
1617 (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail)
1618 (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail)
1619 ;; Seems I must first set C-down-mouse-1 to undefined, or else it
1620 ;; will trigger the buffer menu. If I try to instead bind
1621 ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
1622 ;; about C-mouse-1 not being defined afterwards. Annoying, but I
1623 ;; probably do not completely understand mouse events.
1624 (define-key map [C-down-mouse-1] #'undefined)
1625 (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark)
1626 map)
1627 "Keymap for `image-dired-thumbnail-mode'.")
1628
1629(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map
1630 "Menu for `image-dired-thumbnail-mode'."
1631 '("Image-Dired"
1632 ["Display image" image-dired-display-thumbnail-original-image]
1633 ["Display in external viewer" image-dired-thumbnail-display-external]
1634 ["Jump to Dired buffer" image-dired-jump-original-dired-buffer]
1635 "---"
1636 ["Mark image" image-dired-mark-thumb-original-file]
1637 ["Unmark image" image-dired-unmark-thumb-original-file]
1638 ["Unmark all images" image-dired-unmark-all-marks]
1639 ["Flag for deletion" image-dired-flag-thumb-original-file]
1640 ["Delete marked images" image-dired-delete-marked]
1641 "---"
1642 ["Rotate original right" image-dired-rotate-original-right]
1643 ["Rotate original left" image-dired-rotate-original-left]
1644 "---"
1645 ["Comment thumbnail" image-dired-comment-thumbnail]
1646 ["Tag current or marked thumbnails" image-dired-tag-thumbnail]
1647 ["Remove tag from current or marked thumbnails"
1648 image-dired-tag-thumbnail-remove]
1649 ["Start slideshow" image-dired-slideshow-start]
1650 "---"
1651 ("View Options"
1652 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1653 :style toggle
1654 :selected image-dired-track-movement]
1655 "---"
1656 ["Line up thumbnails" image-dired-line-up]
1657 ["Dynamic line up" image-dired-line-up-dynamic]
1658 ["Refresh thumb" image-dired-refresh-thumb])
1659 ["Quit" quit-window]))
1660
1661(defvar image-dired-display-image-mode-map
1662 (let ((map (make-sparse-keymap)))
1663 (define-key map "S" #'image-dired-slideshow-start)
1664 (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original)
1665 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1666 (define-key map "n" #'image-dired-display-next-thumbnail-original)
1667 (define-key map "p" #'image-dired-display-previous-thumbnail-original)
1668 (define-key map "m" #'image-dired-mark-thumb-original-file)
1669 (define-key map "d" #'image-dired-flag-thumb-original-file)
1670 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1671 (define-key map "U" #'image-dired-unmark-all-marks)
1672 ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
1673 (define-key map "o" nil) ; image-save
1674 map)
1675 "Keymap for `image-dired-display-image-mode'.")
1676
1677(define-derived-mode image-dired-thumbnail-mode
1678 special-mode "image-dired-thumbnail"
1679 "Browse and manipulate thumbnail images using Dired.
1680Use `image-dired-minor-mode' to get a nice setup."
1681 :interactive nil
1682 (buffer-disable-undo)
1683 (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)
1684 (setq-local window-resize-pixelwise t)
1685 (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record)
1686 ;; Use approximately as much vertical spacing as horizontal.
1687 (setq-local line-spacing (frame-char-width)))
1688
1689
1690;;; Display image mode
1691
1692(define-derived-mode image-dired-display-image-mode
1693 image-mode "image-dired-image-display"
1694 "Mode for displaying and manipulating original image.
1695Resized or in full-size."
1696 :interactive nil
1697 (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t))
1698
1699(defvar image-dired-minor-mode-map
1700 (let ((map (make-sparse-keymap)))
1701 ;; (set-keymap-parent map dired-mode-map)
1702 ;; Hijack previous and next line movement. Let C-p and C-b be
1703 ;; though...
1704 (define-key map "p" #'image-dired-dired-previous-line)
1705 (define-key map "n" #'image-dired-dired-next-line)
1706 (define-key map [up] #'image-dired-dired-previous-line)
1707 (define-key map [down] #'image-dired-dired-next-line)
1708
1709 (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display)
1710 (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display)
1711 (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next)
1712
1713 (define-key map "\C-td" #'image-dired-display-thumbs)
1714 (define-key map [tab] #'image-dired-jump-thumbnail-buffer)
1715 (define-key map "\C-ti" #'image-dired-dired-display-image)
1716 (define-key map "\C-tx" #'image-dired-dired-display-external)
1717 (define-key map "\C-ta" #'image-dired-display-thumbs-append)
1718 (define-key map "\C-t." #'image-dired-display-thumb)
1719 (define-key map "\C-tc" #'image-dired-dired-comment-files)
1720 (define-key map "\C-tf" #'image-dired-mark-tagged-files)
1721 map)
1722 "Keymap for `image-dired-minor-mode'.")
1723
1724(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
1725 "Menu for `image-dired-minor-mode'."
1726 '("Image-dired"
1727 ["Display thumb for next file" image-dired-next-line-and-display]
1728 ["Display thumb for previous file" image-dired-previous-line-and-display]
1729 ["Mark and display next" image-dired-mark-and-display-next]
1730 "---"
1731 ["Create thumbnails for marked files" image-dired-create-thumbs]
1732 "---"
1733 ["Display thumbnails append" image-dired-display-thumbs-append]
1734 ["Display this thumbnail" image-dired-display-thumb]
1735 ["Display image" image-dired-dired-display-image]
1736 ["Display in external viewer" image-dired-dired-display-external]
1737 "---"
1738 ["Toggle display properties" image-dired-toggle-dired-display-properties
1739 :style toggle
1740 :selected image-dired-dired-disp-props]
1741 ["Toggle append browsing" image-dired-toggle-append-browsing
1742 :style toggle
1743 :selected image-dired-append-when-browsing]
1744 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1745 :style toggle
1746 :selected image-dired-track-movement]
1747 "---"
1748 ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
1749 ["Mark tagged files" image-dired-mark-tagged-files]
1750 ["Comment files" image-dired-dired-comment-files]
1751 ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
1752
1753;;;###autoload
1754(define-minor-mode image-dired-minor-mode
1755 "Setup easy-to-use keybindings for the commands to be used in Dired mode.
1756Note that n, p and <down> and <up> will be hijacked and bound to
1757`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
1758 :keymap image-dired-minor-mode-map)
1759
1760(declare-function clear-image-cache "image.c" (&optional filter))
1761
1762(defun image-dired-create-thumbs (&optional arg)
1763 "Create thumbnail images for all marked files in Dired.
1764With prefix argument ARG, create thumbnails even if they already exist
1765\(i.e. use this to refresh your thumbnails)."
1766 (interactive "P")
1767 (let (thumb-name)
1768 (dolist (curr-file (dired-get-marked-files))
1769 (setq thumb-name (image-dired-thumb-name curr-file))
1770 ;; If the user overrides the exist check, we must clear the
1771 ;; image cache so that if the user wants to display the
1772 ;; thumbnail, it is not fetched from cache.
1773 (when arg
1774 (clear-image-cache (expand-file-name thumb-name)))
1775 (when (or (not (file-exists-p thumb-name))
1776 arg)
1777 (image-dired-create-thumb curr-file thumb-name)))))
1778
1779
1780;;; Slideshow
1781
1782(defcustom image-dired-slideshow-delay 5.0
1783 "Seconds to wait before showing the next image in a slideshow.
1784This is used by `image-dired-slideshow-start'."
1785 :type 'float
1786 :version "29.1")
1787
1788(define-obsolete-variable-alias 'image-dired-slideshow-timer
1789 'image-dired--slideshow-timer "29.1")
1790(defvar image-dired--slideshow-timer nil
1791 "Slideshow timer.")
1792
1793(defvar image-dired--slideshow-initial nil)
1794
1795(defun image-dired-slideshow-step ()
1796 "Step to next image in a slideshow."
1797 (if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1798 (with-current-buffer buf
1799 (image-dired-display-next-thumbnail-original))
1800 (image-dired-slideshow-stop)))
1801
1802(defun image-dired-slideshow-start (&optional arg)
1803 "Start a slideshow, waiting `image-dired-slideshow-delay' between images.
1804
1805With prefix argument ARG, wait that many seconds before going to
1806the next image.
1807
1808With a negative prefix argument, prompt user for the delay."
1809 (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode)
1810 (let ((delay (if (not arg)
1811 image-dired-slideshow-delay
1812 (if (> arg 0)
1813 arg
1814 (string-to-number
1815 (let ((delay (number-to-string image-dired-slideshow-delay)))
1816 (read-string
1817 (format-prompt "Delay, in seconds. Decimals are accepted" delay))
1818 delay))))))
1819 (setq image-dired--slideshow-timer
1820 (run-with-timer
1821 0 delay
1822 'image-dired-slideshow-step))
1823 (add-hook 'post-command-hook 'image-dired-slideshow-stop)
1824 (setq image-dired--slideshow-initial t)
1825 (message "Running slideshow; use any command to stop")))
1826
1827(defun image-dired-slideshow-stop ()
1828 "Cancel slideshow."
1829 ;; Make sure we don't immediately stop after
1830 ;; `image-dired-slideshow-start'.
1831 (unless image-dired--slideshow-initial
1832 (remove-hook 'post-command-hook 'image-dired-slideshow-stop)
1833 (cancel-timer image-dired--slideshow-timer))
1834 (setq image-dired--slideshow-initial nil))
1835
1836
1837;;; Thumbnail mode (cont. 3)
1838
1839(defun image-dired-delete-char ()
1840 "Remove current thumbnail from thumbnail buffer and line up."
1841 (interactive nil image-dired-thumbnail-mode)
1842 (let ((inhibit-read-only t))
1843 (delete-char 1)
1844 (when (= (following-char) ?\s)
1845 (delete-char 1))))
1846
1847;;;###autoload
1848(defun image-dired-display-thumbs-append ()
1849 "Append thumbnails to `image-dired-thumbnail-buffer'."
1850 (interactive)
1851 (image-dired-display-thumbs nil t t))
1852
1853;;;###autoload
1854(defun image-dired-display-thumb ()
1855 "Shorthand for `image-dired-display-thumbs' with prefix argument."
1856 (interactive)
1857 (image-dired-display-thumbs t nil t))
1858
1859(defun image-dired-line-up ()
1860 "Line up thumbnails according to `image-dired-thumbs-per-row'.
1861See also `image-dired-line-up-dynamic'."
1862 (interactive)
1863 (let ((inhibit-read-only t))
1864 (goto-char (point-min))
1865 (while (and (not (image-dired-image-at-point-p))
1866 (not (eobp)))
1867 (delete-char 1))
1868 (while (not (eobp))
1869 (forward-char)
1870 (while (and (not (image-dired-image-at-point-p))
1871 (not (eobp)))
1872 (delete-char 1)))
1873 (goto-char (point-min))
1874 (let ((seen 0)
1875 (thumb-prev-pos 0)
1876 (thumb-width-chars
1877 (ceiling (/ (+ (* 2 image-dired-thumb-relief)
1878 (* 2 image-dired-thumb-margin)
1879 (image-dired-thumb-size 'width))
1880 (float (frame-char-width))))))
1881 (while (not (eobp))
1882 (forward-char)
1883 (if (= image-dired-thumbs-per-row 1)
1884 (insert "\n")
1885 (cl-incf thumb-prev-pos thumb-width-chars)
1886 (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos)))
1887 (cl-incf seen)
1888 (when (and (= seen (- image-dired-thumbs-per-row 1))
1889 (not (eobp)))
1890 (forward-char)
1891 (insert "\n")
1892 (setq seen 0)
1893 (setq thumb-prev-pos 0)))))
1894 (goto-char (point-min))))
1895
1896(defun image-dired-line-up-dynamic ()
1897 "Line up thumbnails images dynamically.
1898Calculate how many thumbnails fit."
1899 (interactive)
1900 (let* ((char-width (frame-char-width))
1901 (width (image-dired-window-width-pixels (image-dired-thumbnail-window)))
1902 (image-dired-thumbs-per-row
1903 (/ width
1904 (+ (* 2 image-dired-thumb-relief)
1905 (* 2 image-dired-thumb-margin)
1906 (image-dired-thumb-size 'width)
1907 char-width))))
1908 (image-dired-line-up)))
1909
1910(defun image-dired-line-up-interactive ()
1911 "Line up thumbnails interactively.
1912Ask user how many thumbnails should be displayed per row."
1913 (interactive)
1914 (let ((image-dired-thumbs-per-row
1915 (string-to-number (read-string "How many thumbs per row: "))))
1916 (if (not (> image-dired-thumbs-per-row 0))
1917 (message "Number must be greater than 0")
1918 (image-dired-line-up))))
1919
1920(defun image-dired-thumbnail-display-external ()
1921 "Display original image for thumbnail at point using external viewer."
1922 (interactive)
1923 (let ((file (image-dired-original-file-name)))
1924 (if (not (image-dired-image-at-point-p))
1925 (message "No thumbnail at point")
1926 (if (not file)
1927 (message "No original file name found")
1928 (start-process "image-dired-thumb-external" nil
1929 image-dired-external-viewer file)))))
1930
1931;;;###autoload
1932(defun image-dired-dired-display-external ()
1933 "Display file at point using an external viewer."
1934 (interactive)
1935 (let ((file (dired-get-filename)))
1936 (start-process "image-dired-external" nil
1937 image-dired-external-viewer file)))
1938
1939(defun image-dired-window-width-pixels (window)
1940 "Calculate WINDOW width in pixels."
1941 (* (window-width window) (frame-char-width)))
1942
1943(defun image-dired-display-window ()
1944 "Return window where `image-dired-display-image-buffer' is visible."
1945 (get-window-with-predicate
1946 (lambda (window)
1947 (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer))
1948 nil t))
1949
1950(defun image-dired-thumbnail-window ()
1951 "Return window where `image-dired-thumbnail-buffer' is visible."
1952 (get-window-with-predicate
1953 (lambda (window)
1954 (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer))
1955 nil t))
1956
1957(defun image-dired-associated-dired-buffer-window ()
1958 "Return window where associated Dired buffer is visible."
1959 (let (buf)
1960 (if (image-dired-image-at-point-p)
1961 (progn
1962 (setq buf (image-dired-associated-dired-buffer))
1963 (get-window-with-predicate
1964 (lambda (window)
1965 (equal (window-buffer window) buf))))
1966 (error "No thumbnail image at point"))))
1967
1968(defun image-dired-display-image (file &optional _ignored)
1969 "Display image FILE in image buffer.
1970Use this when you want to display the image, in a new window.
1971The window will use `image-dired-display-image-mode' which is
1972based on `image-mode'."
1973 (declare (advertised-calling-convention (file) "29.1"))
1974 (setq file (expand-file-name file))
1975 (when (not (file-exists-p file))
1976 (error "No such file: %s" file))
1977 (let ((buf (get-buffer image-dired-display-image-buffer))
1978 (cur-win (selected-window)))
1979 (when buf
1980 (kill-buffer buf))
1981 (when-let ((buf (find-file-noselect file nil t)))
1982 (pop-to-buffer buf)
1983 (rename-buffer image-dired-display-image-buffer)
1984 (image-dired-display-image-mode)
1985 (select-window cur-win))))
1986
1987(defun image-dired-display-thumbnail-original-image (&optional arg)
1988 "Display current thumbnail's original image in display buffer.
1989See documentation for `image-dired-display-image' for more information.
1990With prefix argument ARG, display image in its original size."
1991 (interactive "P")
1992 (let ((file (image-dired-original-file-name)))
1993 (if (not (string-equal major-mode "image-dired-thumbnail-mode"))
1994 (message "Not in image-dired-thumbnail-mode")
1995 (if (not (image-dired-image-at-point-p))
1996 (message "No thumbnail at point")
1997 (if (not file)
1998 (message "No original file name found")
1999 (image-dired-display-image file arg))))))
2000
2001
2002;;;###autoload
2003(defun image-dired-dired-display-image (&optional arg)
2004 "Display current image file.
2005See documentation for `image-dired-display-image' for more information.
2006With prefix argument ARG, display image in its original size."
2007 (interactive "P")
2008 (image-dired-display-image (dired-get-filename) arg))
2009
2010(defun image-dired-image-at-point-p ()
2011 "Return non-nil if there is an `image-dired' thumbnail at point."
2012 (get-text-property (point) 'image-dired-thumbnail))
2013
2014(defun image-dired-refresh-thumb ()
2015 "Force creation of new image for current thumbnail."
2016 (interactive nil image-dired-thumbnail-mode)
2017 (let* ((file (image-dired-original-file-name))
2018 (thumb (expand-file-name (image-dired-thumb-name file))))
2019 (clear-image-cache (expand-file-name thumb))
2020 (image-dired-create-thumb file thumb)))
2021
2022(defun image-dired-rotate-original (degrees)
2023 "Rotate original image DEGREES degrees."
2024 (image-dired--check-executable-exists
2025 'image-dired-cmd-rotate-original-program)
2026 (if (not (image-dired-image-at-point-p))
2027 (message "No image at point")
2028 (let* ((file (image-dired-original-file-name))
2029 (spec
2030 (list
2031 (cons ?d degrees)
2032 (cons ?o (expand-file-name file))
2033 (cons ?t image-dired-temp-rotate-image-file))))
2034 (unless (eq 'jpeg (image-type file))
2035 (user-error "Only JPEG images can be rotated"))
2036 (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
2037 nil nil nil
2038 (mapcar (lambda (arg) (format-spec arg spec))
2039 image-dired-cmd-rotate-original-options))))
2040 (error "Could not rotate image")
2041 (image-dired-display-image image-dired-temp-rotate-image-file)
2042 (if (or (and image-dired-rotate-original-ask-before-overwrite
2043 (y-or-n-p
2044 "Rotate to temp file OK. Overwrite original image? "))
2045 (not image-dired-rotate-original-ask-before-overwrite))
2046 (progn
2047 (copy-file image-dired-temp-rotate-image-file file t)
2048 (image-dired-refresh-thumb))
2049 (image-dired-display-image file))))))
2050
2051(defun image-dired-rotate-original-left ()
2052 "Rotate original image left (counter clockwise) 90 degrees.
2053The result of the rotation is displayed in the image display area
2054and a confirmation is needed before the original image files is
2055overwritten. This confirmation can be turned off using
2056`image-dired-rotate-original-ask-before-overwrite'."
2057 (interactive)
2058 (image-dired-rotate-original "270"))
2059
2060(defun image-dired-rotate-original-right ()
2061 "Rotate original image right (clockwise) 90 degrees.
2062The result of the rotation is displayed in the image display area
2063and a confirmation is needed before the original image files is
2064overwritten. This confirmation can be turned off using
2065`image-dired-rotate-original-ask-before-overwrite'."
2066 (interactive)
2067 (image-dired-rotate-original "90"))
2068
2069
2070;;; EXIF support
2071
2072(defun image-dired-get-exif-file-name (file)
2073 "Use the image's EXIF information to return a unique file name.
2074The file name should be unique as long as you do not take more than
2075one picture per second. The original file name is suffixed at the end
2076for traceability. The format of the returned file name is
2077YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
2078`image-dired-copy-with-exif-file-name'."
2079 (let (data no-exif-data-found)
2080 (if (not (eq 'jpeg (image-type (expand-file-name file))))
2081 (setq no-exif-data-found t
2082 data (format-time-string
2083 "%Y:%m:%d %H:%M:%S"
2084 (file-attribute-modification-time
2085 (file-attributes (expand-file-name file)))))
2086 (setq data (exif-field 'date-time (exif-parse-file
2087 (expand-file-name file)))))
2088 (while (string-match "[ :]" data)
2089 (setq data (replace-match "_" nil nil data)))
2090 (format "%s%s%s" data
2091 (if no-exif-data-found
2092 "_noexif_"
2093 "_")
2094 (file-name-nondirectory file))))
2095
2096(defun image-dired-thumbnail-set-image-description ()
2097 "Set the ImageDescription EXIF tag for the original image.
2098If the image already has a value for this tag, it is used as the
2099default value at the prompt."
2100 (interactive)
2101 (if (not (image-dired-image-at-point-p))
2102 (message "No thumbnail at point")
2103 (let* ((file (image-dired-original-file-name))
2104 (old-value (or (exif-field 'description (exif-parse-file file)) "")))
2105 (if (eq 0
2106 (image-dired-set-exif-data file "ImageDescription"
2107 (read-string "Value of ImageDescription: "
2108 old-value)))
2109 (message "Successfully wrote ImageDescription tag")
2110 (error "Could not write ImageDescription tag")))))
2111
2112(defun image-dired-set-exif-data (file tag-name tag-value)
2113 "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
2114 (image-dired--check-executable-exists
2115 'image-dired-cmd-write-exif-data-program)
2116 (let ((spec
2117 (list
2118 (cons ?f (expand-file-name file))
2119 (cons ?t tag-name)
2120 (cons ?v tag-value))))
2121 (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
2122 (mapcar (lambda (arg) (format-spec arg spec))
2123 image-dired-cmd-write-exif-data-options))))
2124
2125(defun image-dired-copy-with-exif-file-name ()
2126 "Copy file with unique name to main image directory.
2127Copy current or all marked files in Dired to a new file in your
2128main image directory, using a file name generated by
2129`image-dired-get-exif-file-name'. A typical usage for this if when
2130copying images from a digital camera into the image directory.
2131
2132 Typically, you would open up the folder with the incoming
2133digital images, mark the files to be copied, and execute this
2134function. The result is a couple of new files in
2135`image-dired-main-image-directory' called
21362005_05_08_12_52_00_dscn0319.jpg,
21372005_05_08_14_27_45_dscn0320.jpg etc."
2138 (interactive)
2139 (let (new-name
2140 (files (dired-get-marked-files)))
2141 (mapc
2142 (lambda (curr-file)
2143 (setq new-name
2144 (format "%s/%s"
2145 (file-name-as-directory
2146 (expand-file-name image-dired-main-image-directory))
2147 (image-dired-get-exif-file-name curr-file)))
2148 (message "Copying %s to %s" curr-file new-name)
2149 (copy-file curr-file new-name))
2150 files)))
2151
2152;;; Thumbnail mode (cont.)
2153
2154(defun image-dired-display-next-thumbnail-original (&optional arg)
2155 "Move to the next image in the thumbnail buffer and display it.
2156With prefix ARG, move that many thumbnails."
2157 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2158 (image-dired--with-thumbnail-buffer
2159 (image-dired-forward-image arg t)
2160 (image-dired-display-thumbnail-original-image)))
2161
2162(defun image-dired-display-previous-thumbnail-original (arg)
2163 "Move to the previous image in the thumbnail buffer and display it.
2164With prefix ARG, move that many thumbnails."
2165 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2166 (image-dired-display-next-thumbnail-original (- arg)))
2167
2168
2169;;; Image Comments
2170
2171(defun image-dired-write-comments (file-comments)
2172 "Write file comments to database.
2173Write file comments to one or more files.
2174FILE-COMMENTS is an alist on the following form:
2175 ((FILE . COMMENT) ... )"
2176 (image-dired-sane-db-file)
2177 (let (end comment-beg-pos comment-end-pos file comment)
2178 (image-dired--with-db-file
2179 (setq buffer-file-name image-dired-db-file)
2180 (dolist (elt file-comments)
2181 (setq file (car elt)
2182 comment (cdr elt))
2183 (goto-char (point-min))
2184 (if (search-forward-regexp (format "^%s.*$" file) nil t)
2185 (progn
2186 (setq end (point))
2187 (beginning-of-line)
2188 ;; Delete old comment, if any
2189 (when (search-forward ";comment:" end t)
2190 (setq comment-beg-pos (match-beginning 0))
2191 ;; Any tags after the comment?
2192 (if (search-forward ";" end t)
2193 (setq comment-end-pos (- (point) 1))
2194 (setq comment-end-pos end))
2195 ;; Delete comment tag and comment
2196 (delete-region comment-beg-pos comment-end-pos))
2197 ;; Insert new comment
2198 (beginning-of-line)
2199 (unless (search-forward ";" end t)
2200 (end-of-line)
2201 (insert ";"))
2202 (insert (format "comment:%s;" comment)))
2203 ;; File does not exist in database - add it.
2204 (goto-char (point-max))
2205 (insert (format "%s;comment:%s\n" file comment))))
2206 (save-buffer))))
2207
2208(defun image-dired-update-property (prop value)
2209 "Update text property PROP with value VALUE at point."
2210 (let ((inhibit-read-only t))
2211 (put-text-property
2212 (point) (1+ (point))
2213 prop
2214 value)))
2215
2216;;;###autoload
2217(defun image-dired-dired-comment-files ()
2218 "Add comment to current or marked files in Dired."
2219 (interactive)
2220 (let ((comment (image-dired-read-comment)))
2221 (image-dired-write-comments
2222 (mapcar
2223 (lambda (curr-file)
2224 (cons curr-file comment))
2225 (dired-get-marked-files)))))
2226
2227(defun image-dired-comment-thumbnail ()
2228 "Add comment to current thumbnail in thumbnail buffer."
2229 (interactive)
2230 (let* ((file (image-dired-original-file-name))
2231 (comment (image-dired-read-comment file)))
2232 (image-dired-write-comments (list (cons file comment)))
2233 (image-dired-update-property 'comment comment))
2234 (image-dired-update-header-line))
2235
2236(defun image-dired-read-comment (&optional file)
2237 "Read comment for an image.
2238Optionally use old comment from FILE as initial value."
2239 (let ((comment
2240 (read-string
2241 "Comment: "
2242 (if file (image-dired-get-comment file)))))
2243 comment))
2244
2245(defun image-dired-get-comment (file)
2246 "Get comment for file FILE."
2247 (image-dired-sane-db-file)
2248 (image-dired--with-db-file
2249 (let (end comment-beg-pos comment-end-pos comment)
2250 (when (search-forward-regexp (format "^%s" file) nil t)
2251 (end-of-line)
2252 (setq end (point))
2253 (beginning-of-line)
2254 (when (search-forward ";comment:" end t)
2255 (setq comment-beg-pos (point))
2256 (if (search-forward ";" end t)
2257 (setq comment-end-pos (- (point) 1))
2258 (setq comment-end-pos end))
2259 (setq comment (buffer-substring
2260 comment-beg-pos comment-end-pos))))
2261 comment)))
2262
2263;;;###autoload
2264(defun image-dired-mark-tagged-files (regexp)
2265 "Use REGEXP to mark files with matching tag.
2266A `tag' is a keyword, a piece of meta data, associated with an
2267image file and stored in image-dired's database file. This command
2268lets you input a regexp and this will be matched against all tags
2269on all image files in the database file. The files that have a
2270matching tag will be marked in the Dired buffer."
2271 (interactive "sMark tagged files (regexp): ")
2272 (image-dired-sane-db-file)
2273 (let ((hits 0)
2274 files)
2275 (image-dired--with-db-file
2276 ;; Collect matches
2277 (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t)
2278 (let ((file (match-string 1))
2279 (tags (split-string (match-string 2) ";")))
2280 (when (seq-find (lambda (tag)
2281 (string-match-p regexp tag))
2282 tags)
2283 (push file files)))))
2284 ;; Mark files
2285 (dolist (curr-file files)
2286 ;; I tried using `dired-mark-files-regexp' but it was waaaay to
2287 ;; slow. Don't bother about hits found in other directories
2288 ;; than the current one.
2289 (when (string= (file-name-as-directory
2290 (expand-file-name default-directory))
2291 (file-name-as-directory
2292 (file-name-directory curr-file)))
2293 (setq curr-file (file-name-nondirectory curr-file))
2294 (goto-char (point-min))
2295 (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
2296 (setq hits (+ hits 1))
2297 (dired-mark 1))))
2298 (message "%d files with matching tag marked" hits)))
2299
2300
2301
2302;;; Mouse support
2303
2304(defun image-dired-mouse-display-image (event)
2305 "Use mouse EVENT, call `image-dired-display-image' to display image.
2306Track this in associated Dired buffer if `image-dired-track-movement' is
2307non-nil."
2308 (interactive "e")
2309 (mouse-set-point event)
2310 (goto-char (posn-point (event-end event)))
2311 (unless (image-at-point-p)
2312 (image-dired-backward-image))
2313 (let ((file (image-dired-original-file-name)))
2314 (when file
2315 (if image-dired-track-movement
2316 (image-dired-track-original-file))
2317 (image-dired-display-image file))))
2318
2319(defun image-dired-mouse-select-thumbnail (event)
2320 "Use mouse EVENT to select thumbnail image.
2321Track this in associated Dired buffer if `image-dired-track-movement' is
2322non-nil."
2323 (interactive "e")
2324 (mouse-set-point event)
2325 (goto-char (posn-point (event-end event)))
2326 (unless (image-at-point-p)
2327 (image-dired-backward-image))
2328 (if image-dired-track-movement
2329 (image-dired-track-original-file))
2330 (image-dired-update-header-line))
2331
2332
2333
2334;;; Dired marks and tags
2335
2336(defun image-dired-thumb-file-marked-p (&optional flagged)
2337 "Check if file is marked in associated Dired buffer.
2338If optional argument FLAGGED is non-nil, check if file is flagged
2339for deletion instead."
2340 (let ((file-name (image-dired-original-file-name))
2341 (dired-buf (image-dired-associated-dired-buffer)))
2342 (when (and dired-buf file-name)
2343 (with-current-buffer dired-buf
2344 (save-excursion
2345 (when (dired-goto-file file-name)
2346 (if flagged
2347 (image-dired-dired-file-flagged-p)
2348 (image-dired-dired-file-marked-p))))))))
2349
2350(defun image-dired-thumb-file-flagged-p ()
2351 "Check if file is flagged for deletion in associated Dired buffer."
2352 (image-dired-thumb-file-marked-p t))
2353
2354(defun image-dired-delete-marked ()
2355 "Delete current or marked thumbnails and associated images."
2356 (interactive)
2357 (image-dired--with-marked
2358 (image-dired-delete-char)
2359 (unless (bobp)
2360 (backward-char)))
2361 (image-dired--line-up-with-method)
2362 (with-current-buffer (image-dired-associated-dired-buffer)
2363 (dired-do-delete)))
2364
2365(defun image-dired-thumb-update-marks ()
2366 "Update the marks in the thumbnail buffer."
2367 (when image-dired-thumb-visible-marks
2368 (with-current-buffer image-dired-thumbnail-buffer
2369 (save-mark-and-excursion
2370 (goto-char (point-min))
2371 (let ((inhibit-read-only t))
2372 (while (not (eobp))
2373 (with-silent-modifications
2374 (cond ((image-dired-thumb-file-marked-p)
2375 (add-face-text-property (point) (1+ (point))
2376 'image-dired-thumb-mark))
2377 ((image-dired-thumb-file-flagged-p)
2378 (add-face-text-property (point) (1+ (point))
2379 'image-dired-thumb-flagged))
2380 (t (remove-text-properties (point) (1+ (point))
2381 '(face image-dired-thumb-mark)))))
2382 (forward-char)))))))
2383
2384(defun image-dired-mouse-toggle-mark-1 ()
2385 "Toggle Dired mark for current thumbnail.
2386Track this in associated Dired buffer if
2387`image-dired-track-movement' is non-nil."
2388 (when image-dired-track-movement
2389 (image-dired-track-original-file))
2390 (image-dired-toggle-mark-thumb-original-file))
2391
2392(defun image-dired-mouse-toggle-mark (event)
2393 "Use mouse EVENT to toggle Dired mark for thumbnail.
2394Toggle marks of all thumbnails in region, if it's active.
2395Track this in associated Dired buffer if
2396`image-dired-track-movement' is non-nil."
2397 (interactive "e")
2398 (if (use-region-p)
2399 (let ((end (region-end)))
2400 (save-excursion
2401 (goto-char (region-beginning))
2402 (while (<= (point) end)
2403 (when (image-dired-image-at-point-p)
2404 (image-dired-mouse-toggle-mark-1))
2405 (forward-char))))
2406 (mouse-set-point event)
2407 (goto-char (posn-point (event-end event)))
2408 (image-dired-mouse-toggle-mark-1))
2409 (image-dired-thumb-update-marks))
2410
2411(defun image-dired-dired-display-properties ()
2412 "Display properties for Dired file in the echo area."
2413 (interactive)
2414 (let* ((file (dired-get-filename))
2415 (file-name (file-name-nondirectory file))
2416 (dired-buf (buffer-name (current-buffer)))
2417 (props (mapconcat #'identity (image-dired-list-tags file) ", "))
2418 (comment (image-dired-get-comment file))
2419 (message-log-max nil))
2420 (if file-name
2421 (message "%s"
2422 (image-dired-format-properties-string
2423 dired-buf
2424 file-name
2425 props
2426 comment)))))
2427
2428
2429
2430;;; Gallery support
2431
2432;; TODO:
2433;; * Support gallery creation when using per-directory thumbnail
2434;; storage.
2435;; * Enhanced gallery creation with basic CSS-support and pagination
2436;; of tag pages with many pictures.
2437
2438(defgroup image-dired-gallery nil
2439 "Image-Dired support for generating a HTML gallery."
2440 :prefix "image-dired-"
2441 :group 'image-dired
2442 :version "29.1")
2443
2444(defcustom image-dired-gallery-dir
2445 (expand-file-name ".image-dired_gallery" image-dired-dir)
2446 "Directory to store generated gallery html pages.
2447The name of this directory needs to be \"shared\" to the public
2448so that it can access the index.html page that image-dired creates."
2449 :type 'directory)
2450
2451(defcustom image-dired-gallery-image-root-url
2452 "https://example.org/image-diredpics"
2453 "URL where the full size images are to be found on your web server.
2454Note that this URL has to be configured on your web server.
2455Image-Dired expects to find pictures in this directory.
2456This is used by `image-dired-gallery-generate'."
2457 :type 'string
2458 :version "29.1")
2459
2460(defcustom image-dired-gallery-thumb-image-root-url
2461 "https://example.org/image-diredthumbs"
2462 "URL where the thumbnail images are to be found on your web server.
2463Note that URL path has to be configured on your web server.
2464Image-Dired expects to find pictures in this directory.
2465This is used by `image-dired-gallery-generate'."
2466 :type 'string
2467 :version "29.1")
2468
2469(defcustom image-dired-gallery-hidden-tags
2470 (list "private" "hidden" "pending")
2471 "List of \"hidden\" tags.
2472Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
2473 :type '(repeat string))
2474
2475(defvar image-dired-tag-file-list nil
2476 "List to store tag-file structure.")
2477
2478(defvar image-dired-file-tag-list nil
2479 "List to store file-tag structure.")
2480
2481(defvar image-dired-file-comment-list nil
2482 "List to store file comments.")
2483
2484(defun image-dired--add-to-tag-file-lists (tag file)
2485 "Helper function used from `image-dired--create-gallery-lists'.
2486
2487Add TAG to FILE in one list and FILE to TAG in the other.
2488
2489Lisp structures look like the following:
2490
2491image-dired-file-tag-list:
2492
2493 ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...)
2494 (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...)
2495 ...)
2496
2497image-dired-tag-file-list:
2498
2499 ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...)
2500 (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...)
2501 ...)"
2502 ;; Add tag to file list
2503 (let (curr)
2504 (if image-dired-file-tag-list
2505 (if (setq curr (assoc file image-dired-file-tag-list))
2506 (setcdr curr (cons tag (cdr curr)))
2507 (setcdr image-dired-file-tag-list
2508 (cons (list file tag) (cdr image-dired-file-tag-list))))
2509 (setq image-dired-file-tag-list (list (list file tag))))
2510 ;; Add file to tag list
2511 (if image-dired-tag-file-list
2512 (if (setq curr (assoc tag image-dired-tag-file-list))
2513 (if (not (member file curr))
2514 (setcdr curr (cons file (cdr curr))))
2515 (setcdr image-dired-tag-file-list
2516 (cons (list tag file) (cdr image-dired-tag-file-list))))
2517 (setq image-dired-tag-file-list (list (list tag file))))))
2518
2519(defun image-dired--add-to-file-comment-list (file comment)
2520 "Helper function used from `image-dired--create-gallery-lists'.
2521
2522For FILE, add COMMENT to list.
2523
2524Lisp structure looks like the following:
2525
2526image-dired-file-comment-list:
2527
2528 ((\"filename1\" . \"comment1\")
2529 (\"filename2\" . \"comment2\")
2530 ...)"
2531 (if image-dired-file-comment-list
2532 (if (not (assoc file image-dired-file-comment-list))
2533 (setcdr image-dired-file-comment-list
2534 (cons (cons file comment)
2535 (cdr image-dired-file-comment-list))))
2536 (setq image-dired-file-comment-list (list (cons file comment)))))
2537
2538(defun image-dired--create-gallery-lists ()
2539 "Create temporary lists used by `image-dired-gallery-generate'."
2540 (image-dired-sane-db-file)
2541 (image-dired--with-db-file
2542 (let (end beg file row-tags)
2543 (setq image-dired-tag-file-list nil)
2544 (setq image-dired-file-tag-list nil)
2545 (setq image-dired-file-comment-list nil)
2546 (goto-char (point-min))
2547 (while (search-forward-regexp "^." nil t)
2548 (end-of-line)
2549 (setq end (point))
2550 (beginning-of-line)
2551 (setq beg (point))
2552 (unless (search-forward ";" end nil)
2553 (error "Something is really wrong, check format of database"))
2554 (setq row-tags (split-string
2555 (buffer-substring beg end) ";"))
2556 (setq file (car row-tags))
2557 (dolist (x (cdr row-tags))
2558 (if (not (string-match "^comment:\\(.*\\)" x))
2559 (image-dired--add-to-tag-file-lists x file)
2560 (image-dired--add-to-file-comment-list file (match-string 1 x)))))))
2561 ;; Sort tag-file list
2562 (setq image-dired-tag-file-list
2563 (sort image-dired-tag-file-list
2564 (lambda (x y)
2565 (string< (car x) (car y))))))
2566
2567(defun image-dired--hidden-p (file)
2568 "Return t if image FILE has a \"hidden\" tag."
2569 (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
2570 if (member tag image-dired-gallery-hidden-tags) return t))
2571
2572(defun image-dired-gallery-generate ()
2573 "Generate gallery pages.
2574First we create a couple of Lisp structures from the database to make
2575it easier to generate, then HTML-files are created in
2576`image-dired-gallery-dir'."
2577 (interactive)
2578 (if (eq 'per-directory image-dired-thumbnail-storage)
2579 (error "Currently, gallery generation is not supported \
2580when using per-directory thumbnail file storage"))
2581 (image-dired--create-gallery-lists)
2582 (let ((tags image-dired-tag-file-list)
2583 (index-file (format "%s/index.html" image-dired-gallery-dir))
2584 count tag tag-file
2585 comment file-tags tag-link tag-link-list)
2586 ;; Make sure gallery root exist
2587 (if (file-exists-p image-dired-gallery-dir)
2588 (if (not (file-directory-p image-dired-gallery-dir))
2589 (error "Variable image-dired-gallery-dir is not a directory"))
2590 ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
2591 (make-directory image-dired-gallery-dir))
2592 ;; Open index file
2593 (with-temp-file index-file
2594 (if (file-exists-p index-file)
2595 (insert-file-contents index-file))
2596 (insert "<html>\n")
2597 (insert " <body>\n")
2598 (insert " <h2>Image-Dired Gallery</h2>\n")
2599 (insert (format "<p>\n Gallery generated %s\n <p>\n"
2600 (current-time-string)))
2601 (insert " <h3>Tag index</h3>\n")
2602 (setq count 1)
2603 ;; Pre-generate list of all tag links
2604 (dolist (curr tags)
2605 (setq tag (car curr))
2606 (when (not (member tag image-dired-gallery-hidden-tags))
2607 (setq tag-link (format "<a href=\"%d.html\">%s</a>" count tag))
2608 (if tag-link-list
2609 (setq tag-link-list
2610 (append tag-link-list (list (cons tag tag-link))))
2611 (setq tag-link-list (list (cons tag tag-link))))
2612 (setq count (1+ count))))
2613 (setq count 1)
2614 ;; Main loop where we generated thumbnail pages per tag
2615 (dolist (curr tags)
2616 (setq tag (car curr))
2617 ;; Don't display hidden tags
2618 (when (not (member tag image-dired-gallery-hidden-tags))
2619 ;; Insert link to tag page in index
2620 (insert (format " %s<br>\n" (cdr (assoc tag tag-link-list))))
2621 ;; Open per-tag file
2622 (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count))
2623 (with-temp-file tag-file
2624 (if (file-exists-p tag-file)
2625 (insert-file-contents tag-file))
2626 (erase-buffer)
2627 (insert "<html>\n")
2628 (insert " <body>\n")
2629 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2630 (insert (format " <h2>Images with tag &quot;%s&quot;</h2>" tag))
2631 ;; Main loop for files per tag page
2632 (dolist (file (cdr curr))
2633 (unless (image-dired-hidden-p file)
2634 ;; Insert thumbnail with link to full image
2635 (insert
2636 (format "<a href=\"%s/%s\"><img src=\"%s/%s\"%s></a>\n"
2637 image-dired-gallery-image-root-url
2638 (file-name-nondirectory file)
2639 image-dired-gallery-thumb-image-root-url
2640 (file-name-nondirectory (image-dired-thumb-name file)) file))
2641 ;; Insert comment, if any
2642 (if (setq comment (cdr (assoc file image-dired-file-comment-list)))
2643 (insert (format "<br>\n%s<br>\n" comment))
2644 (insert "<br>\n"))
2645 ;; Insert links to other tags, if any
2646 (when (> (length
2647 (setq file-tags (assoc file image-dired-file-tag-list))) 2)
2648 (insert "[ ")
2649 (dolist (extra-tag file-tags)
2650 ;; Only insert if not file name or the main tag
2651 (if (and (not (equal extra-tag tag))
2652 (not (equal extra-tag file)))
2653 (insert
2654 (format "%s " (cdr (assoc extra-tag tag-link-list))))))
2655 (insert "]<br>\n"))))
2656 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2657 (insert " </body>\n")
2658 (insert "</html>\n"))
2659 (setq count (1+ count))))
2660 (insert " </body>\n")
2661 (insert "</html>"))))
2662
2663
2664;;; Tag support
2665
2666(defvar image-dired-widget-list nil
2667 "List to keep track of meta data in edit buffer.")
2668
2669(declare-function widget-forward "wid-edit" (arg))
2670
2671;;;###autoload
2672(defun image-dired-dired-edit-comment-and-tags ()
2673 "Edit comment and tags of current or marked image files.
2674Edit comment and tags for all marked image files in an
2675easy-to-use form."
2676 (interactive)
2677 (setq image-dired-widget-list nil)
2678 ;; Setup buffer.
2679 (let ((files (dired-get-marked-files)))
2680 (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
2681 (kill-all-local-variables)
2682 (let ((inhibit-read-only t))
2683 (erase-buffer))
2684 (remove-overlays)
2685 ;; Some help for the user.
2686 (widget-insert
2687"\nEdit comments and tags for each image. Separate multiple tags
2688with a comma. Move forward between fields using TAB or RET.
2689Move to the previous field using backtab (S-TAB). Save by
2690activating the Save button at the bottom of the form or cancel
2691the operation by activating the Cancel button.\n\n")
2692 ;; Here comes all images and a comment and tag field for each
2693 ;; image.
2694 (let (thumb-file img comment-widget tag-widget)
2695
2696 (dolist (file files)
2697
2698 (setq thumb-file (image-dired-thumb-name file)
2699 img (create-image thumb-file))
2700
2701 (insert-image img)
2702 (widget-insert "\n\nComment: ")
2703 (setq comment-widget
2704 (widget-create 'editable-field
2705 :size 60
2706 :format "%v "
2707 :value (or (image-dired-get-comment file) "")))
2708 (widget-insert "\nTags: ")
2709 (setq tag-widget
2710 (widget-create 'editable-field
2711 :size 60
2712 :format "%v "
2713 :value (or (mapconcat
2714 #'identity
2715 (image-dired-list-tags file)
2716 ",") "")))
2717 ;; Save information in all widgets so that we can use it when
2718 ;; the user saves the form.
2719 (setq image-dired-widget-list
2720 (append image-dired-widget-list
2721 (list (list file comment-widget tag-widget))))
2722 (widget-insert "\n\n")))
2723
2724 ;; Footer with Save and Cancel button.
2725 (widget-insert "\n")
2726 (widget-create 'push-button
2727 :notify
2728 (lambda (&rest _ignore)
2729 (image-dired-save-information-from-widgets)
2730 (bury-buffer)
2731 (message "Done"))
2732 "Save")
2733 (widget-insert " ")
2734 (widget-create 'push-button
2735 :notify
2736 (lambda (&rest _ignore)
2737 (bury-buffer)
2738 (message "Operation canceled"))
2739 "Cancel")
2740 (widget-insert "\n")
2741 (use-local-map widget-keymap)
2742 (widget-setup)
2743 ;; Jump to the first widget.
2744 (widget-forward 1)))
2745
2746(defun image-dired-save-information-from-widgets ()
2747 "Save information found in `image-dired-widget-list'.
2748Use the information in `image-dired-widget-list' to save comments and
2749tags to their respective image file. Internal function used by
2750`image-dired-dired-edit-comment-and-tags'."
2751 (let (file comment tag-string tag-list lst)
2752 (image-dired-write-comments
2753 (mapcar
2754 (lambda (widget)
2755 (setq file (car widget)
2756 comment (widget-value (cadr widget)))
2757 (cons file comment))
2758 image-dired-widget-list))
2759 (image-dired-write-tags
2760 (dolist (widget image-dired-widget-list lst)
2761 (setq file (car widget)
2762 tag-string (widget-value (car (cddr widget)))
2763 tag-list (split-string tag-string ","))
2764 (dolist (tag tag-list)
2765 (push (cons file tag) lst))))))
2766
2767
2768;;; bookmark.el support
2769
2770(declare-function bookmark-make-record-default
2771 "bookmark" (&optional no-file no-context posn))
2772(declare-function bookmark-prop-get "bookmark" (bookmark prop))
2773
2774(defun image-dired-bookmark-name ()
2775 "Create a default bookmark name for the current EWW buffer."
2776 (file-name-nondirectory
2777 (directory-file-name
2778 (file-name-directory (image-dired-original-file-name)))))
2779
2780(defun image-dired-bookmark-make-record ()
2781 "Create a bookmark for the current EWW buffer."
2782 `(,(image-dired-bookmark-name)
2783 ,@(bookmark-make-record-default t)
2784 (location . ,(file-name-directory (image-dired-original-file-name)))
2785 (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name)))
2786 (handler . image-dired-bookmark-jump)))
2787
2788;;;###autoload
2789(defun image-dired-bookmark-jump (bookmark)
2790 "Default bookmark handler for Image-Dired buffers."
2791 ;; User already cached thumbnails, so disable any checking.
2792 (let ((image-dired-show-all-from-dir-max-files nil))
2793 (image-dired (bookmark-prop-get bookmark 'location))
2794 ;; TODO: Go to the bookmarked file, if it exists.
2795 ;; (bookmark-prop-get bookmark 'image-dired-file)
2796 (goto-char (point-min))))
2797
2798(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired")
2799
2800;;; Obsolete
2801
2802;;;###autoload
2803(define-obsolete-function-alias 'tumme #'image-dired "24.4")
2804
2805;;;###autoload
2806(define-obsolete-function-alias 'image-dired-setup-dired-keybindings
2807 #'image-dired-minor-mode "26.1")
2808
2809(defcustom image-dired-temp-image-file
2810 (expand-file-name ".image-dired_temp" image-dired-dir)
2811 "Name of temporary image file used by various commands."
2812 :type 'file)
2813(make-obsolete-variable 'image-dired-temp-image-file
2814 "no longer used." "29.1")
2815
2816(defcustom image-dired-cmd-create-temp-image-program
2817 (if (executable-find "gm") "gm" "convert")
2818 "Executable used to create temporary image.
2819Used together with `image-dired-cmd-create-temp-image-options'."
2820 :type 'file
2821 :version "29.1")
2822(make-obsolete-variable 'image-dired-cmd-create-temp-image-program
2823 "no longer used." "29.1")
2824
2825(defcustom image-dired-cmd-create-temp-image-options
2826 (let ((opts '("-size" "%wx%h" "%f[0]"
2827 "-resize" "%wx%h>"
2828 "-strip" "jpeg:%t")))
2829 (if (executable-find "gm") (cons "convert" opts) opts))
2830 "Options of command used to create temporary image for display window.
2831Used together with `image-dired-cmd-create-temp-image-program',
2832Available format specifiers are: %w and %h which are replaced by
2833the calculated max size for width and height in the image display window,
2834%f which is replaced by the file name of the original image and %t which
2835is replaced by the file name of the temporary file."
2836 :version "29.1"
2837 :type '(repeat (string :tag "Argument")))
2838(make-obsolete-variable 'image-dired-cmd-create-temp-image-options
2839 "no longer used." "29.1")
2840
2841(defcustom image-dired-display-window-width-correction 1
2842 "Number to be used to correct image display window width.
2843Change if the default (1) does not work (i.e. if the image does not
2844completely fit)."
2845 :type 'integer)
2846(make-obsolete-variable 'image-dired-display-window-width-correction
2847 "no longer used." "29.1")
2848
2849(defcustom image-dired-display-window-height-correction 0
2850 "Number to be used to correct image display window height.
2851Change if the default (0) does not work (i.e. if the image does not
2852completely fit)."
2853 :type 'integer)
2854(make-obsolete-variable 'image-dired-display-window-height-correction
2855 "no longer used." "29.1")
2856
2857(defun image-dired-display-window-width (window)
2858 "Return width, in pixels, of WINDOW."
2859 (declare (obsolete nil "29.1"))
2860 (- (image-dired-window-width-pixels window)
2861 image-dired-display-window-width-correction))
2862
2863(defun image-dired-display-window-height (window)
2864 "Return height, in pixels, of WINDOW."
2865 (declare (obsolete nil "29.1"))
2866 (- (image-dired-window-height-pixels window)
2867 image-dired-display-window-height-correction))
2868
2869(defun image-dired-window-height-pixels (window)
2870 "Calculate WINDOW height in pixels."
2871 (declare (obsolete nil "29.1"))
2872 ;; Note: The mode-line consumes one line
2873 (* (- (window-height window) 1) (frame-char-height)))
2874
2875(defcustom image-dired-cmd-read-exif-data-program "exiftool"
2876 "Program used to read EXIF data to image.
2877Used together with `image-dired-cmd-read-exif-data-options'."
2878 :type 'file)
2879(make-obsolete-variable 'image-dired-cmd-read-exif-data-program
2880 "use `exif-parse-file' and `exif-field' instead." "29.1")
2881
2882(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f")
2883 "Arguments of command used to read EXIF data.
2884Used with `image-dired-cmd-read-exif-data-program'.
2885Available format specifiers are: %f which is replaced
2886by the image file name and %t which is replaced by the tag name."
2887 :version "26.1"
2888 :type '(repeat (string :tag "Argument")))
2889(make-obsolete-variable 'image-dired-cmd-read-exif-data-options
2890 "use `exif-parse-file' and `exif-field' instead." "29.1")
2891
2892(defun image-dired-get-exif-data (file tag-name)
2893 "From FILE, return EXIF tag TAG-NAME."
2894 (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1"))
2895 (image-dired--check-executable-exists
2896 'image-dired-cmd-read-exif-data-program)
2897 (let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
2898 (spec (list (cons ?f file) (cons ?t tag-name)))
2899 tag-value)
2900 (with-current-buffer buf
2901 (delete-region (point-min) (point-max))
2902 (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
2903 nil t nil
2904 (mapcar
2905 (lambda (arg) (format-spec arg spec))
2906 image-dired-cmd-read-exif-data-options))
2907 0))
2908 (error "Could not get EXIF tag")
2909 (goto-char (point-min))
2910 ;; Clean buffer from newlines and carriage returns before
2911 ;; getting final info
2912 (while (search-forward-regexp "[\n\r]" nil t)
2913 (replace-match "" nil t))
2914 (setq tag-value (buffer-substring (point-min) (point-max)))))
2915 tag-value))
2916
2917(defcustom image-dired-cmd-rotate-thumbnail-program
2918 (if (executable-find "gm") "gm" "mogrify")
2919 "Executable used to rotate thumbnail.
2920Used together with `image-dired-cmd-rotate-thumbnail-options'."
2921 :type 'file
2922 :version "29.1")
2923(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1")
2924
2925(defcustom image-dired-cmd-rotate-thumbnail-options
2926 (let ((opts '("-rotate" "%d" "%t")))
2927 (if (executable-find "gm") (cons "mogrify" opts) opts))
2928 "Arguments of command used to rotate thumbnail image.
2929Used with `image-dired-cmd-rotate-thumbnail-program'.
2930Available format specifiers are: %d which is replaced by the
2931number of (positive) degrees to rotate the image, normally 90 or 270
2932\(for 90 degrees right and left), %t which is replaced by the file name
2933of the thumbnail file."
2934 :version "29.1"
2935 :type '(repeat (string :tag "Argument")))
2936(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1")
2937
2938(defun image-dired-rotate-thumbnail (degrees)
2939 "Rotate thumbnail DEGREES degrees."
2940 (declare (obsolete image-dired-refresh-thumb "29.1"))
2941 (image-dired--check-executable-exists
2942 'image-dired-cmd-rotate-thumbnail-program)
2943 (if (not (image-dired-image-at-point-p))
2944 (message "No thumbnail at point")
2945 (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
2946 (thumb (expand-file-name file))
2947 (spec (list (cons ?d degrees) (cons ?t thumb))))
2948 (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil
2949 (mapcar (lambda (arg) (format-spec arg spec))
2950 image-dired-cmd-rotate-thumbnail-options))
2951 (clear-image-cache thumb))))
2952
2953(defun image-dired-rotate-thumbnail-left ()
2954 "Rotate thumbnail left (counter clockwise) 90 degrees."
2955 (declare (obsolete image-dired-refresh-thumb "29.1"))
2956 (interactive)
2957 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2958 (image-dired-rotate-thumbnail "270")))
2959
2960(defun image-dired-rotate-thumbnail-right ()
2961 "Rotate thumbnail counter right (clockwise) 90 degrees."
2962 (declare (obsolete image-dired-refresh-thumb "29.1"))
2963 (interactive)
2964 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2965 (image-dired-rotate-thumbnail "90")))
2966
2967(defun image-dired-modify-mark-on-thumb-original-file (command)
2968 "Modify mark in Dired buffer.
2969COMMAND is one of `mark' for marking file in Dired, `unmark' for
2970unmarking file in Dired or `flag' for flagging file for delete in
2971Dired."
2972 (declare (obsolete image-dired--on-file-in-dired-buffer "29.1"))
2973 (let ((file-name (image-dired-original-file-name))
2974 (dired-buf (image-dired-associated-dired-buffer)))
2975 (if (not (and dired-buf file-name))
2976 (message "No image, or image with correct properties, at point")
2977 (with-current-buffer dired-buf
2978 (message "%s" file-name)
2979 (when (dired-goto-file file-name)
2980 (cond ((eq command 'mark) (dired-mark 1))
2981 ((eq command 'unmark) (dired-unmark 1))
2982 ((eq command 'toggle)
2983 (if (image-dired-dired-file-marked-p)
2984 (dired-unmark 1)
2985 (dired-mark 1)))
2986 ((eq command 'flag) (dired-flag-file-deletion 1)))
2987 (image-dired-thumb-update-marks))))))
2988
2989(defun image-dired-display-current-image-full ()
2990 "Display current image in full size."
2991 (declare (obsolete image-transform-original "29.1"))
2992 (interactive nil image-dired-thumbnail-mode)
2993 (let ((file (image-dired-original-file-name)))
2994 (if file
2995 (progn
2996 (image-dired-display-image file)
2997 (with-current-buffer image-dired-display-image-buffer
2998 (image-transform-original)))
2999 (error "No original file name at point"))))
3000
3001(defun image-dired-display-current-image-sized ()
3002 "Display current image in sized to fit window dimensions."
3003 (declare (obsolete image-mode-fit-frame "29.1"))
3004 (interactive nil image-dired-thumbnail-mode)
3005 (let ((file (image-dired-original-file-name)))
3006 (if file
3007 (progn
3008 (image-dired-display-image file))
3009 (error "No original file name at point"))))
3010
3011(defun image-dired-add-to-tag-file-list (tag file)
3012 "Add relation between TAG and FILE."
3013 (declare (obsolete nil "29.1"))
3014 (let (curr)
3015 (if image-dired-tag-file-list
3016 (if (setq curr (assoc tag image-dired-tag-file-list))
3017 (if (not (member file curr))
3018 (setcdr curr (cons file (cdr curr))))
3019 (setcdr image-dired-tag-file-list
3020 (cons (list tag file) (cdr image-dired-tag-file-list))))
3021 (setq image-dired-tag-file-list (list (list tag file))))))
3022
3023(defun image-dired-display-thumb-properties ()
3024 "Display thumbnail properties in the echo area."
3025 (declare (obsolete image-dired-update-header-line "29.1"))
3026 (image-dired-update-header-line))
3027
3028(defvar image-dired-slideshow-count 0
3029 "Keeping track on number of images in slideshow.")
3030(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1")
3031
3032(defvar image-dired-slideshow-times 0
3033 "Number of pictures to display in slideshow.")
3034(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1")
3035
3036(define-obsolete-function-alias 'image-dired-create-display-image-buffer
3037 #'ignore "29.1")
3038(define-obsolete-function-alias 'image-dired-create-gallery-lists
3039 #'image-dired--create-gallery-lists "29.1")
3040(define-obsolete-function-alias 'image-dired-add-to-file-comment-list
3041 #'image-dired--add-to-file-comment-list "29.1")
3042(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists
3043 #'image-dired--add-to-tag-file-lists "29.1")
3044(define-obsolete-function-alias 'image-dired-hidden-p
3045 #'image-dired--hidden-p "29.1")
3046
3047;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3048;;;;;;;;; TEST-SECTION ;;;;;;;;;;;
3049;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3050
3051;; (defvar image-dired-dir-max-size 12300000)
3052
3053;; (defun image-dired-test-clean-old-files ()
3054;; "Clean `image-dired-dir' from old thumbnail files.
3055;; \"Oldness\" measured using last access time. If the total size of all
3056;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size',
3057;; old files are deleted until the max size is reached."
3058;; (let* ((files
3059;; (sort
3060;; (mapcar
3061;; (lambda (f)
3062;; (let ((fattribs (file-attributes f)))
3063;; `(,(file-attribute-access-time fattribs)
3064;; ,(file-attribute-size fattribs) ,f)))
3065;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$"))
3066;; ;; Sort function. Compare time between two files.
3067;; (lambda (l1 l2)
3068;; (time-less-p (car l1) (car l2)))))
3069;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files))))
3070;; (while (> dirsize image-dired-dir-max-size)
3071;; (y-or-n-p
3072;; (format "Size of thumbnail directory: %d, delete old file %s? "
3073;; dirsize (cadr (cdar files))))
3074;; (delete-file (cadr (cdar files)))
3075;; (setq dirsize (- dirsize (car (cdar files))))
3076;; (setq files (cdr files)))))
3077
3078(provide 'image-dired)
3079
3080;;; 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 @@
1;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*-
2
3;; Copyright (C) 2005-2022 Free Software Foundation, Inc.
4
5;; Version: 0.4.11
6;; Keywords: multimedia
7;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com>
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software: you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;; BACKGROUND
27;; ==========
28;;
29;; I needed a program to browse, organize and tag my pictures. I got
30;; tired of the old gallery program I used as it did not allow
31;; multi-file operations easily. Also, it put things out of my
32;; control. Image viewing programs I tested did not allow multi-file
33;; operations or did not do what I wanted it to.
34;;
35;; So, I got the idea to use the wonderful functionality of Emacs and
36;; `dired' to do it. It would allow me to do almost anything I wanted,
37;; which is basically just to browse all my pictures in an easy way,
38;; letting me manipulate and tag them in various ways. `dired' already
39;; provide all the file handling and navigation facilities; I only
40;; needed to add some functions to display the images.
41;;
42;; I briefly tried out thumbs.el, and although it seemed more
43;; powerful than this package, it did not work the way I wanted to. It
44;; was too slow to create thumbnails of all files in a directory (I
45;; currently keep all my 2000+ images in the same directory) and
46;; browsing the thumbnail buffer was slow too. image-dired.el will not
47;; create thumbnails until they are needed and the browsing is done
48;; quickly and easily in Dired. I copied a great deal of ideas and
49;; code from there though... :)
50;;
51;; `image-dired' stores the thumbnail files in `image-dired-dir'
52;; using the file name format ORIGNAME.thumb.ORIGEXT. For example
53;; ~/.emacs.d/image-dired/myimage01.thumb.jpg. The "database" is for
54;; now just a plain text file with the following format:
55;;
56;; file-name-non-directory;comment:comment-text;tag1;tag2;tag3;...;tagN
57;;
58;;
59;; PREREQUISITES
60;; =============
61;;
62;; * The GraphicsMagick or ImageMagick package; Image-Dired uses
63;; whichever is available.
64;;
65;; A) For GraphicsMagick, `gm' is used.
66;; Find it here: http://www.graphicsmagick.org/
67;;
68;; B) For ImageMagick, `convert' and `mogrify' are used.
69;; Find it here: https://www.imagemagick.org.
70;;
71;; * For non-lossy rotation of JPEG images, the JpegTRAN program is
72;; needed.
73;;
74;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is
75;; needed. It can be found here: https://exiftool.org/. This
76;; function is, among other things, used for writing comments to
77;; image files using `image-dired-thumbnail-set-image-description'.
78;;
79;;
80;; USAGE
81;; =====
82;;
83;; This information has been moved to the manual. Type `C-h r' to open
84;; the Emacs manual and go to the node Thumbnails by typing `g
85;; Image-Dired RET'.
86;;
87;; Quickstart: M-x image-dired RET DIRNAME RET
88;;
89;; where DIRNAME is a directory containing image files.
90;;
91;; LIMITATIONS
92;; ===========
93;;
94;; * Supports all image formats that Emacs and convert supports, but
95;; the thumbnails are hard-coded to JPEG or PNG format. It uses
96;; JPEG by default, but can optionally follow the Thumbnail Managing
97;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user
98;; option `image-dired-thumbnail-storage'.
99;;
100;; * WARNING: The "database" format used might be changed so keep a
101;; backup of `image-dired-db-file' when testing new versions.
102;;
103;; TODO
104;; ====
105;;
106;; * Investigate if it is possible to also write the tags to the image
107;; files.
108;;
109;; * From thumbs.el: Add an option for clean-up/max-size functionality
110;; for thumbnail directory.
111;;
112;; * From thumbs.el: Add setroot function.
113;;
114;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out
115;; which is best, saving old batch just before inserting new, or
116;; saving the current batch in the ring when inserting it. Adding
117;; it probably needs rewriting `image-dired-display-thumbs' to be more general.
118;;
119;; * Find some way of toggling on and off really nice keybindings in
120;; Dired (for example, using C-n or <down> instead of C-S-n).
121;; Richard suggested that we could keep C-t as prefix for
122;; image-dired commands as it is currently not used in Dired. He
123;; also suggested that `dired-next-line' and `dired-previous-line'
124;; figure out if image-dired is enabled in the current buffer and,
125;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line',
126;; respectively. Update: This is partly done; some bindings have
127;; now been added to Dired.
128;;
129;; * In some way keep track of buffers and windows and stuff so that
130;; it works as the user expects.
131;;
132;; * More/better documentation.
133
134;;; Code:
135
136(require 'dired)
137(require 'exif)
138(require 'image-mode)
139(require 'widget)
140(require 'xdg)
141
142(eval-when-compile
143 (require 'cl-lib)
144 (require 'wid-edit))
145
146
147;;; Customizable variables
148
149(defgroup image-dired nil
150 "Use Dired to browse your images as thumbnails, and more."
151 :prefix "image-dired-"
152 :link '(info-link "(emacs) Image-Dired")
153 :group 'multimedia)
154
155(defcustom image-dired-dir (locate-user-emacs-file "image-dired/")
156 "Directory where thumbnail images are stored.
157
158The value of this option will be ignored if Image-Dired is
159customized to use the Thumbnail Managing Standard; they will be
160saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See
161`image-dired-thumbnail-storage'."
162 :type 'directory)
163
164(defcustom image-dired-thumbnail-storage 'use-image-dired-dir
165 "How `image-dired' stores thumbnail files.
166There are two ways that Image-Dired can store and generate
167thumbnails. If you set this variable to one of the two following
168values, they will be stored in the JPEG format:
169
170- `use-image-dired-dir' means that the thumbnails are stored in a
171 central directory.
172
173- `per-directory' means that each thumbnail is stored in a
174 subdirectory called \".image-dired\" in the same directory
175 where the image file is.
176
177It can also use the \"Thumbnail Managing Standard\", which allows
178sharing of thumbnails across different programs. Thumbnails will
179be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in
180`image-dired-dir'. Thumbnails are saved in the PNG format, and
181can be one of the following sizes:
182
183- `standard' means use thumbnails sized 128x128.
184- `standard-large' means use thumbnails sized 256x256.
185- `standard-x-large' means use thumbnails sized 512x512.
186- `standard-xx-large' means use thumbnails sized 1024x1024.
187
188For more information on the Thumbnail Managing Standard, see:
189https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html"
190 :type '(choice :tag "How to store thumbnail files"
191 (const :tag "Use image-dired-dir" use-image-dired-dir)
192 (const :tag "Thumbnail Managing Standard (normal 128x128)"
193 standard)
194 (const :tag "Thumbnail Managing Standard (large 256x256)"
195 standard-large)
196 (const :tag "Thumbnail Managing Standard (larger 512x512)"
197 standard-x-large)
198 (const :tag "Thumbnail Managing Standard (extra large 1024x1024)"
199 standard-xx-large)
200 (const :tag "Per-directory" per-directory))
201 :version "29.1")
202
203(defconst image-dired--thumbnail-standard-sizes
204 '( standard standard-large
205 standard-x-large standard-xx-large)
206 "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.")
207
208(defcustom image-dired-db-file
209 (expand-file-name ".image-dired_db" image-dired-dir)
210 "Database file where file names and their associated tags are stored."
211 :type 'file)
212
213(defcustom image-dired-cmd-create-thumbnail-program
214 (if (executable-find "gm") "gm" "convert")
215 "Executable used to create thumbnail.
216Used together with `image-dired-cmd-create-thumbnail-options'."
217 :type 'file
218 :version "29.1")
219
220(defcustom image-dired-cmd-create-thumbnail-options
221 (let ((opts '("-size" "%wx%h" "%f[0]"
222 "-resize" "%wx%h>"
223 "-strip" "jpeg:%t")))
224 (if (executable-find "gm") (cons "convert" opts) opts))
225 "Options of command used to create thumbnail image.
226Used with `image-dired-cmd-create-thumbnail-program'.
227Available format specifiers are: %w which is replaced by
228`image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height',
229%f which is replaced by the file name of the original image and %t
230which is replaced by the file name of the thumbnail file."
231 :version "29.1"
232 :type '(repeat (string :tag "Argument")))
233
234(defcustom image-dired-cmd-pngnq-program
235 ;; Prefer pngquant to pngnq-s9 as it is faster on my machine.
236 ;; The project also seems more active than the alternatives.
237 ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq.
238 ;; The pngnq project seems dead (?) since 2011 or so.
239 (or (executable-find "pngquant")
240 (executable-find "pngnq-s9")
241 (executable-find "pngnq"))
242 "The file name of the `pngquant' or `pngnq' program.
243It quantizes colors of PNG images down to 256 colors or fewer
244using the NeuQuant algorithm."
245 :version "29.1"
246 :type '(choice (const :tag "Not Set" nil) file))
247
248(defcustom image-dired-cmd-pngnq-options
249 (if (executable-find "pngquant")
250 '("--ext" "-nq8.png" "%t") ; same extension as "pngnq"
251 '("-f" "%t"))
252 "Arguments to pass `image-dired-cmd-pngnq-program'.
253Available format specifiers are the same as in
254`image-dired-cmd-create-thumbnail-options'."
255 :type '(repeat (string :tag "Argument"))
256 :version "29.1")
257
258(defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush")
259 "The file name of the `pngcrush' program.
260It optimizes the compression of PNG images. Also it adds PNG textual chunks
261with the information required by the Thumbnail Managing Standard."
262 :type '(choice (const :tag "Not Set" nil) file))
263
264(defcustom image-dired-cmd-pngcrush-options
265 `("-q"
266 "-text" "b" "Description" "Thumbnail of file://%f"
267 "-text" "b" "Software" ,(emacs-version)
268 ;; "-text b \"Thumb::Image::Height\" \"%oh\" "
269 ;; "-text b \"Thumb::Image::Mimetype\" \"%mime\" "
270 ;; "-text b \"Thumb::Image::Width\" \"%ow\" "
271 "-text" "b" "Thumb::MTime" "%m"
272 ;; "-text b \"Thumb::Size\" \"%b\" "
273 "-text" "b" "Thumb::URI" "file://%f"
274 "%q" "%t")
275 "Arguments for `image-dired-cmd-pngcrush-program'.
276Available format specifiers are the same as in
277`image-dired-cmd-create-thumbnail-options', with %q for a
278temporary file name (typically generated by pnqnq)."
279 :version "26.1"
280 :type '(repeat (string :tag "Argument")))
281
282(defcustom image-dired-cmd-optipng-program (executable-find "optipng")
283 "The file name of the `optipng' program."
284 :version "26.1"
285 :type '(choice (const :tag "Not Set" nil) file))
286
287(defcustom image-dired-cmd-optipng-options '("-o5" "%t")
288 "Arguments passed to `image-dired-cmd-optipng-program'.
289Available format specifiers are described in
290`image-dired-cmd-create-thumbnail-options'."
291 :version "26.1"
292 :type '(repeat (string :tag "Argument"))
293 :link '(url-link "man:optipng(1)"))
294
295(defcustom image-dired-cmd-create-standard-thumbnail-options
296 (append '("-size" "%wx%h" "%f[0]")
297 (unless (or image-dired-cmd-pngcrush-program
298 image-dired-cmd-pngnq-program)
299 (list
300 "-set" "Thumb::MTime" "%m"
301 "-set" "Thumb::URI" "file://%f"
302 "-set" "Description" "Thumbnail of file://%f"
303 "-set" "Software" (emacs-version)))
304 '("-thumbnail" "%wx%h>" "png:%t"))
305 "Options for creating thumbnails according to the Thumbnail Managing Standard.
306Available format specifiers are the same as in
307`image-dired-cmd-create-thumbnail-options', with %m for file modification time."
308 :version "26.1"
309 :type '(repeat (string :tag "Argument")))
310
311(defcustom image-dired-cmd-rotate-original-program
312 "jpegtran"
313 "Executable used to rotate original image.
314Used together with `image-dired-cmd-rotate-original-options'."
315 :type 'file)
316
317(defcustom image-dired-cmd-rotate-original-options
318 '("-rotate" "%d" "-copy" "all" "-outfile" "%t" "%o")
319 "Arguments of command used to rotate original image.
320Used with `image-dired-cmd-rotate-original-program'.
321Available format specifiers are: %d which is replaced by the
322number of (positive) degrees to rotate the image, normally 90 or
323270 \(for 90 degrees right and left), %o which is replaced by the
324original image file name and %t which is replaced by
325`image-dired-temp-image-file'."
326 :version "26.1"
327 :type '(repeat (string :tag "Argument")))
328
329(defcustom image-dired-temp-rotate-image-file
330 (expand-file-name ".image-dired_rotate_temp" image-dired-dir)
331 "Temporary file for rotate operations."
332 :type 'file)
333
334(defcustom image-dired-rotate-original-ask-before-overwrite t
335 "Confirm overwrite of original file after rotate operation.
336If non-nil, ask user for confirmation before overwriting the
337original file with `image-dired-temp-rotate-image-file'."
338 :type 'boolean)
339
340(defcustom image-dired-cmd-write-exif-data-program
341 "exiftool"
342 "Program used to write EXIF data to image.
343Used together with `image-dired-cmd-write-exif-data-options'."
344 :type 'file)
345
346(defcustom image-dired-cmd-write-exif-data-options
347 '("-%t=%v" "%f")
348 "Arguments of command used to write EXIF data.
349Used with `image-dired-cmd-write-exif-data-program'.
350Available format specifiers are: %f which is replaced by
351the image file name, %t which is replaced by the tag name and %v
352which is replaced by the tag value."
353 :version "26.1"
354 :type '(repeat (string :tag "Argument")))
355
356(defcustom image-dired-thumb-size
357 (cond
358 ((eq 'standard image-dired-thumbnail-storage) 128)
359 ((eq 'standard-large image-dired-thumbnail-storage) 256)
360 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
361 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
362 (t 100))
363 "Size of thumbnails, in pixels.
364This is the default size for both `image-dired-thumb-width'
365and `image-dired-thumb-height'.
366
367The value of this option will be ignored if Image-Dired is
368customized to use the Thumbnail Managing Standard; the standard
369sizes will be used instead. See `image-dired-thumbnail-storage'."
370 :type 'integer)
371
372(defcustom image-dired-thumb-width image-dired-thumb-size
373 "Width of thumbnails, in pixels."
374 :type 'integer)
375
376(defcustom image-dired-thumb-height image-dired-thumb-size
377 "Height of thumbnails, in pixels."
378 :type 'integer)
379
380(defcustom image-dired-thumb-relief 2
381 "Size of button-like border around thumbnails."
382 :type 'integer)
383
384(defcustom image-dired-thumb-margin 2
385 "Size of the margin around thumbnails.
386This is where you see the cursor."
387 :type 'integer)
388
389(defcustom image-dired-thumb-visible-marks t
390 "Make marks and flags visible in thumbnail buffer.
391If non-nil, apply the `image-dired-thumb-mark' face to marked
392images and `image-dired-thumb-flagged' to images flagged for
393deletion."
394 :type 'boolean
395 :version "28.1")
396
397(defface image-dired-thumb-mark
398 '((((class color) (min-colors 16)) :background "DarkOrange")
399 (((class color)) :foreground "yellow"))
400 "Face for marked images in thumbnail buffer."
401 :version "29.1")
402
403(defface image-dired-thumb-flagged
404 '((((class color) (min-colors 88) (background light)) :background "Red3")
405 (((class color) (min-colors 88) (background dark)) :background "Pink")
406 (((class color) (min-colors 16) (background light)) :background "Red3")
407 (((class color) (min-colors 16) (background dark)) :background "Pink")
408 (((class color) (min-colors 8)) :background "red")
409 (t :inverse-video t))
410 "Face for images flagged for deletion in thumbnail buffer."
411 :version "29.1")
412
413(defcustom image-dired-line-up-method 'dynamic
414 "Default method for line-up of thumbnails in thumbnail buffer.
415Used by `image-dired-display-thumbs' and other functions that needs
416to line-up thumbnails. Dynamic means to use the available width of
417the window containing the thumbnail buffer, Fixed means to use
418`image-dired-thumbs-per-row', Interactive is for asking the user,
419and No line-up means that no automatic line-up will be done."
420 :type '(choice :tag "Default line-up method"
421 (const :tag "Dynamic" dynamic)
422 (const :tag "Fixed" fixed)
423 (const :tag "Interactive" interactive)
424 (const :tag "No line-up" none)))
425
426(defcustom image-dired-thumbs-per-row 3
427 "Number of thumbnails to display per row in thumb buffer."
428 :type 'integer)
429
430(defcustom image-dired-track-movement t
431 "The current state of the tracking and mirroring.
432For more information, see the documentation for
433`image-dired-toggle-movement-tracking'."
434 :type 'boolean)
435
436(defcustom image-dired-append-when-browsing nil
437 "Append thumbnails in thumbnail buffer when browsing.
438If non-nil, using `image-dired-next-line-and-display' and
439`image-dired-previous-line-and-display' will leave a trail of thumbnail
440images in the thumbnail buffer. If you enable this and want to clean
441the thumbnail buffer because it is filled with too many thumbnails,
442just call `image-dired-display-thumb' to display only the image at point.
443This value can be toggled using `image-dired-toggle-append-browsing'."
444 :type 'boolean)
445
446(defcustom image-dired-dired-disp-props t
447 "If non-nil, display properties for Dired file when browsing.
448Used by `image-dired-next-line-and-display',
449`image-dired-previous-line-and-display' and `image-dired-mark-and-display-next'.
450If the database file is large, this can slow down image browsing in
451Dired and you might want to turn it off."
452 :type 'boolean)
453
454(defcustom image-dired-display-properties-format "%b: %f (%t): %c"
455 "Display format for thumbnail properties.
456%b is replaced with associated Dired buffer name, %f with file
457name (without path) of original image file, %t with the list of
458tags and %c with the comment."
459 :type 'string)
460
461(defcustom image-dired-external-viewer
462 ;; TODO: Use mailcap, dired-guess-shell-alist-default,
463 ;; dired-view-command-alist.
464 (cond ((executable-find "display"))
465 ((executable-find "xli"))
466 ((executable-find "qiv") "qiv -t")
467 ((executable-find "feh") "feh"))
468 "Name of external viewer.
469Including parameters. Used when displaying original image from
470`image-dired-thumbnail-mode'."
471 :version "28.1"
472 :type '(choice string
473 (const :tag "Not Set" nil)))
474
475(defcustom image-dired-main-image-directory
476 (or (xdg-user-dir "PICTURES") "~/pics/")
477 "Name of main image directory, if any.
478Used by `image-dired-copy-with-exif-file-name'."
479 :type 'string
480 :version "29.1")
481
482(defcustom image-dired-show-all-from-dir-max-files 500
483 "Maximum number of files in directory before prompting.
484
485If there are more image files than this in a selected directory,
486the `image-dired-show-all-from-dir' command will ask for
487confirmation before creating the thumbnail buffer. If this
488variable is nil, it will never ask."
489 :type '(choice integer
490 (const :tag "Disable warning" nil))
491 :version "29.1")
492
493(defcustom image-dired-marking-shows-next t
494 "If non-nil, marking, unmarking or flagging an image shows the next image.
495
496This affects the following commands:
497\\<image-dired-thumbnail-mode-map>
498 `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file])
499 `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file])
500 `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])"
501 :type 'boolean
502 :version "29.1")
503
504
505;;; Util functions
506
507(defvar image-dired-debug nil
508 "Non-nil means enable debug messages.")
509
510(defun image-dired-debug-message (&rest args)
511 "Display debug message ARGS when `image-dired-debug' is non-nil."
512 (when image-dired-debug
513 (apply #'message args)))
514
515(defmacro image-dired--with-db-file (&rest body)
516 "Run BODY in a temp buffer containing `image-dired-db-file'.
517Return the last form in BODY."
518 (declare (indent 0) (debug t))
519 `(with-temp-buffer
520 (if (file-exists-p image-dired-db-file)
521 (insert-file-contents image-dired-db-file))
522 ,@body))
523
524(defun image-dired-dir ()
525 "Return the current thumbnail directory (from variable `image-dired-dir').
526Create the thumbnail directory if it does not exist."
527 (let ((image-dired-dir (file-name-as-directory
528 (expand-file-name image-dired-dir))))
529 (unless (file-directory-p image-dired-dir)
530 (with-file-modes #o700
531 (make-directory image-dired-dir t))
532 (message "Thumbnail directory created: %s" image-dired-dir))
533 image-dired-dir))
534
535(defun image-dired-insert-image (file type relief margin)
536 "Insert image FILE of image TYPE, using RELIEF and MARGIN, at point."
537 (let ((i `(image :type ,type
538 :file ,file
539 :relief ,relief
540 :margin ,margin)))
541 (insert-image i)))
542
543(defun image-dired-get-thumbnail-image (file)
544 "Return the image descriptor for a thumbnail of image file FILE."
545 (unless (string-match-p (image-file-name-regexp) file)
546 (error "%s is not a valid image file" file))
547 (let* ((thumb-file (image-dired-thumb-name file))
548 (thumb-attr (file-attributes thumb-file)))
549 (when (or (not thumb-attr)
550 (time-less-p (file-attribute-modification-time thumb-attr)
551 (file-attribute-modification-time
552 (file-attributes file))))
553 (image-dired-create-thumb file thumb-file))
554 (create-image thumb-file)))
555
556(defun image-dired-insert-thumbnail (file original-file-name
557 associated-dired-buffer)
558 "Insert thumbnail image FILE.
559Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER."
560 (let (beg end)
561 (setq beg (point))
562 (image-dired-insert-image
563 file
564 ;; Thumbnails are created asynchronously, so we might not yet
565 ;; have a file. But if it exists, it might have been cached from
566 ;; before and we should use it instead of our current settings.
567 (or (and (file-exists-p file)
568 (image-type-from-file-header file))
569 (and (memq image-dired-thumbnail-storage
570 image-dired--thumbnail-standard-sizes)
571 'png)
572 'jpeg)
573 image-dired-thumb-relief
574 image-dired-thumb-margin)
575 (setq end (point))
576 (add-text-properties
577 beg end
578 (list 'image-dired-thumbnail t
579 'original-file-name original-file-name
580 'associated-dired-buffer associated-dired-buffer
581 'tags (image-dired-list-tags original-file-name)
582 'mouse-face 'highlight
583 'comment (image-dired-get-comment original-file-name)))))
584
585(defun image-dired-thumb-name (file)
586 "Return absolute file name for thumbnail FILE.
587Depending on the value of `image-dired-thumbnail-storage', the
588file name of the thumbnail will vary:
589- For `use-image-dired-dir', make a SHA1-hash of the image file's
590 directory name and add that to make the thumbnail file name
591 unique.
592- For `per-directory' storage, just add a subdirectory.
593- For `standard' storage, produce the file name according to the
594 Thumbnail Managing Standard. Among other things, an MD5-hash
595 of the image file's directory name will be added to the
596 filename.
597See also `image-dired-thumbnail-storage'."
598 (cond ((memq image-dired-thumbnail-storage
599 image-dired--thumbnail-standard-sizes)
600 (let ((thumbdir (cl-case image-dired-thumbnail-storage
601 (standard "thumbnails/normal")
602 (standard-large "thumbnails/large")
603 (standard-x-large "thumbnails/x-large")
604 (standard-xx-large "thumbnails/xx-large"))))
605 (expand-file-name
606 ;; MD5 is mandated by the Thumbnail Managing Standard.
607 (concat (md5 (concat "file://" (expand-file-name file))) ".png")
608 (expand-file-name thumbdir (xdg-cache-home)))))
609 ((eq 'use-image-dired-dir image-dired-thumbnail-storage)
610 (let* ((f (expand-file-name file))
611 (hash
612 (md5 (file-name-as-directory (file-name-directory f)))))
613 (format "%s%s%s.thumb.%s"
614 (file-name-as-directory (expand-file-name (image-dired-dir)))
615 (file-name-base f)
616 (if hash (concat "_" hash) "")
617 (file-name-extension f))))
618 ((eq 'per-directory image-dired-thumbnail-storage)
619 (let ((f (expand-file-name file)))
620 (format "%s.image-dired/%s.thumb.%s"
621 (file-name-directory f)
622 (file-name-base f)
623 (file-name-extension f))))))
624
625(defun image-dired--check-executable-exists (executable)
626 (unless (executable-find (symbol-value executable))
627 (error "Executable %S not found" executable)))
628
629
630;;; Creating thumbnails
631
632(defun image-dired-thumb-size (dimension)
633 "Return thumb size depending on `image-dired-thumbnail-storage'.
634DIMENSION should be either the symbol `width' or `height'."
635 (cond
636 ((eq 'standard image-dired-thumbnail-storage) 128)
637 ((eq 'standard-large image-dired-thumbnail-storage) 256)
638 ((eq 'standard-x-large image-dired-thumbnail-storage) 512)
639 ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024)
640 (t (cl-ecase dimension
641 (width image-dired-thumb-width)
642 (height image-dired-thumb-height)))))
643
644(defvar image-dired--generate-thumbs-start nil
645 "Time when `display-thumbs' was called.")
646
647(defvar image-dired-queue nil
648 "List of items in the queue.
649Each item has the form (ORIGINAL-FILE TARGET-FILE).")
650
651(defvar image-dired-queue-active-jobs 0
652 "Number of active jobs in `image-dired-queue'.")
653
654(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2)))
655 "Maximum number of concurrent jobs permitted for generating images.
656Increase at own risk. If you want to experiment with this,
657consider setting `image-dired-debug' to a non-nil value to see
658the time spent on generating thumbnails. Run `image-clear-cache'
659and remove the cached thumbnail files between each trial run.")
660
661(defun image-dired-pngnq-thumb (spec)
662 "Quantize thumbnail described by format SPEC with pngnq(1)."
663 (let ((process
664 (apply #'start-process "image-dired-pngnq" nil
665 image-dired-cmd-pngnq-program
666 (mapcar (lambda (arg) (format-spec arg spec))
667 image-dired-cmd-pngnq-options))))
668 (setf (process-sentinel process)
669 (lambda (process status)
670 (if (and (eq (process-status process) 'exit)
671 (zerop (process-exit-status process)))
672 ;; Pass off to pngcrush, or just rename the
673 ;; THUMB-nq8.png file back to THUMB.png
674 (if (and image-dired-cmd-pngcrush-program
675 (executable-find image-dired-cmd-pngcrush-program))
676 (image-dired-pngcrush-thumb spec)
677 (let ((nq8 (cdr (assq ?q spec)))
678 (thumb (cdr (assq ?t spec))))
679 (rename-file nq8 thumb t)))
680 (message "command %S %s" (process-command process)
681 (string-replace "\n" "" status)))))
682 process))
683
684(defun image-dired-pngcrush-thumb (spec)
685 "Optimize thumbnail described by format SPEC with pngcrush(1)."
686 ;; If pngnq wasn't run, then the THUMB-nq8.png file does not exist.
687 ;; pngcrush needs an infile and outfile, so we just copy THUMB to
688 ;; THUMB-nq8.png and use the latter as a temp file.
689 (when (not image-dired-cmd-pngnq-program)
690 (let ((temp (cdr (assq ?q spec)))
691 (thumb (cdr (assq ?t spec))))
692 (copy-file thumb temp)))
693 (let ((process
694 (apply #'start-process "image-dired-pngcrush" nil
695 image-dired-cmd-pngcrush-program
696 (mapcar (lambda (arg) (format-spec arg spec))
697 image-dired-cmd-pngcrush-options))))
698 (setf (process-sentinel process)
699 (lambda (process status)
700 (unless (and (eq (process-status process) 'exit)
701 (zerop (process-exit-status process)))
702 (message "command %S %s" (process-command process)
703 (string-replace "\n" "" status)))
704 (when (memq (process-status process) '(exit signal))
705 (let ((temp (cdr (assq ?q spec))))
706 (delete-file temp)))))
707 process))
708
709(defun image-dired-optipng-thumb (spec)
710 "Optimize thumbnail described by format SPEC with optipng(1)."
711 (let ((process
712 (apply #'start-process "image-dired-optipng" nil
713 image-dired-cmd-optipng-program
714 (mapcar (lambda (arg) (format-spec arg spec))
715 image-dired-cmd-optipng-options))))
716 (setf (process-sentinel process)
717 (lambda (process status)
718 (unless (and (eq (process-status process) 'exit)
719 (zerop (process-exit-status process)))
720 (message "command %S %s" (process-command process)
721 (string-replace "\n" "" status)))))
722 process))
723
724(defun image-dired-create-thumb-1 (original-file thumbnail-file)
725 "For ORIGINAL-FILE, create thumbnail image named THUMBNAIL-FILE."
726 (image-dired--check-executable-exists
727 'image-dired-cmd-create-thumbnail-program)
728 (let* ((width (int-to-string (image-dired-thumb-size 'width)))
729 (height (int-to-string (image-dired-thumb-size 'height)))
730 (modif-time (format-time-string
731 "%s" (file-attribute-modification-time
732 (file-attributes original-file))))
733 (thumbnail-nq8-file (replace-regexp-in-string ".png\\'" "-nq8.png"
734 thumbnail-file))
735 (spec
736 (list
737 (cons ?w width)
738 (cons ?h height)
739 (cons ?m modif-time)
740 (cons ?f original-file)
741 (cons ?q thumbnail-nq8-file)
742 (cons ?t thumbnail-file)))
743 (thumbnail-dir (file-name-directory thumbnail-file))
744 process)
745 (when (not (file-exists-p thumbnail-dir))
746 (with-file-modes #o700
747 (make-directory thumbnail-dir t))
748 (message "Thumbnail directory created: %s" thumbnail-dir))
749
750 ;; Thumbnail file creation processes begin here and are marshaled
751 ;; in a queue by `image-dired-create-thumb'.
752 (setq process
753 (apply #'start-process "image-dired-create-thumbnail" nil
754 image-dired-cmd-create-thumbnail-program
755 (mapcar
756 (lambda (arg) (format-spec arg spec))
757 (if (memq image-dired-thumbnail-storage
758 image-dired--thumbnail-standard-sizes)
759 image-dired-cmd-create-standard-thumbnail-options
760 image-dired-cmd-create-thumbnail-options))))
761
762 (setf (process-sentinel process)
763 (lambda (process status)
764 ;; Trigger next in queue once a thumbnail has been created
765 (cl-decf image-dired-queue-active-jobs)
766 (image-dired-thumb-queue-run)
767 (when (= image-dired-queue-active-jobs 0)
768 (image-dired-debug-message
769 (format-time-string
770 "Generated thumbnails in %s.%3N seconds"
771 (time-subtract nil
772 image-dired--generate-thumbs-start))))
773 (if (not (and (eq (process-status process) 'exit)
774 (zerop (process-exit-status process))))
775 (message "Thumb could not be created for %s: %s"
776 (abbreviate-file-name original-file)
777 (string-replace "\n" "" status))
778 (set-file-modes thumbnail-file #o600)
779 (clear-image-cache thumbnail-file)
780 ;; PNG thumbnail has been created since we are
781 ;; following the XDG thumbnail spec, so try to optimize
782 (when (memq image-dired-thumbnail-storage
783 image-dired--thumbnail-standard-sizes)
784 (cond
785 ((and image-dired-cmd-pngnq-program
786 (executable-find image-dired-cmd-pngnq-program))
787 (image-dired-pngnq-thumb spec))
788 ((and image-dired-cmd-pngcrush-program
789 (executable-find image-dired-cmd-pngcrush-program))
790 (image-dired-pngcrush-thumb spec))
791 ((and image-dired-cmd-optipng-program
792 (executable-find image-dired-cmd-optipng-program))
793 (image-dired-optipng-thumb spec)))))))
794 process))
795
796(defun image-dired-thumb-queue-run ()
797 "Run a queued job if one exists and not too many jobs are running.
798Queued items live in `image-dired-queue'."
799 (while (and image-dired-queue
800 (< image-dired-queue-active-jobs
801 image-dired-queue-active-limit))
802 (cl-incf image-dired-queue-active-jobs)
803 (apply #'image-dired-create-thumb-1 (pop image-dired-queue))))
804
805(defun image-dired-create-thumb (original-file thumbnail-file)
806 "Add a job for generating ORIGINAL-FILE thumbnail to `image-dired-queue'.
807The new file will be named THUMBNAIL-FILE."
808 (setq image-dired-queue
809 (nconc image-dired-queue
810 (list (list original-file thumbnail-file))))
811 (run-at-time 0 nil #'image-dired-thumb-queue-run))
812
813(defmacro image-dired--with-marked (&rest body)
814 "Eval BODY with point on each marked thumbnail.
815If no marked file could be found, execute BODY on the current
816thumbnail."
817 `(with-current-buffer image-dired-thumbnail-buffer
818 (let (found)
819 (save-mark-and-excursion
820 (goto-char (point-min))
821 (while (not (eobp))
822 (when (image-dired-thumb-file-marked-p)
823 (setq found t)
824 ,@body)
825 (forward-char)))
826 (unless found
827 ,@body))))
828
829;;;###autoload
830(defun image-dired-dired-toggle-marked-thumbs (&optional arg)
831 "Toggle thumbnails in front of file names in the Dired buffer.
832If no marked file could be found, insert or hide thumbnails on the
833current line. ARG, if non-nil, specifies the files to use instead
834of the marked files. If ARG is an integer, use the next ARG (or
835previous -ARG, if ARG<0) files."
836 (interactive "P")
837 (dired-map-over-marks
838 (let ((image-pos (dired-move-to-filename))
839 (image-file (dired-get-filename nil t))
840 thumb-file
841 overlay)
842 (when (and image-file
843 (string-match-p (image-file-name-regexp) image-file))
844 (setq thumb-file (image-dired-get-thumbnail-image image-file))
845 ;; If image is not already added, then add it.
846 (let ((thumb-ov (cl-loop for ov in (overlays-in (point) (1+ (point)))
847 if (overlay-get ov 'thumb-file) return ov)))
848 (if thumb-ov
849 (delete-overlay thumb-ov)
850 (put-image thumb-file image-pos)
851 (setq overlay
852 (cl-loop for ov in (overlays-in (point) (1+ (point)))
853 if (overlay-get ov 'put-image) return ov))
854 (overlay-put overlay 'image-file image-file)
855 (overlay-put overlay 'thumb-file thumb-file)))))
856 arg ; Show or hide image on ARG next files.
857 'show-progress) ; Update dired display after each image is updated.
858 (add-hook 'dired-after-readin-hook
859 'image-dired-dired-after-readin-hook nil t))
860
861(defun image-dired-dired-after-readin-hook ()
862 "Relocate existing thumbnail overlays in Dired buffer after reverting.
863Move them to their corresponding files if they still exist.
864Otherwise, delete overlays."
865 (mapc (lambda (overlay)
866 (when (overlay-get overlay 'put-image)
867 (let* ((image-file (overlay-get overlay 'image-file))
868 (image-pos (dired-goto-file image-file)))
869 (if image-pos
870 (move-overlay overlay image-pos image-pos)
871 (delete-overlay overlay)))))
872 (overlays-in (point-min) (point-max))))
873
874(defun image-dired-next-line-and-display ()
875 "Move to next Dired line and display thumbnail image."
876 (interactive)
877 (dired-next-line 1)
878 (image-dired-display-thumbs
879 t (or image-dired-append-when-browsing nil) t)
880 (if image-dired-dired-disp-props
881 (image-dired-dired-display-properties)))
882
883(defun image-dired-previous-line-and-display ()
884 "Move to previous Dired line and display thumbnail image."
885 (interactive)
886 (dired-previous-line 1)
887 (image-dired-display-thumbs
888 t (or image-dired-append-when-browsing nil) t)
889 (if image-dired-dired-disp-props
890 (image-dired-dired-display-properties)))
891
892(defun image-dired-toggle-append-browsing ()
893 "Toggle `image-dired-append-when-browsing'."
894 (interactive)
895 (setq image-dired-append-when-browsing
896 (not image-dired-append-when-browsing))
897 (message "Append browsing %s"
898 (if image-dired-append-when-browsing
899 "on"
900 "off")))
901
902(defun image-dired-mark-and-display-next ()
903 "Mark current file in Dired and display next thumbnail image."
904 (interactive)
905 (dired-mark 1)
906 (image-dired-display-thumbs
907 t (or image-dired-append-when-browsing nil) t)
908 (if image-dired-dired-disp-props
909 (image-dired-dired-display-properties)))
910
911(defun image-dired-toggle-dired-display-properties ()
912 "Toggle `image-dired-dired-disp-props'."
913 (interactive)
914 (setq image-dired-dired-disp-props
915 (not image-dired-dired-disp-props))
916 (message "Dired display properties %s"
917 (if image-dired-dired-disp-props
918 "on"
919 "off")))
920
921(defvar image-dired-thumbnail-buffer "*image-dired*"
922 "Image-Dired's thumbnail buffer.")
923
924(defun image-dired-create-thumbnail-buffer ()
925 "Create thumb buffer and set `image-dired-thumbnail-mode'."
926 (let ((buf (get-buffer-create image-dired-thumbnail-buffer)))
927 (with-current-buffer buf
928 (setq buffer-read-only t)
929 (if (not (eq major-mode 'image-dired-thumbnail-mode))
930 (image-dired-thumbnail-mode)))
931 buf))
932
933(defvar image-dired-display-image-buffer "*image-dired-display-image*"
934 "Where larger versions of the images are display.")
935
936(defvar image-dired-saved-window-configuration nil
937 "Saved window configuration.")
938
939;;;###autoload
940(defun image-dired-dired-with-window-configuration (dir &optional arg)
941 "Open directory DIR and create a default window configuration.
942
943Convenience command that:
944
945 - Opens Dired in folder DIR
946 - Splits windows in most useful (?) way
947 - Sets `truncate-lines' to t
948
949After the command has finished, you would typically mark some
950image files in Dired and type
951\\[image-dired-display-thumbs] (`image-dired-display-thumbs').
952
953If called with prefix argument ARG, skip splitting of windows.
954
955The current window configuration is saved and can be restored by
956calling `image-dired-restore-window-configuration'."
957 (interactive "DDirectory: \nP")
958 (let ((buf (image-dired-create-thumbnail-buffer))
959 (buf2 (get-buffer-create image-dired-display-image-buffer)))
960 (setq image-dired-saved-window-configuration
961 (current-window-configuration))
962 (dired dir)
963 (delete-other-windows)
964 (when (not arg)
965 (split-window-right)
966 (setq truncate-lines t)
967 (save-excursion
968 (other-window 1)
969 (pop-to-buffer-same-window buf)
970 (select-window (split-window-below))
971 (pop-to-buffer-same-window buf2)
972 (other-window -2)))))
973
974(defun image-dired-restore-window-configuration ()
975 "Restore window configuration.
976Restore any changes to the window configuration made by calling
977`image-dired-dired-with-window-configuration'."
978 (interactive nil image-dired-thumbnail-mode)
979 (if image-dired-saved-window-configuration
980 (set-window-configuration image-dired-saved-window-configuration)
981 (message "No saved window configuration")))
982
983(defun image-dired--line-up-with-method ()
984 "Line up thumbnails according to `image-dired-line-up-method'."
985 (cond ((eq 'dynamic image-dired-line-up-method)
986 (image-dired-line-up-dynamic))
987 ((eq 'fixed image-dired-line-up-method)
988 (image-dired-line-up))
989 ((eq 'interactive image-dired-line-up-method)
990 (image-dired-line-up-interactive))
991 ((eq 'none image-dired-line-up-method)
992 nil)
993 (t
994 (image-dired-line-up-dynamic))))
995
996;;;###autoload
997(defun image-dired-display-thumbs (&optional arg append do-not-pop)
998 "Display thumbnails of all marked files, in `image-dired-thumbnail-buffer'.
999If a thumbnail image does not exist for a file, it is created on the
1000fly. With prefix argument ARG, display only thumbnail for file at
1001point (this is useful if you have marked some files but want to show
1002another one).
1003
1004Recommended usage is to split the current frame horizontally so that
1005you have the Dired buffer in the left window and the
1006`image-dired-thumbnail-buffer' buffer in the right window.
1007
1008With optional argument APPEND, append thumbnail to thumbnail buffer
1009instead of erasing it first.
1010
1011Optional argument DO-NOT-POP controls if `pop-to-buffer' should be
1012used or not. If non-nil, use `display-buffer' instead of
1013`pop-to-buffer'. This is used from functions like
1014`image-dired-next-line-and-display' and
1015`image-dired-previous-line-and-display' where we do not want the
1016thumbnail buffer to be selected."
1017 (interactive "P")
1018 (setq image-dired--generate-thumbs-start (current-time))
1019 (let ((buf (image-dired-create-thumbnail-buffer))
1020 thumb-name files dired-buf)
1021 (if arg
1022 (setq files (list (dired-get-filename)))
1023 (setq files (dired-get-marked-files)))
1024 (setq dired-buf (current-buffer))
1025 (with-current-buffer buf
1026 (let ((inhibit-read-only t))
1027 (if (not append)
1028 (erase-buffer)
1029 (goto-char (point-max)))
1030 (dolist (curr-file files)
1031 (setq thumb-name (image-dired-thumb-name curr-file))
1032 (when (not (file-exists-p thumb-name))
1033 (image-dired-create-thumb curr-file thumb-name))
1034 (image-dired-insert-thumbnail thumb-name curr-file dired-buf)))
1035 (if do-not-pop
1036 (display-buffer buf)
1037 (pop-to-buffer buf))
1038 (image-dired--line-up-with-method))))
1039
1040;;;###autoload
1041(defun image-dired-show-all-from-dir (dir)
1042 "Make a thumbnail buffer for all images in DIR and display it.
1043Any file matching `image-file-name-regexp' is considered an image
1044file.
1045
1046If the number of image files in DIR exceeds
1047`image-dired-show-all-from-dir-max-files', ask for confirmation
1048before creating the thumbnail buffer. If that variable is nil,
1049never ask for confirmation."
1050 (interactive "DImage-Dired: ")
1051 (dired dir)
1052 (dired-mark-files-regexp (image-file-name-regexp))
1053 (let ((files (dired-get-marked-files nil nil nil t)))
1054 (cond ((and (null (cdr files)))
1055 (message "No image files in directory"))
1056 ((or (not image-dired-show-all-from-dir-max-files)
1057 (<= (length (cdr files)) image-dired-show-all-from-dir-max-files)
1058 (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files)
1059 (y-or-n-p
1060 (format
1061 "Directory contains more than %d image files. Proceed?"
1062 image-dired-show-all-from-dir-max-files))))
1063 (image-dired-display-thumbs)
1064 (pop-to-buffer image-dired-thumbnail-buffer)
1065 (setq default-directory dir)
1066 (image-dired-unmark-all-marks))
1067 (t (message "Image-Dired canceled")))))
1068
1069;;;###autoload
1070(defalias 'image-dired 'image-dired-show-all-from-dir)
1071
1072
1073;;; Tags
1074
1075(defun image-dired-sane-db-file ()
1076 "Check if `image-dired-db-file' exists.
1077If not, try to create it (including any parent directories).
1078Signal error if there are problems creating it."
1079 (or (file-exists-p image-dired-db-file)
1080 (let (dir buf)
1081 (unless (file-directory-p (setq dir (file-name-directory
1082 image-dired-db-file)))
1083 (with-file-modes #o700
1084 (make-directory dir t)))
1085 (with-current-buffer (setq buf (create-file-buffer
1086 image-dired-db-file))
1087 (with-file-modes #o600
1088 (write-file image-dired-db-file)))
1089 (kill-buffer buf)
1090 (file-exists-p image-dired-db-file))
1091 (error "Could not create %s" image-dired-db-file)))
1092
1093(defvar image-dired-tag-history nil "Variable holding the tag history.")
1094
1095(defun image-dired-write-tags (file-tags)
1096 "Write file tags to database.
1097Write each file and tag in FILE-TAGS to the database.
1098FILE-TAGS is an alist in the following form:
1099 ((FILE . TAG) ... )"
1100 (image-dired-sane-db-file)
1101 (let (end file tag)
1102 (image-dired--with-db-file
1103 (setq buffer-file-name image-dired-db-file)
1104 (dolist (elt file-tags)
1105 (setq file (car elt)
1106 tag (cdr elt))
1107 (goto-char (point-min))
1108 (if (search-forward-regexp (format "^%s.*$" file) nil t)
1109 (progn
1110 (setq end (point))
1111 (beginning-of-line)
1112 (when (not (search-forward (format ";%s" tag) end t))
1113 (end-of-line)
1114 (insert (format ";%s" tag))))
1115 (goto-char (point-max))
1116 (insert (format "%s;%s\n" file tag))))
1117 (save-buffer))))
1118
1119(defun image-dired-remove-tag (files tag)
1120 "For all FILES, remove TAG from the image database."
1121 (image-dired-sane-db-file)
1122 (image-dired--with-db-file
1123 (setq buffer-file-name image-dired-db-file)
1124 (let (end)
1125 (unless (listp files)
1126 (if (stringp files)
1127 (setq files (list files))
1128 (error "Files must be a string or a list of strings!")))
1129 (dolist (file files)
1130 (goto-char (point-min))
1131 (when (search-forward-regexp (format "^%s;" file) nil t)
1132 (end-of-line)
1133 (setq end (point))
1134 (beginning-of-line)
1135 (when (search-forward-regexp
1136 (format "\\(;%s\\)\\($\\|;\\)" tag) end t)
1137 (delete-region (match-beginning 1) (match-end 1))
1138 ;; Check if file should still be in the database. If
1139 ;; it has no tags or comments, it will be removed.
1140 (end-of-line)
1141 (setq end (point))
1142 (beginning-of-line)
1143 (when (not (search-forward ";" end t))
1144 (kill-line 1))))))
1145 (save-buffer)))
1146
1147(defun image-dired-list-tags (file)
1148 "Read all tags for image FILE from the image database."
1149 (image-dired-sane-db-file)
1150 (image-dired--with-db-file
1151 (let (end (tags ""))
1152 (when (search-forward-regexp (format "^%s" file) nil t)
1153 (end-of-line)
1154 (setq end (point))
1155 (beginning-of-line)
1156 (if (search-forward ";" end t)
1157 (if (search-forward "comment:" end t)
1158 (if (search-forward ";" end t)
1159 (setq tags (buffer-substring (point) end)))
1160 (setq tags (buffer-substring (point) end)))))
1161 (split-string tags ";"))))
1162
1163;;;###autoload
1164(defun image-dired-tag-files (arg)
1165 "Tag marked file(s) in Dired. With prefix ARG, tag file at point."
1166 (interactive "P")
1167 (let ((tag (completing-read
1168 "Tags to add (separate tags with a semicolon): "
1169 image-dired-tag-history nil nil nil 'image-dired-tag-history))
1170 files)
1171 (if arg
1172 (setq files (list (dired-get-filename)))
1173 (setq files (dired-get-marked-files)))
1174 (image-dired-write-tags
1175 (mapcar
1176 (lambda (x)
1177 (cons x tag))
1178 files))))
1179
1180(defun image-dired-tag-thumbnail ()
1181 "Tag current or marked thumbnails."
1182 (interactive)
1183 (let ((tag (completing-read
1184 "Tags to add (separate tags with a semicolon): "
1185 image-dired-tag-history nil nil nil 'image-dired-tag-history)))
1186 (image-dired--with-marked
1187 (image-dired-write-tags
1188 (list (cons (image-dired-original-file-name) tag)))
1189 (image-dired-update-property
1190 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1191
1192;;;###autoload
1193(defun image-dired-delete-tag (arg)
1194 "Remove tag for selected file(s).
1195With prefix argument ARG, remove tag from file at point."
1196 (interactive "P")
1197 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1198 nil nil nil 'image-dired-tag-history))
1199 files)
1200 (if arg
1201 (setq files (list (dired-get-filename)))
1202 (setq files (dired-get-marked-files)))
1203 (image-dired-remove-tag files tag)))
1204
1205(defun image-dired-tag-thumbnail-remove ()
1206 "Remove tag from current or marked thumbnails."
1207 (interactive)
1208 (let ((tag (completing-read "Tag to remove: " image-dired-tag-history
1209 nil nil nil 'image-dired-tag-history)))
1210 (image-dired--with-marked
1211 (image-dired-remove-tag (image-dired-original-file-name) tag)
1212 (image-dired-update-property
1213 'tags (image-dired-list-tags (image-dired-original-file-name))))))
1214
1215
1216;;; Thumbnail mode (cont.)
1217
1218(defun image-dired-original-file-name ()
1219 "Get original file name for thumbnail or display image at point."
1220 (get-text-property (point) 'original-file-name))
1221
1222(defun image-dired-file-name-at-point ()
1223 "Get abbreviated file name for thumbnail or display image at point."
1224 (let ((f (image-dired-original-file-name)))
1225 (when f
1226 (abbreviate-file-name f))))
1227
1228(defun image-dired-associated-dired-buffer ()
1229 "Get associated Dired buffer at point."
1230 (get-text-property (point) 'associated-dired-buffer))
1231
1232(defun image-dired-get-buffer-window (buf)
1233 "Return window where buffer BUF is."
1234 (get-window-with-predicate
1235 (lambda (window)
1236 (equal (window-buffer window) buf))
1237 nil t))
1238
1239(defun image-dired-track-original-file ()
1240 "Track the original file in the associated Dired buffer.
1241See documentation for `image-dired-toggle-movement-tracking'.
1242Interactive use only useful if `image-dired-track-movement' is nil."
1243 (interactive)
1244 (let* ((dired-buf (image-dired-associated-dired-buffer))
1245 (file-name (image-dired-original-file-name))
1246 (window (image-dired-get-buffer-window dired-buf)))
1247 (and (buffer-live-p dired-buf) file-name
1248 (with-current-buffer dired-buf
1249 (if (not (dired-goto-file file-name))
1250 (message "Could not track file")
1251 (if window (set-window-point window (point))))))))
1252
1253(defun image-dired-toggle-movement-tracking ()
1254 "Turn on and off `image-dired-track-movement'.
1255Tracking of the movements between thumbnail and Dired buffer so that
1256they are \"mirrored\" in the dired buffer. When this is on, moving
1257around in the thumbnail or dired buffer will find the matching
1258position in the other buffer."
1259 (interactive)
1260 (setq image-dired-track-movement (not image-dired-track-movement))
1261 (message "Movement tracking %s" (if image-dired-track-movement "on" "off")))
1262
1263(defun image-dired-track-thumbnail ()
1264 "Track current Dired file's thumb in `image-dired-thumbnail-buffer'.
1265This is almost the same as what `image-dired-track-original-file' does,
1266but the other way around."
1267 (let ((file (dired-get-filename))
1268 prop-val found window)
1269 (when (get-buffer image-dired-thumbnail-buffer)
1270 (with-current-buffer image-dired-thumbnail-buffer
1271 (goto-char (point-min))
1272 (while (and (not (eobp))
1273 (not found))
1274 (if (and (setq prop-val
1275 (get-text-property (point) 'original-file-name))
1276 (string= prop-val file))
1277 (setq found t))
1278 (if (not found)
1279 (forward-char 1)))
1280 (when found
1281 (if (setq window (image-dired-thumbnail-window))
1282 (set-window-point window (point)))
1283 (image-dired-update-header-line))))))
1284
1285(defun image-dired-dired-next-line (&optional arg)
1286 "Call `dired-next-line', then track thumbnail.
1287This can safely replace `dired-next-line'.
1288With prefix argument, move ARG lines."
1289 (interactive "P")
1290 (dired-next-line (or arg 1))
1291 (if image-dired-track-movement
1292 (image-dired-track-thumbnail)))
1293
1294(defun image-dired-dired-previous-line (&optional arg)
1295 "Call `dired-previous-line', then track thumbnail.
1296This can safely replace `dired-previous-line'.
1297With prefix argument, move ARG lines."
1298 (interactive "P")
1299 (dired-previous-line (or arg 1))
1300 (if image-dired-track-movement
1301 (image-dired-track-thumbnail)))
1302
1303(defun image-dired--display-thumb-properties-fun ()
1304 (let ((old-buf (current-buffer))
1305 (old-point (point)))
1306 (lambda ()
1307 (when (and (equal (current-buffer) old-buf)
1308 (= (point) old-point))
1309 (ignore-errors
1310 (image-dired-update-header-line))))))
1311
1312(defun image-dired-forward-image (&optional arg wrap-around)
1313 "Move to next image and display properties.
1314Optional prefix ARG says how many images to move; the default is
1315one image. Negative means move backwards.
1316On reaching end or beginning of buffer, stop and show a message.
1317
1318If optional argument WRAP-AROUND is non-nil, wrap around: if
1319point is on the last image, move to the last one and vice versa."
1320 (interactive "p")
1321 (setq arg (or arg 1))
1322 (let (pos)
1323 (dotimes (_ (abs arg))
1324 (if (and (not (if (> arg 0) (eobp) (bobp)))
1325 (save-excursion
1326 (forward-char (if (> arg 0) 1 -1))
1327 (while (and (not (if (> arg 0) (eobp) (bobp)))
1328 (not (image-dired-image-at-point-p)))
1329 (forward-char (if (> arg 0) 1 -1)))
1330 (setq pos (point))
1331 (image-dired-image-at-point-p)))
1332 (progn (goto-char pos)
1333 (image-dired-update-header-line))
1334 (if wrap-around
1335 (progn (goto-char (if (> arg 0)
1336 (point-min)
1337 ;; There are two spaces after the last image.
1338 (- (point-max) 2)))
1339 (image-dired-update-header-line))
1340 (message "At %s image" (if (> arg 0) "last" "first"))
1341 (run-at-time 1 nil (image-dired--display-thumb-properties-fun))))))
1342 (when image-dired-track-movement
1343 (image-dired-track-original-file)))
1344
1345(defun image-dired-backward-image (&optional arg)
1346 "Move to previous image and display properties.
1347Optional prefix ARG says how many images to move; the default is
1348one image. Negative means move forward.
1349On reaching end or beginning of buffer, stop and show a message."
1350 (interactive "p")
1351 (image-dired-forward-image (- (or arg 1))))
1352
1353(defun image-dired-next-line ()
1354 "Move to next line and display properties."
1355 (interactive nil image-dired-thumbnail-mode)
1356 (let ((goal-column (current-column)))
1357 (forward-line 1)
1358 (move-to-column goal-column))
1359 ;; If we end up in an empty spot, back up to the next thumbnail.
1360 (if (not (image-dired-image-at-point-p))
1361 (image-dired-backward-image))
1362 (if image-dired-track-movement
1363 (image-dired-track-original-file))
1364 (image-dired-update-header-line))
1365
1366
1367(defun image-dired-previous-line ()
1368 "Move to previous line and display properties."
1369 (interactive nil image-dired-thumbnail-mode)
1370 (let ((goal-column (current-column)))
1371 (forward-line -1)
1372 (move-to-column goal-column))
1373 ;; If we end up in an empty spot, back up to the next
1374 ;; thumbnail. This should only happen if the user deleted a
1375 ;; thumbnail and did not refresh, so it is not very common. But we
1376 ;; can handle it in a good manner, so why not?
1377 (if (not (image-dired-image-at-point-p))
1378 (image-dired-backward-image))
1379 (if image-dired-track-movement
1380 (image-dired-track-original-file))
1381 (image-dired-update-header-line))
1382
1383(defun image-dired-beginning-of-buffer ()
1384 "Move to the first image in the buffer and display properties."
1385 (interactive nil image-dired-thumbnail-mode)
1386 (goto-char (point-min))
1387 (while (and (not (image-at-point-p))
1388 (not (eobp)))
1389 (forward-char 1))
1390 (when image-dired-track-movement
1391 (image-dired-track-original-file))
1392 (image-dired-update-header-line))
1393
1394(defun image-dired-end-of-buffer ()
1395 "Move to the last image in the buffer and display properties."
1396 (interactive nil image-dired-thumbnail-mode)
1397 (goto-char (point-max))
1398 (while (and (not (image-at-point-p))
1399 (not (bobp)))
1400 (forward-char -1))
1401 (when image-dired-track-movement
1402 (image-dired-track-original-file))
1403 (image-dired-update-header-line))
1404
1405(defun image-dired-format-properties-string (buf file props comment)
1406 "Format display properties.
1407BUF is the associated Dired buffer, FILE is the original image file
1408name, PROPS is a stringified list of tags and COMMENT is the image file's
1409comment."
1410 (format-spec
1411 image-dired-display-properties-format
1412 (list
1413 (cons ?b (or buf ""))
1414 (cons ?f file)
1415 (cons ?t (or props ""))
1416 (cons ?c (or comment "")))))
1417
1418(defun image-dired-update-header-line ()
1419 "Update image information in the header line."
1420 (when (and (not (eobp))
1421 (memq major-mode '(image-dired-thumbnail-mode
1422 image-dired-display-image-mode)))
1423 (let ((file-name (file-name-nondirectory (image-dired-original-file-name)))
1424 (dired-buf (buffer-name (image-dired-associated-dired-buffer)))
1425 (props (mapconcat #'identity (get-text-property (point) 'tags) ", "))
1426 (comment (get-text-property (point) 'comment))
1427 (message-log-max nil))
1428 (if file-name
1429 (setq header-line-format
1430 (image-dired-format-properties-string
1431 dired-buf
1432 file-name
1433 props
1434 comment))))))
1435
1436(defun image-dired-dired-file-marked-p (&optional marker)
1437 "In Dired, return t if file on current line is marked.
1438If optional argument MARKER is non-nil, it is a character to look
1439for. The default is to look for `dired-marker-char'."
1440 (setq marker (or marker dired-marker-char))
1441 (save-excursion
1442 (beginning-of-line)
1443 (and (looking-at dired-re-mark)
1444 (= (aref (match-string 0) 0) marker))))
1445
1446(defun image-dired-dired-file-flagged-p ()
1447 "In Dired, return t if file on current line is flagged for deletion."
1448 (image-dired-dired-file-marked-p dired-del-marker))
1449
1450(defmacro image-dired--with-thumbnail-buffer (&rest body)
1451 (declare (indent defun) (debug t))
1452 `(if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1453 (with-current-buffer buf
1454 (if-let ((win (get-buffer-window buf)))
1455 (with-selected-window win
1456 ,@body)
1457 ,@body))
1458 (user-error "No such buffer: %s" image-dired-thumbnail-buffer)))
1459
1460(defmacro image-dired--on-file-in-dired-buffer (&rest body)
1461 "Run BODY with point on file at point in Dired buffer.
1462Should be called from commands in `image-dired-thumbnail-mode'."
1463 (declare (indent defun) (debug t))
1464 `(let ((file-name (image-dired-original-file-name))
1465 (dired-buf (image-dired-associated-dired-buffer)))
1466 (if (not (and dired-buf file-name))
1467 (message "No image, or image with correct properties, at point")
1468 (with-current-buffer dired-buf
1469 (when (dired-goto-file file-name)
1470 ,@body
1471 (image-dired-thumb-update-marks))))))
1472
1473(defmacro image-dired--do-mark-command (maybe-next &rest body)
1474 "Helper macro for the mark, unmark and flag commands.
1475Run BODY in Dired buffer.
1476If optional argument MAYBE-NEXT is non-nil, show next image
1477according to `image-dired-marking-shows-next'."
1478 (declare (indent defun) (debug t))
1479 `(image-dired--with-thumbnail-buffer
1480 (image-dired--on-file-in-dired-buffer
1481 ,@body)
1482 ,(when maybe-next
1483 '(if image-dired-marking-shows-next
1484 (image-dired-display-next-thumbnail-original)
1485 (image-dired-next-line)))))
1486
1487(defun image-dired-mark-thumb-original-file ()
1488 "Mark original image file in associated Dired buffer."
1489 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1490 (image-dired--do-mark-command t
1491 (dired-mark 1)))
1492
1493(defun image-dired-unmark-thumb-original-file ()
1494 "Unmark original image file in associated Dired buffer."
1495 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1496 (image-dired--do-mark-command t
1497 (dired-unmark 1)))
1498
1499(defun image-dired-flag-thumb-original-file ()
1500 "Flag original image file for deletion in associated Dired buffer."
1501 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1502 (image-dired--do-mark-command t
1503 (dired-flag-file-deletion 1)))
1504
1505(defun image-dired-toggle-mark-thumb-original-file ()
1506 "Toggle mark on original image file in associated Dired buffer."
1507 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1508 (image-dired--do-mark-command nil
1509 (if (image-dired-dired-file-marked-p)
1510 (dired-unmark 1)
1511 (dired-mark 1))))
1512
1513(defun image-dired-unmark-all-marks ()
1514 "Remove all marks from all files in associated Dired buffer.
1515Also update the marks in the thumbnail buffer."
1516 (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode)
1517 (image-dired--do-mark-command nil
1518 (dired-unmark-all-marks))
1519 (image-dired--with-thumbnail-buffer
1520 (image-dired-thumb-update-marks)))
1521
1522(defun image-dired-jump-original-dired-buffer ()
1523 "Jump to the Dired buffer associated with the current image file.
1524You probably want to use this together with
1525`image-dired-track-original-file'."
1526 (interactive nil image-dired-thumbnail-mode)
1527 (let ((buf (image-dired-associated-dired-buffer))
1528 window frame)
1529 (setq window (image-dired-get-buffer-window buf))
1530 (if window
1531 (progn
1532 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1533 (select-frame-set-input-focus frame))
1534 (select-window window))
1535 (message "Associated dired buffer not visible"))))
1536
1537;;;###autoload
1538(defun image-dired-jump-thumbnail-buffer ()
1539 "Jump to thumbnail buffer."
1540 (interactive)
1541 (let ((window (image-dired-thumbnail-window))
1542 frame)
1543 (if window
1544 (progn
1545 (if (not (equal (selected-frame) (setq frame (window-frame window))))
1546 (select-frame-set-input-focus frame))
1547 (select-window window))
1548 (message "Thumbnail buffer not visible"))))
1549
1550(defvar image-dired-thumbnail-mode-line-up-map
1551 (let ((map (make-sparse-keymap)))
1552 ;; map it to "g" so that the user can press it more quickly
1553 (define-key map "g" #'image-dired-line-up-dynamic)
1554 ;; "f" for "fixed" number of thumbs per row
1555 (define-key map "f" #'image-dired-line-up)
1556 ;; "i" for "interactive"
1557 (define-key map "i" #'image-dired-line-up-interactive)
1558 map)
1559 "Keymap for line-up commands in `image-dired-thumbnail-mode'.")
1560
1561(defvar image-dired-thumbnail-mode-tag-map
1562 (let ((map (make-sparse-keymap)))
1563 ;; map it to "t" so that the user can press it more quickly
1564 (define-key map "t" #'image-dired-tag-thumbnail)
1565 ;; "r" for "remove"
1566 (define-key map "r" #'image-dired-tag-thumbnail-remove)
1567 map)
1568 "Keymap for tag commands in `image-dired-thumbnail-mode'.")
1569
1570(defvar image-dired-thumbnail-mode-map
1571 (let ((map (make-sparse-keymap)))
1572 (define-key map [right] #'image-dired-forward-image)
1573 (define-key map [left] #'image-dired-backward-image)
1574 (define-key map [up] #'image-dired-previous-line)
1575 (define-key map [down] #'image-dired-next-line)
1576 (define-key map "\C-f" #'image-dired-forward-image)
1577 (define-key map "\C-b" #'image-dired-backward-image)
1578 (define-key map "\C-p" #'image-dired-previous-line)
1579 (define-key map "\C-n" #'image-dired-next-line)
1580
1581 (define-key map "<" #'image-dired-beginning-of-buffer)
1582 (define-key map ">" #'image-dired-end-of-buffer)
1583 (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer)
1584 (define-key map (kbd "M->") #'image-dired-end-of-buffer)
1585
1586 (define-key map "d" #'image-dired-flag-thumb-original-file)
1587 (define-key map [delete] #'image-dired-flag-thumb-original-file)
1588 (define-key map "m" #'image-dired-mark-thumb-original-file)
1589 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1590 (define-key map "U" #'image-dired-unmark-all-marks)
1591 (define-key map "." #'image-dired-track-original-file)
1592 (define-key map [tab] #'image-dired-jump-original-dired-buffer)
1593
1594 ;; add line-up map
1595 (define-key map "g" image-dired-thumbnail-mode-line-up-map)
1596 ;; add tag map
1597 (define-key map "t" image-dired-thumbnail-mode-tag-map)
1598
1599 (define-key map "\C-m" #'image-dired-display-thumbnail-original-image)
1600 (define-key map [C-return] #'image-dired-thumbnail-display-external)
1601
1602 (define-key map "L" #'image-dired-rotate-original-left)
1603 (define-key map "R" #'image-dired-rotate-original-right)
1604
1605 (define-key map "D" #'image-dired-thumbnail-set-image-description)
1606 (define-key map "S" #'image-dired-slideshow-start)
1607 (define-key map "\C-d" #'image-dired-delete-char)
1608 (define-key map " " #'image-dired-display-next-thumbnail-original)
1609 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1610 (define-key map "c" #'image-dired-comment-thumbnail)
1611
1612 ;; Mouse
1613 (define-key map [mouse-2] #'image-dired-mouse-display-image)
1614 (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail)
1615 (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail)
1616 (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail)
1617 (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail)
1618 (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail)
1619 ;; Seems I must first set C-down-mouse-1 to undefined, or else it
1620 ;; will trigger the buffer menu. If I try to instead bind
1621 ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message
1622 ;; about C-mouse-1 not being defined afterwards. Annoying, but I
1623 ;; probably do not completely understand mouse events.
1624 (define-key map [C-down-mouse-1] #'undefined)
1625 (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark)
1626 map)
1627 "Keymap for `image-dired-thumbnail-mode'.")
1628
1629(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map
1630 "Menu for `image-dired-thumbnail-mode'."
1631 '("Image-Dired"
1632 ["Display image" image-dired-display-thumbnail-original-image]
1633 ["Display in external viewer" image-dired-thumbnail-display-external]
1634 ["Jump to Dired buffer" image-dired-jump-original-dired-buffer]
1635 "---"
1636 ["Mark image" image-dired-mark-thumb-original-file]
1637 ["Unmark image" image-dired-unmark-thumb-original-file]
1638 ["Unmark all images" image-dired-unmark-all-marks]
1639 ["Flag for deletion" image-dired-flag-thumb-original-file]
1640 ["Delete marked images" image-dired-delete-marked]
1641 "---"
1642 ["Rotate original right" image-dired-rotate-original-right]
1643 ["Rotate original left" image-dired-rotate-original-left]
1644 "---"
1645 ["Comment thumbnail" image-dired-comment-thumbnail]
1646 ["Tag current or marked thumbnails" image-dired-tag-thumbnail]
1647 ["Remove tag from current or marked thumbnails"
1648 image-dired-tag-thumbnail-remove]
1649 ["Start slideshow" image-dired-slideshow-start]
1650 "---"
1651 ("View Options"
1652 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1653 :style toggle
1654 :selected image-dired-track-movement]
1655 "---"
1656 ["Line up thumbnails" image-dired-line-up]
1657 ["Dynamic line up" image-dired-line-up-dynamic]
1658 ["Refresh thumb" image-dired-refresh-thumb])
1659 ["Quit" quit-window]))
1660
1661(defvar image-dired-display-image-mode-map
1662 (let ((map (make-sparse-keymap)))
1663 (define-key map "S" #'image-dired-slideshow-start)
1664 (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original)
1665 (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original)
1666 (define-key map "n" #'image-dired-display-next-thumbnail-original)
1667 (define-key map "p" #'image-dired-display-previous-thumbnail-original)
1668 (define-key map "m" #'image-dired-mark-thumb-original-file)
1669 (define-key map "d" #'image-dired-flag-thumb-original-file)
1670 (define-key map "u" #'image-dired-unmark-thumb-original-file)
1671 (define-key map "U" #'image-dired-unmark-all-marks)
1672 ;; Disable keybindings from `image-mode-map' that doesn't make sense here.
1673 (define-key map "o" nil) ; image-save
1674 map)
1675 "Keymap for `image-dired-display-image-mode'.")
1676
1677(define-derived-mode image-dired-thumbnail-mode
1678 special-mode "image-dired-thumbnail"
1679 "Browse and manipulate thumbnail images using Dired.
1680Use `image-dired-minor-mode' to get a nice setup."
1681 :interactive nil
1682 (buffer-disable-undo)
1683 (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)
1684 (setq-local window-resize-pixelwise t)
1685 (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record)
1686 ;; Use approximately as much vertical spacing as horizontal.
1687 (setq-local line-spacing (frame-char-width)))
1688
1689
1690;;; Display image mode
1691
1692(define-derived-mode image-dired-display-image-mode
1693 image-mode "image-dired-image-display"
1694 "Mode for displaying and manipulating original image.
1695Resized or in full-size."
1696 :interactive nil
1697 (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t))
1698
1699(defvar image-dired-minor-mode-map
1700 (let ((map (make-sparse-keymap)))
1701 ;; (set-keymap-parent map dired-mode-map)
1702 ;; Hijack previous and next line movement. Let C-p and C-b be
1703 ;; though...
1704 (define-key map "p" #'image-dired-dired-previous-line)
1705 (define-key map "n" #'image-dired-dired-next-line)
1706 (define-key map [up] #'image-dired-dired-previous-line)
1707 (define-key map [down] #'image-dired-dired-next-line)
1708
1709 (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display)
1710 (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display)
1711 (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next)
1712
1713 (define-key map "\C-td" #'image-dired-display-thumbs)
1714 (define-key map [tab] #'image-dired-jump-thumbnail-buffer)
1715 (define-key map "\C-ti" #'image-dired-dired-display-image)
1716 (define-key map "\C-tx" #'image-dired-dired-display-external)
1717 (define-key map "\C-ta" #'image-dired-display-thumbs-append)
1718 (define-key map "\C-t." #'image-dired-display-thumb)
1719 (define-key map "\C-tc" #'image-dired-dired-comment-files)
1720 (define-key map "\C-tf" #'image-dired-mark-tagged-files)
1721 map)
1722 "Keymap for `image-dired-minor-mode'.")
1723
1724(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map
1725 "Menu for `image-dired-minor-mode'."
1726 '("Image-dired"
1727 ["Display thumb for next file" image-dired-next-line-and-display]
1728 ["Display thumb for previous file" image-dired-previous-line-and-display]
1729 ["Mark and display next" image-dired-mark-and-display-next]
1730 "---"
1731 ["Create thumbnails for marked files" image-dired-create-thumbs]
1732 "---"
1733 ["Display thumbnails append" image-dired-display-thumbs-append]
1734 ["Display this thumbnail" image-dired-display-thumb]
1735 ["Display image" image-dired-dired-display-image]
1736 ["Display in external viewer" image-dired-dired-display-external]
1737 "---"
1738 ["Toggle display properties" image-dired-toggle-dired-display-properties
1739 :style toggle
1740 :selected image-dired-dired-disp-props]
1741 ["Toggle append browsing" image-dired-toggle-append-browsing
1742 :style toggle
1743 :selected image-dired-append-when-browsing]
1744 ["Toggle movement tracking" image-dired-toggle-movement-tracking
1745 :style toggle
1746 :selected image-dired-track-movement]
1747 "---"
1748 ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer]
1749 ["Mark tagged files" image-dired-mark-tagged-files]
1750 ["Comment files" image-dired-dired-comment-files]
1751 ["Copy with EXIF file name" image-dired-copy-with-exif-file-name]))
1752
1753;;;###autoload
1754(define-minor-mode image-dired-minor-mode
1755 "Setup easy-to-use keybindings for the commands to be used in Dired mode.
1756Note that n, p and <down> and <up> will be hijacked and bound to
1757`image-dired-dired-next-line' and `image-dired-dired-previous-line'."
1758 :keymap image-dired-minor-mode-map)
1759
1760(declare-function clear-image-cache "image.c" (&optional filter))
1761
1762(defun image-dired-create-thumbs (&optional arg)
1763 "Create thumbnail images for all marked files in Dired.
1764With prefix argument ARG, create thumbnails even if they already exist
1765\(i.e. use this to refresh your thumbnails)."
1766 (interactive "P")
1767 (let (thumb-name)
1768 (dolist (curr-file (dired-get-marked-files))
1769 (setq thumb-name (image-dired-thumb-name curr-file))
1770 ;; If the user overrides the exist check, we must clear the
1771 ;; image cache so that if the user wants to display the
1772 ;; thumbnail, it is not fetched from cache.
1773 (when arg
1774 (clear-image-cache (expand-file-name thumb-name)))
1775 (when (or (not (file-exists-p thumb-name))
1776 arg)
1777 (image-dired-create-thumb curr-file thumb-name)))))
1778
1779
1780;;; Slideshow
1781
1782(defcustom image-dired-slideshow-delay 5.0
1783 "Seconds to wait before showing the next image in a slideshow.
1784This is used by `image-dired-slideshow-start'."
1785 :type 'float
1786 :version "29.1")
1787
1788(define-obsolete-variable-alias 'image-dired-slideshow-timer
1789 'image-dired--slideshow-timer "29.1")
1790(defvar image-dired--slideshow-timer nil
1791 "Slideshow timer.")
1792
1793(defvar image-dired--slideshow-initial nil)
1794
1795(defun image-dired-slideshow-step ()
1796 "Step to next image in a slideshow."
1797 (if-let ((buf (get-buffer image-dired-thumbnail-buffer)))
1798 (with-current-buffer buf
1799 (image-dired-display-next-thumbnail-original))
1800 (image-dired-slideshow-stop)))
1801
1802(defun image-dired-slideshow-start (&optional arg)
1803 "Start a slideshow, waiting `image-dired-slideshow-delay' between images.
1804
1805With prefix argument ARG, wait that many seconds before going to
1806the next image.
1807
1808With a negative prefix argument, prompt user for the delay."
1809 (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode)
1810 (let ((delay (if (not arg)
1811 image-dired-slideshow-delay
1812 (if (> arg 0)
1813 arg
1814 (string-to-number
1815 (let ((delay (number-to-string image-dired-slideshow-delay)))
1816 (read-string
1817 (format-prompt "Delay, in seconds. Decimals are accepted" delay))
1818 delay))))))
1819 (setq image-dired--slideshow-timer
1820 (run-with-timer
1821 0 delay
1822 'image-dired-slideshow-step))
1823 (add-hook 'post-command-hook 'image-dired-slideshow-stop)
1824 (setq image-dired--slideshow-initial t)
1825 (message "Running slideshow; use any command to stop")))
1826
1827(defun image-dired-slideshow-stop ()
1828 "Cancel slideshow."
1829 ;; Make sure we don't immediately stop after
1830 ;; `image-dired-slideshow-start'.
1831 (unless image-dired--slideshow-initial
1832 (remove-hook 'post-command-hook 'image-dired-slideshow-stop)
1833 (cancel-timer image-dired--slideshow-timer))
1834 (setq image-dired--slideshow-initial nil))
1835
1836
1837;;; Thumbnail mode (cont. 3)
1838
1839(defun image-dired-delete-char ()
1840 "Remove current thumbnail from thumbnail buffer and line up."
1841 (interactive nil image-dired-thumbnail-mode)
1842 (let ((inhibit-read-only t))
1843 (delete-char 1)
1844 (when (= (following-char) ?\s)
1845 (delete-char 1))))
1846
1847;;;###autoload
1848(defun image-dired-display-thumbs-append ()
1849 "Append thumbnails to `image-dired-thumbnail-buffer'."
1850 (interactive)
1851 (image-dired-display-thumbs nil t t))
1852
1853;;;###autoload
1854(defun image-dired-display-thumb ()
1855 "Shorthand for `image-dired-display-thumbs' with prefix argument."
1856 (interactive)
1857 (image-dired-display-thumbs t nil t))
1858
1859(defun image-dired-line-up ()
1860 "Line up thumbnails according to `image-dired-thumbs-per-row'.
1861See also `image-dired-line-up-dynamic'."
1862 (interactive)
1863 (let ((inhibit-read-only t))
1864 (goto-char (point-min))
1865 (while (and (not (image-dired-image-at-point-p))
1866 (not (eobp)))
1867 (delete-char 1))
1868 (while (not (eobp))
1869 (forward-char)
1870 (while (and (not (image-dired-image-at-point-p))
1871 (not (eobp)))
1872 (delete-char 1)))
1873 (goto-char (point-min))
1874 (let ((seen 0)
1875 (thumb-prev-pos 0)
1876 (thumb-width-chars
1877 (ceiling (/ (+ (* 2 image-dired-thumb-relief)
1878 (* 2 image-dired-thumb-margin)
1879 (image-dired-thumb-size 'width))
1880 (float (frame-char-width))))))
1881 (while (not (eobp))
1882 (forward-char)
1883 (if (= image-dired-thumbs-per-row 1)
1884 (insert "\n")
1885 (cl-incf thumb-prev-pos thumb-width-chars)
1886 (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos)))
1887 (cl-incf seen)
1888 (when (and (= seen (- image-dired-thumbs-per-row 1))
1889 (not (eobp)))
1890 (forward-char)
1891 (insert "\n")
1892 (setq seen 0)
1893 (setq thumb-prev-pos 0)))))
1894 (goto-char (point-min))))
1895
1896(defun image-dired-line-up-dynamic ()
1897 "Line up thumbnails images dynamically.
1898Calculate how many thumbnails fit."
1899 (interactive)
1900 (let* ((char-width (frame-char-width))
1901 (width (image-dired-window-width-pixels (image-dired-thumbnail-window)))
1902 (image-dired-thumbs-per-row
1903 (/ width
1904 (+ (* 2 image-dired-thumb-relief)
1905 (* 2 image-dired-thumb-margin)
1906 (image-dired-thumb-size 'width)
1907 char-width))))
1908 (image-dired-line-up)))
1909
1910(defun image-dired-line-up-interactive ()
1911 "Line up thumbnails interactively.
1912Ask user how many thumbnails should be displayed per row."
1913 (interactive)
1914 (let ((image-dired-thumbs-per-row
1915 (string-to-number (read-string "How many thumbs per row: "))))
1916 (if (not (> image-dired-thumbs-per-row 0))
1917 (message "Number must be greater than 0")
1918 (image-dired-line-up))))
1919
1920(defun image-dired-thumbnail-display-external ()
1921 "Display original image for thumbnail at point using external viewer."
1922 (interactive)
1923 (let ((file (image-dired-original-file-name)))
1924 (if (not (image-dired-image-at-point-p))
1925 (message "No thumbnail at point")
1926 (if (not file)
1927 (message "No original file name found")
1928 (start-process "image-dired-thumb-external" nil
1929 image-dired-external-viewer file)))))
1930
1931;;;###autoload
1932(defun image-dired-dired-display-external ()
1933 "Display file at point using an external viewer."
1934 (interactive)
1935 (let ((file (dired-get-filename)))
1936 (start-process "image-dired-external" nil
1937 image-dired-external-viewer file)))
1938
1939(defun image-dired-window-width-pixels (window)
1940 "Calculate WINDOW width in pixels."
1941 (* (window-width window) (frame-char-width)))
1942
1943(defun image-dired-display-window ()
1944 "Return window where `image-dired-display-image-buffer' is visible."
1945 (get-window-with-predicate
1946 (lambda (window)
1947 (equal (buffer-name (window-buffer window)) image-dired-display-image-buffer))
1948 nil t))
1949
1950(defun image-dired-thumbnail-window ()
1951 "Return window where `image-dired-thumbnail-buffer' is visible."
1952 (get-window-with-predicate
1953 (lambda (window)
1954 (equal (buffer-name (window-buffer window)) image-dired-thumbnail-buffer))
1955 nil t))
1956
1957(defun image-dired-associated-dired-buffer-window ()
1958 "Return window where associated Dired buffer is visible."
1959 (let (buf)
1960 (if (image-dired-image-at-point-p)
1961 (progn
1962 (setq buf (image-dired-associated-dired-buffer))
1963 (get-window-with-predicate
1964 (lambda (window)
1965 (equal (window-buffer window) buf))))
1966 (error "No thumbnail image at point"))))
1967
1968(defun image-dired-display-image (file &optional _ignored)
1969 "Display image FILE in image buffer.
1970Use this when you want to display the image, in a new window.
1971The window will use `image-dired-display-image-mode' which is
1972based on `image-mode'."
1973 (declare (advertised-calling-convention (file) "29.1"))
1974 (setq file (expand-file-name file))
1975 (when (not (file-exists-p file))
1976 (error "No such file: %s" file))
1977 (let ((buf (get-buffer image-dired-display-image-buffer))
1978 (cur-win (selected-window)))
1979 (when buf
1980 (kill-buffer buf))
1981 (when-let ((buf (find-file-noselect file nil t)))
1982 (pop-to-buffer buf)
1983 (rename-buffer image-dired-display-image-buffer)
1984 (image-dired-display-image-mode)
1985 (select-window cur-win))))
1986
1987(defun image-dired-display-thumbnail-original-image (&optional arg)
1988 "Display current thumbnail's original image in display buffer.
1989See documentation for `image-dired-display-image' for more information.
1990With prefix argument ARG, display image in its original size."
1991 (interactive "P")
1992 (let ((file (image-dired-original-file-name)))
1993 (if (not (string-equal major-mode "image-dired-thumbnail-mode"))
1994 (message "Not in image-dired-thumbnail-mode")
1995 (if (not (image-dired-image-at-point-p))
1996 (message "No thumbnail at point")
1997 (if (not file)
1998 (message "No original file name found")
1999 (image-dired-display-image file arg))))))
2000
2001
2002;;;###autoload
2003(defun image-dired-dired-display-image (&optional arg)
2004 "Display current image file.
2005See documentation for `image-dired-display-image' for more information.
2006With prefix argument ARG, display image in its original size."
2007 (interactive "P")
2008 (image-dired-display-image (dired-get-filename) arg))
2009
2010(defun image-dired-image-at-point-p ()
2011 "Return non-nil if there is an `image-dired' thumbnail at point."
2012 (get-text-property (point) 'image-dired-thumbnail))
2013
2014(defun image-dired-refresh-thumb ()
2015 "Force creation of new image for current thumbnail."
2016 (interactive nil image-dired-thumbnail-mode)
2017 (let* ((file (image-dired-original-file-name))
2018 (thumb (expand-file-name (image-dired-thumb-name file))))
2019 (clear-image-cache (expand-file-name thumb))
2020 (image-dired-create-thumb file thumb)))
2021
2022(defun image-dired-rotate-original (degrees)
2023 "Rotate original image DEGREES degrees."
2024 (image-dired--check-executable-exists
2025 'image-dired-cmd-rotate-original-program)
2026 (if (not (image-dired-image-at-point-p))
2027 (message "No image at point")
2028 (let* ((file (image-dired-original-file-name))
2029 (spec
2030 (list
2031 (cons ?d degrees)
2032 (cons ?o (expand-file-name file))
2033 (cons ?t image-dired-temp-rotate-image-file))))
2034 (unless (eq 'jpeg (image-type file))
2035 (user-error "Only JPEG images can be rotated"))
2036 (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program
2037 nil nil nil
2038 (mapcar (lambda (arg) (format-spec arg spec))
2039 image-dired-cmd-rotate-original-options))))
2040 (error "Could not rotate image")
2041 (image-dired-display-image image-dired-temp-rotate-image-file)
2042 (if (or (and image-dired-rotate-original-ask-before-overwrite
2043 (y-or-n-p
2044 "Rotate to temp file OK. Overwrite original image? "))
2045 (not image-dired-rotate-original-ask-before-overwrite))
2046 (progn
2047 (copy-file image-dired-temp-rotate-image-file file t)
2048 (image-dired-refresh-thumb))
2049 (image-dired-display-image file))))))
2050
2051(defun image-dired-rotate-original-left ()
2052 "Rotate original image left (counter clockwise) 90 degrees.
2053The result of the rotation is displayed in the image display area
2054and a confirmation is needed before the original image files is
2055overwritten. This confirmation can be turned off using
2056`image-dired-rotate-original-ask-before-overwrite'."
2057 (interactive)
2058 (image-dired-rotate-original "270"))
2059
2060(defun image-dired-rotate-original-right ()
2061 "Rotate original image right (clockwise) 90 degrees.
2062The result of the rotation is displayed in the image display area
2063and a confirmation is needed before the original image files is
2064overwritten. This confirmation can be turned off using
2065`image-dired-rotate-original-ask-before-overwrite'."
2066 (interactive)
2067 (image-dired-rotate-original "90"))
2068
2069
2070;;; EXIF support
2071
2072(defun image-dired-get-exif-file-name (file)
2073 "Use the image's EXIF information to return a unique file name.
2074The file name should be unique as long as you do not take more than
2075one picture per second. The original file name is suffixed at the end
2076for traceability. The format of the returned file name is
2077YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from
2078`image-dired-copy-with-exif-file-name'."
2079 (let (data no-exif-data-found)
2080 (if (not (eq 'jpeg (image-type (expand-file-name file))))
2081 (setq no-exif-data-found t
2082 data (format-time-string
2083 "%Y:%m:%d %H:%M:%S"
2084 (file-attribute-modification-time
2085 (file-attributes (expand-file-name file)))))
2086 (setq data (exif-field 'date-time (exif-parse-file
2087 (expand-file-name file)))))
2088 (while (string-match "[ :]" data)
2089 (setq data (replace-match "_" nil nil data)))
2090 (format "%s%s%s" data
2091 (if no-exif-data-found
2092 "_noexif_"
2093 "_")
2094 (file-name-nondirectory file))))
2095
2096(defun image-dired-thumbnail-set-image-description ()
2097 "Set the ImageDescription EXIF tag for the original image.
2098If the image already has a value for this tag, it is used as the
2099default value at the prompt."
2100 (interactive)
2101 (if (not (image-dired-image-at-point-p))
2102 (message "No thumbnail at point")
2103 (let* ((file (image-dired-original-file-name))
2104 (old-value (or (exif-field 'description (exif-parse-file file)) "")))
2105 (if (eq 0
2106 (image-dired-set-exif-data file "ImageDescription"
2107 (read-string "Value of ImageDescription: "
2108 old-value)))
2109 (message "Successfully wrote ImageDescription tag")
2110 (error "Could not write ImageDescription tag")))))
2111
2112(defun image-dired-set-exif-data (file tag-name tag-value)
2113 "In FILE, set EXIF tag TAG-NAME to value TAG-VALUE."
2114 (image-dired--check-executable-exists
2115 'image-dired-cmd-write-exif-data-program)
2116 (let ((spec
2117 (list
2118 (cons ?f (expand-file-name file))
2119 (cons ?t tag-name)
2120 (cons ?v tag-value))))
2121 (apply #'call-process image-dired-cmd-write-exif-data-program nil nil nil
2122 (mapcar (lambda (arg) (format-spec arg spec))
2123 image-dired-cmd-write-exif-data-options))))
2124
2125(defun image-dired-copy-with-exif-file-name ()
2126 "Copy file with unique name to main image directory.
2127Copy current or all marked files in Dired to a new file in your
2128main image directory, using a file name generated by
2129`image-dired-get-exif-file-name'. A typical usage for this if when
2130copying images from a digital camera into the image directory.
2131
2132 Typically, you would open up the folder with the incoming
2133digital images, mark the files to be copied, and execute this
2134function. The result is a couple of new files in
2135`image-dired-main-image-directory' called
21362005_05_08_12_52_00_dscn0319.jpg,
21372005_05_08_14_27_45_dscn0320.jpg etc."
2138 (interactive)
2139 (let (new-name
2140 (files (dired-get-marked-files)))
2141 (mapc
2142 (lambda (curr-file)
2143 (setq new-name
2144 (format "%s/%s"
2145 (file-name-as-directory
2146 (expand-file-name image-dired-main-image-directory))
2147 (image-dired-get-exif-file-name curr-file)))
2148 (message "Copying %s to %s" curr-file new-name)
2149 (copy-file curr-file new-name))
2150 files)))
2151
2152;;; Thumbnail mode (cont.)
2153
2154(defun image-dired-display-next-thumbnail-original (&optional arg)
2155 "Move to the next image in the thumbnail buffer and display it.
2156With prefix ARG, move that many thumbnails."
2157 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2158 (image-dired--with-thumbnail-buffer
2159 (image-dired-forward-image arg t)
2160 (image-dired-display-thumbnail-original-image)))
2161
2162(defun image-dired-display-previous-thumbnail-original (arg)
2163 "Move to the previous image in the thumbnail buffer and display it.
2164With prefix ARG, move that many thumbnails."
2165 (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode)
2166 (image-dired-display-next-thumbnail-original (- arg)))
2167
2168
2169;;; Image Comments
2170
2171(defun image-dired-write-comments (file-comments)
2172 "Write file comments to database.
2173Write file comments to one or more files.
2174FILE-COMMENTS is an alist on the following form:
2175 ((FILE . COMMENT) ... )"
2176 (image-dired-sane-db-file)
2177 (let (end comment-beg-pos comment-end-pos file comment)
2178 (image-dired--with-db-file
2179 (setq buffer-file-name image-dired-db-file)
2180 (dolist (elt file-comments)
2181 (setq file (car elt)
2182 comment (cdr elt))
2183 (goto-char (point-min))
2184 (if (search-forward-regexp (format "^%s.*$" file) nil t)
2185 (progn
2186 (setq end (point))
2187 (beginning-of-line)
2188 ;; Delete old comment, if any
2189 (when (search-forward ";comment:" end t)
2190 (setq comment-beg-pos (match-beginning 0))
2191 ;; Any tags after the comment?
2192 (if (search-forward ";" end t)
2193 (setq comment-end-pos (- (point) 1))
2194 (setq comment-end-pos end))
2195 ;; Delete comment tag and comment
2196 (delete-region comment-beg-pos comment-end-pos))
2197 ;; Insert new comment
2198 (beginning-of-line)
2199 (unless (search-forward ";" end t)
2200 (end-of-line)
2201 (insert ";"))
2202 (insert (format "comment:%s;" comment)))
2203 ;; File does not exist in database - add it.
2204 (goto-char (point-max))
2205 (insert (format "%s;comment:%s\n" file comment))))
2206 (save-buffer))))
2207
2208(defun image-dired-update-property (prop value)
2209 "Update text property PROP with value VALUE at point."
2210 (let ((inhibit-read-only t))
2211 (put-text-property
2212 (point) (1+ (point))
2213 prop
2214 value)))
2215
2216;;;###autoload
2217(defun image-dired-dired-comment-files ()
2218 "Add comment to current or marked files in Dired."
2219 (interactive)
2220 (let ((comment (image-dired-read-comment)))
2221 (image-dired-write-comments
2222 (mapcar
2223 (lambda (curr-file)
2224 (cons curr-file comment))
2225 (dired-get-marked-files)))))
2226
2227(defun image-dired-comment-thumbnail ()
2228 "Add comment to current thumbnail in thumbnail buffer."
2229 (interactive)
2230 (let* ((file (image-dired-original-file-name))
2231 (comment (image-dired-read-comment file)))
2232 (image-dired-write-comments (list (cons file comment)))
2233 (image-dired-update-property 'comment comment))
2234 (image-dired-update-header-line))
2235
2236(defun image-dired-read-comment (&optional file)
2237 "Read comment for an image.
2238Optionally use old comment from FILE as initial value."
2239 (let ((comment
2240 (read-string
2241 "Comment: "
2242 (if file (image-dired-get-comment file)))))
2243 comment))
2244
2245(defun image-dired-get-comment (file)
2246 "Get comment for file FILE."
2247 (image-dired-sane-db-file)
2248 (image-dired--with-db-file
2249 (let (end comment-beg-pos comment-end-pos comment)
2250 (when (search-forward-regexp (format "^%s" file) nil t)
2251 (end-of-line)
2252 (setq end (point))
2253 (beginning-of-line)
2254 (when (search-forward ";comment:" end t)
2255 (setq comment-beg-pos (point))
2256 (if (search-forward ";" end t)
2257 (setq comment-end-pos (- (point) 1))
2258 (setq comment-end-pos end))
2259 (setq comment (buffer-substring
2260 comment-beg-pos comment-end-pos))))
2261 comment)))
2262
2263;;;###autoload
2264(defun image-dired-mark-tagged-files (regexp)
2265 "Use REGEXP to mark files with matching tag.
2266A `tag' is a keyword, a piece of meta data, associated with an
2267image file and stored in image-dired's database file. This command
2268lets you input a regexp and this will be matched against all tags
2269on all image files in the database file. The files that have a
2270matching tag will be marked in the Dired buffer."
2271 (interactive "sMark tagged files (regexp): ")
2272 (image-dired-sane-db-file)
2273 (let ((hits 0)
2274 files)
2275 (image-dired--with-db-file
2276 ;; Collect matches
2277 (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t)
2278 (let ((file (match-string 1))
2279 (tags (split-string (match-string 2) ";")))
2280 (when (seq-find (lambda (tag)
2281 (string-match-p regexp tag))
2282 tags)
2283 (push file files)))))
2284 ;; Mark files
2285 (dolist (curr-file files)
2286 ;; I tried using `dired-mark-files-regexp' but it was waaaay to
2287 ;; slow. Don't bother about hits found in other directories
2288 ;; than the current one.
2289 (when (string= (file-name-as-directory
2290 (expand-file-name default-directory))
2291 (file-name-as-directory
2292 (file-name-directory curr-file)))
2293 (setq curr-file (file-name-nondirectory curr-file))
2294 (goto-char (point-min))
2295 (when (search-forward-regexp (format "\\s %s$" curr-file) nil t)
2296 (setq hits (+ hits 1))
2297 (dired-mark 1))))
2298 (message "%d files with matching tag marked" hits)))
2299
2300
2301
2302;;; Mouse support
2303
2304(defun image-dired-mouse-display-image (event)
2305 "Use mouse EVENT, call `image-dired-display-image' to display image.
2306Track this in associated Dired buffer if `image-dired-track-movement' is
2307non-nil."
2308 (interactive "e")
2309 (mouse-set-point event)
2310 (goto-char (posn-point (event-end event)))
2311 (unless (image-at-point-p)
2312 (image-dired-backward-image))
2313 (let ((file (image-dired-original-file-name)))
2314 (when file
2315 (if image-dired-track-movement
2316 (image-dired-track-original-file))
2317 (image-dired-display-image file))))
2318
2319(defun image-dired-mouse-select-thumbnail (event)
2320 "Use mouse EVENT to select thumbnail image.
2321Track this in associated Dired buffer if `image-dired-track-movement' is
2322non-nil."
2323 (interactive "e")
2324 (mouse-set-point event)
2325 (goto-char (posn-point (event-end event)))
2326 (unless (image-at-point-p)
2327 (image-dired-backward-image))
2328 (if image-dired-track-movement
2329 (image-dired-track-original-file))
2330 (image-dired-update-header-line))
2331
2332
2333
2334;;; Dired marks and tags
2335
2336(defun image-dired-thumb-file-marked-p (&optional flagged)
2337 "Check if file is marked in associated Dired buffer.
2338If optional argument FLAGGED is non-nil, check if file is flagged
2339for deletion instead."
2340 (let ((file-name (image-dired-original-file-name))
2341 (dired-buf (image-dired-associated-dired-buffer)))
2342 (when (and dired-buf file-name)
2343 (with-current-buffer dired-buf
2344 (save-excursion
2345 (when (dired-goto-file file-name)
2346 (if flagged
2347 (image-dired-dired-file-flagged-p)
2348 (image-dired-dired-file-marked-p))))))))
2349
2350(defun image-dired-thumb-file-flagged-p ()
2351 "Check if file is flagged for deletion in associated Dired buffer."
2352 (image-dired-thumb-file-marked-p t))
2353
2354(defun image-dired-delete-marked ()
2355 "Delete current or marked thumbnails and associated images."
2356 (interactive)
2357 (image-dired--with-marked
2358 (image-dired-delete-char)
2359 (unless (bobp)
2360 (backward-char)))
2361 (image-dired--line-up-with-method)
2362 (with-current-buffer (image-dired-associated-dired-buffer)
2363 (dired-do-delete)))
2364
2365(defun image-dired-thumb-update-marks ()
2366 "Update the marks in the thumbnail buffer."
2367 (when image-dired-thumb-visible-marks
2368 (with-current-buffer image-dired-thumbnail-buffer
2369 (save-mark-and-excursion
2370 (goto-char (point-min))
2371 (let ((inhibit-read-only t))
2372 (while (not (eobp))
2373 (with-silent-modifications
2374 (cond ((image-dired-thumb-file-marked-p)
2375 (add-face-text-property (point) (1+ (point))
2376 'image-dired-thumb-mark))
2377 ((image-dired-thumb-file-flagged-p)
2378 (add-face-text-property (point) (1+ (point))
2379 'image-dired-thumb-flagged))
2380 (t (remove-text-properties (point) (1+ (point))
2381 '(face image-dired-thumb-mark)))))
2382 (forward-char)))))))
2383
2384(defun image-dired-mouse-toggle-mark-1 ()
2385 "Toggle Dired mark for current thumbnail.
2386Track this in associated Dired buffer if
2387`image-dired-track-movement' is non-nil."
2388 (when image-dired-track-movement
2389 (image-dired-track-original-file))
2390 (image-dired-toggle-mark-thumb-original-file))
2391
2392(defun image-dired-mouse-toggle-mark (event)
2393 "Use mouse EVENT to toggle Dired mark for thumbnail.
2394Toggle marks of all thumbnails in region, if it's active.
2395Track this in associated Dired buffer if
2396`image-dired-track-movement' is non-nil."
2397 (interactive "e")
2398 (if (use-region-p)
2399 (let ((end (region-end)))
2400 (save-excursion
2401 (goto-char (region-beginning))
2402 (while (<= (point) end)
2403 (when (image-dired-image-at-point-p)
2404 (image-dired-mouse-toggle-mark-1))
2405 (forward-char))))
2406 (mouse-set-point event)
2407 (goto-char (posn-point (event-end event)))
2408 (image-dired-mouse-toggle-mark-1))
2409 (image-dired-thumb-update-marks))
2410
2411(defun image-dired-dired-display-properties ()
2412 "Display properties for Dired file in the echo area."
2413 (interactive)
2414 (let* ((file (dired-get-filename))
2415 (file-name (file-name-nondirectory file))
2416 (dired-buf (buffer-name (current-buffer)))
2417 (props (mapconcat #'identity (image-dired-list-tags file) ", "))
2418 (comment (image-dired-get-comment file))
2419 (message-log-max nil))
2420 (if file-name
2421 (message "%s"
2422 (image-dired-format-properties-string
2423 dired-buf
2424 file-name
2425 props
2426 comment)))))
2427
2428
2429
2430;;; Gallery support
2431
2432;; TODO:
2433;; * Support gallery creation when using per-directory thumbnail
2434;; storage.
2435;; * Enhanced gallery creation with basic CSS-support and pagination
2436;; of tag pages with many pictures.
2437
2438(defgroup image-dired-gallery nil
2439 "Image-Dired support for generating a HTML gallery."
2440 :prefix "image-dired-"
2441 :group 'image-dired
2442 :version "29.1")
2443
2444(defcustom image-dired-gallery-dir
2445 (expand-file-name ".image-dired_gallery" image-dired-dir)
2446 "Directory to store generated gallery html pages.
2447The name of this directory needs to be \"shared\" to the public
2448so that it can access the index.html page that image-dired creates."
2449 :type 'directory)
2450
2451(defcustom image-dired-gallery-image-root-url
2452 "https://example.org/image-diredpics"
2453 "URL where the full size images are to be found on your web server.
2454Note that this URL has to be configured on your web server.
2455Image-Dired expects to find pictures in this directory.
2456This is used by `image-dired-gallery-generate'."
2457 :type 'string
2458 :version "29.1")
2459
2460(defcustom image-dired-gallery-thumb-image-root-url
2461 "https://example.org/image-diredthumbs"
2462 "URL where the thumbnail images are to be found on your web server.
2463Note that URL path has to be configured on your web server.
2464Image-Dired expects to find pictures in this directory.
2465This is used by `image-dired-gallery-generate'."
2466 :type 'string
2467 :version "29.1")
2468
2469(defcustom image-dired-gallery-hidden-tags
2470 (list "private" "hidden" "pending")
2471 "List of \"hidden\" tags.
2472Used by `image-dired-gallery-generate' to leave out \"hidden\" images."
2473 :type '(repeat string))
2474
2475(defvar image-dired-tag-file-list nil
2476 "List to store tag-file structure.")
2477
2478(defvar image-dired-file-tag-list nil
2479 "List to store file-tag structure.")
2480
2481(defvar image-dired-file-comment-list nil
2482 "List to store file comments.")
2483
2484(defun image-dired--add-to-tag-file-lists (tag file)
2485 "Helper function used from `image-dired--create-gallery-lists'.
2486
2487Add TAG to FILE in one list and FILE to TAG in the other.
2488
2489Lisp structures look like the following:
2490
2491image-dired-file-tag-list:
2492
2493 ((\"filename1\" \"tag1\" \"tag2\" \"tag3\" ...)
2494 (\"filename2\" \"tag1\" \"tag2\" \"tag3\" ...)
2495 ...)
2496
2497image-dired-tag-file-list:
2498
2499 ((\"tag1\" \"filename1\" \"filename2\" \"filename3\" ...)
2500 (\"tag2\" \"filename1\" \"filename2\" \"filename3\" ...)
2501 ...)"
2502 ;; Add tag to file list
2503 (let (curr)
2504 (if image-dired-file-tag-list
2505 (if (setq curr (assoc file image-dired-file-tag-list))
2506 (setcdr curr (cons tag (cdr curr)))
2507 (setcdr image-dired-file-tag-list
2508 (cons (list file tag) (cdr image-dired-file-tag-list))))
2509 (setq image-dired-file-tag-list (list (list file tag))))
2510 ;; Add file to tag list
2511 (if image-dired-tag-file-list
2512 (if (setq curr (assoc tag image-dired-tag-file-list))
2513 (if (not (member file curr))
2514 (setcdr curr (cons file (cdr curr))))
2515 (setcdr image-dired-tag-file-list
2516 (cons (list tag file) (cdr image-dired-tag-file-list))))
2517 (setq image-dired-tag-file-list (list (list tag file))))))
2518
2519(defun image-dired--add-to-file-comment-list (file comment)
2520 "Helper function used from `image-dired--create-gallery-lists'.
2521
2522For FILE, add COMMENT to list.
2523
2524Lisp structure looks like the following:
2525
2526image-dired-file-comment-list:
2527
2528 ((\"filename1\" . \"comment1\")
2529 (\"filename2\" . \"comment2\")
2530 ...)"
2531 (if image-dired-file-comment-list
2532 (if (not (assoc file image-dired-file-comment-list))
2533 (setcdr image-dired-file-comment-list
2534 (cons (cons file comment)
2535 (cdr image-dired-file-comment-list))))
2536 (setq image-dired-file-comment-list (list (cons file comment)))))
2537
2538(defun image-dired--create-gallery-lists ()
2539 "Create temporary lists used by `image-dired-gallery-generate'."
2540 (image-dired-sane-db-file)
2541 (image-dired--with-db-file
2542 (let (end beg file row-tags)
2543 (setq image-dired-tag-file-list nil)
2544 (setq image-dired-file-tag-list nil)
2545 (setq image-dired-file-comment-list nil)
2546 (goto-char (point-min))
2547 (while (search-forward-regexp "^." nil t)
2548 (end-of-line)
2549 (setq end (point))
2550 (beginning-of-line)
2551 (setq beg (point))
2552 (unless (search-forward ";" end nil)
2553 (error "Something is really wrong, check format of database"))
2554 (setq row-tags (split-string
2555 (buffer-substring beg end) ";"))
2556 (setq file (car row-tags))
2557 (dolist (x (cdr row-tags))
2558 (if (not (string-match "^comment:\\(.*\\)" x))
2559 (image-dired--add-to-tag-file-lists x file)
2560 (image-dired--add-to-file-comment-list file (match-string 1 x)))))))
2561 ;; Sort tag-file list
2562 (setq image-dired-tag-file-list
2563 (sort image-dired-tag-file-list
2564 (lambda (x y)
2565 (string< (car x) (car y))))))
2566
2567(defun image-dired--hidden-p (file)
2568 "Return t if image FILE has a \"hidden\" tag."
2569 (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list))
2570 if (member tag image-dired-gallery-hidden-tags) return t))
2571
2572(defun image-dired-gallery-generate ()
2573 "Generate gallery pages.
2574First we create a couple of Lisp structures from the database to make
2575it easier to generate, then HTML-files are created in
2576`image-dired-gallery-dir'."
2577 (interactive)
2578 (if (eq 'per-directory image-dired-thumbnail-storage)
2579 (error "Currently, gallery generation is not supported \
2580when using per-directory thumbnail file storage"))
2581 (image-dired--create-gallery-lists)
2582 (let ((tags image-dired-tag-file-list)
2583 (index-file (format "%s/index.html" image-dired-gallery-dir))
2584 count tag tag-file
2585 comment file-tags tag-link tag-link-list)
2586 ;; Make sure gallery root exist
2587 (if (file-exists-p image-dired-gallery-dir)
2588 (if (not (file-directory-p image-dired-gallery-dir))
2589 (error "Variable image-dired-gallery-dir is not a directory"))
2590 ;; FIXME: Should we set umask to 077 here, as we do for thumbnails?
2591 (make-directory image-dired-gallery-dir))
2592 ;; Open index file
2593 (with-temp-file index-file
2594 (if (file-exists-p index-file)
2595 (insert-file-contents index-file))
2596 (insert "<html>\n")
2597 (insert " <body>\n")
2598 (insert " <h2>Image-Dired Gallery</h2>\n")
2599 (insert (format "<p>\n Gallery generated %s\n <p>\n"
2600 (current-time-string)))
2601 (insert " <h3>Tag index</h3>\n")
2602 (setq count 1)
2603 ;; Pre-generate list of all tag links
2604 (dolist (curr tags)
2605 (setq tag (car curr))
2606 (when (not (member tag image-dired-gallery-hidden-tags))
2607 (setq tag-link (format "<a href=\"%d.html\">%s</a>" count tag))
2608 (if tag-link-list
2609 (setq tag-link-list
2610 (append tag-link-list (list (cons tag tag-link))))
2611 (setq tag-link-list (list (cons tag tag-link))))
2612 (setq count (1+ count))))
2613 (setq count 1)
2614 ;; Main loop where we generated thumbnail pages per tag
2615 (dolist (curr tags)
2616 (setq tag (car curr))
2617 ;; Don't display hidden tags
2618 (when (not (member tag image-dired-gallery-hidden-tags))
2619 ;; Insert link to tag page in index
2620 (insert (format " %s<br>\n" (cdr (assoc tag tag-link-list))))
2621 ;; Open per-tag file
2622 (setq tag-file (format "%s/%s.html" image-dired-gallery-dir count))
2623 (with-temp-file tag-file
2624 (if (file-exists-p tag-file)
2625 (insert-file-contents tag-file))
2626 (erase-buffer)
2627 (insert "<html>\n")
2628 (insert " <body>\n")
2629 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2630 (insert (format " <h2>Images with tag &quot;%s&quot;</h2>" tag))
2631 ;; Main loop for files per tag page
2632 (dolist (file (cdr curr))
2633 (unless (image-dired-hidden-p file)
2634 ;; Insert thumbnail with link to full image
2635 (insert
2636 (format "<a href=\"%s/%s\"><img src=\"%s/%s\"%s></a>\n"
2637 image-dired-gallery-image-root-url
2638 (file-name-nondirectory file)
2639 image-dired-gallery-thumb-image-root-url
2640 (file-name-nondirectory (image-dired-thumb-name file)) file))
2641 ;; Insert comment, if any
2642 (if (setq comment (cdr (assoc file image-dired-file-comment-list)))
2643 (insert (format "<br>\n%s<br>\n" comment))
2644 (insert "<br>\n"))
2645 ;; Insert links to other tags, if any
2646 (when (> (length
2647 (setq file-tags (assoc file image-dired-file-tag-list))) 2)
2648 (insert "[ ")
2649 (dolist (extra-tag file-tags)
2650 ;; Only insert if not file name or the main tag
2651 (if (and (not (equal extra-tag tag))
2652 (not (equal extra-tag file)))
2653 (insert
2654 (format "%s " (cdr (assoc extra-tag tag-link-list))))))
2655 (insert "]<br>\n"))))
2656 (insert " <p><a href=\"index.html\">Index</a></p>\n")
2657 (insert " </body>\n")
2658 (insert "</html>\n"))
2659 (setq count (1+ count))))
2660 (insert " </body>\n")
2661 (insert "</html>"))))
2662
2663
2664;;; Tag support
2665
2666(defvar image-dired-widget-list nil
2667 "List to keep track of meta data in edit buffer.")
2668
2669(declare-function widget-forward "wid-edit" (arg))
2670
2671;;;###autoload
2672(defun image-dired-dired-edit-comment-and-tags ()
2673 "Edit comment and tags of current or marked image files.
2674Edit comment and tags for all marked image files in an
2675easy-to-use form."
2676 (interactive)
2677 (setq image-dired-widget-list nil)
2678 ;; Setup buffer.
2679 (let ((files (dired-get-marked-files)))
2680 (pop-to-buffer-same-window "*Image-Dired Edit Meta Data*")
2681 (kill-all-local-variables)
2682 (let ((inhibit-read-only t))
2683 (erase-buffer))
2684 (remove-overlays)
2685 ;; Some help for the user.
2686 (widget-insert
2687"\nEdit comments and tags for each image. Separate multiple tags
2688with a comma. Move forward between fields using TAB or RET.
2689Move to the previous field using backtab (S-TAB). Save by
2690activating the Save button at the bottom of the form or cancel
2691the operation by activating the Cancel button.\n\n")
2692 ;; Here comes all images and a comment and tag field for each
2693 ;; image.
2694 (let (thumb-file img comment-widget tag-widget)
2695
2696 (dolist (file files)
2697
2698 (setq thumb-file (image-dired-thumb-name file)
2699 img (create-image thumb-file))
2700
2701 (insert-image img)
2702 (widget-insert "\n\nComment: ")
2703 (setq comment-widget
2704 (widget-create 'editable-field
2705 :size 60
2706 :format "%v "
2707 :value (or (image-dired-get-comment file) "")))
2708 (widget-insert "\nTags: ")
2709 (setq tag-widget
2710 (widget-create 'editable-field
2711 :size 60
2712 :format "%v "
2713 :value (or (mapconcat
2714 #'identity
2715 (image-dired-list-tags file)
2716 ",") "")))
2717 ;; Save information in all widgets so that we can use it when
2718 ;; the user saves the form.
2719 (setq image-dired-widget-list
2720 (append image-dired-widget-list
2721 (list (list file comment-widget tag-widget))))
2722 (widget-insert "\n\n")))
2723
2724 ;; Footer with Save and Cancel button.
2725 (widget-insert "\n")
2726 (widget-create 'push-button
2727 :notify
2728 (lambda (&rest _ignore)
2729 (image-dired-save-information-from-widgets)
2730 (bury-buffer)
2731 (message "Done"))
2732 "Save")
2733 (widget-insert " ")
2734 (widget-create 'push-button
2735 :notify
2736 (lambda (&rest _ignore)
2737 (bury-buffer)
2738 (message "Operation canceled"))
2739 "Cancel")
2740 (widget-insert "\n")
2741 (use-local-map widget-keymap)
2742 (widget-setup)
2743 ;; Jump to the first widget.
2744 (widget-forward 1)))
2745
2746(defun image-dired-save-information-from-widgets ()
2747 "Save information found in `image-dired-widget-list'.
2748Use the information in `image-dired-widget-list' to save comments and
2749tags to their respective image file. Internal function used by
2750`image-dired-dired-edit-comment-and-tags'."
2751 (let (file comment tag-string tag-list lst)
2752 (image-dired-write-comments
2753 (mapcar
2754 (lambda (widget)
2755 (setq file (car widget)
2756 comment (widget-value (cadr widget)))
2757 (cons file comment))
2758 image-dired-widget-list))
2759 (image-dired-write-tags
2760 (dolist (widget image-dired-widget-list lst)
2761 (setq file (car widget)
2762 tag-string (widget-value (car (cddr widget)))
2763 tag-list (split-string tag-string ","))
2764 (dolist (tag tag-list)
2765 (push (cons file tag) lst))))))
2766
2767
2768;;; bookmark.el support
2769
2770(declare-function bookmark-make-record-default
2771 "bookmark" (&optional no-file no-context posn))
2772(declare-function bookmark-prop-get "bookmark" (bookmark prop))
2773
2774(defun image-dired-bookmark-name ()
2775 "Create a default bookmark name for the current EWW buffer."
2776 (file-name-nondirectory
2777 (directory-file-name
2778 (file-name-directory (image-dired-original-file-name)))))
2779
2780(defun image-dired-bookmark-make-record ()
2781 "Create a bookmark for the current EWW buffer."
2782 `(,(image-dired-bookmark-name)
2783 ,@(bookmark-make-record-default t)
2784 (location . ,(file-name-directory (image-dired-original-file-name)))
2785 (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name)))
2786 (handler . image-dired-bookmark-jump)))
2787
2788;;;###autoload
2789(defun image-dired-bookmark-jump (bookmark)
2790 "Default bookmark handler for Image-Dired buffers."
2791 ;; User already cached thumbnails, so disable any checking.
2792 (let ((image-dired-show-all-from-dir-max-files nil))
2793 (image-dired (bookmark-prop-get bookmark 'location))
2794 ;; TODO: Go to the bookmarked file, if it exists.
2795 ;; (bookmark-prop-get bookmark 'image-dired-file)
2796 (goto-char (point-min))))
2797
2798(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image-Dired")
2799
2800;;; Obsolete
2801
2802;;;###autoload
2803(define-obsolete-function-alias 'tumme #'image-dired "24.4")
2804
2805;;;###autoload
2806(define-obsolete-function-alias 'image-dired-setup-dired-keybindings
2807 #'image-dired-minor-mode "26.1")
2808
2809(defcustom image-dired-temp-image-file
2810 (expand-file-name ".image-dired_temp" image-dired-dir)
2811 "Name of temporary image file used by various commands."
2812 :type 'file)
2813(make-obsolete-variable 'image-dired-temp-image-file
2814 "no longer used." "29.1")
2815
2816(defcustom image-dired-cmd-create-temp-image-program
2817 (if (executable-find "gm") "gm" "convert")
2818 "Executable used to create temporary image.
2819Used together with `image-dired-cmd-create-temp-image-options'."
2820 :type 'file
2821 :version "29.1")
2822(make-obsolete-variable 'image-dired-cmd-create-temp-image-program
2823 "no longer used." "29.1")
2824
2825(defcustom image-dired-cmd-create-temp-image-options
2826 (let ((opts '("-size" "%wx%h" "%f[0]"
2827 "-resize" "%wx%h>"
2828 "-strip" "jpeg:%t")))
2829 (if (executable-find "gm") (cons "convert" opts) opts))
2830 "Options of command used to create temporary image for display window.
2831Used together with `image-dired-cmd-create-temp-image-program',
2832Available format specifiers are: %w and %h which are replaced by
2833the calculated max size for width and height in the image display window,
2834%f which is replaced by the file name of the original image and %t which
2835is replaced by the file name of the temporary file."
2836 :version "29.1"
2837 :type '(repeat (string :tag "Argument")))
2838(make-obsolete-variable 'image-dired-cmd-create-temp-image-options
2839 "no longer used." "29.1")
2840
2841(defcustom image-dired-display-window-width-correction 1
2842 "Number to be used to correct image display window width.
2843Change if the default (1) does not work (i.e. if the image does not
2844completely fit)."
2845 :type 'integer)
2846(make-obsolete-variable 'image-dired-display-window-width-correction
2847 "no longer used." "29.1")
2848
2849(defcustom image-dired-display-window-height-correction 0
2850 "Number to be used to correct image display window height.
2851Change if the default (0) does not work (i.e. if the image does not
2852completely fit)."
2853 :type 'integer)
2854(make-obsolete-variable 'image-dired-display-window-height-correction
2855 "no longer used." "29.1")
2856
2857(defun image-dired-display-window-width (window)
2858 "Return width, in pixels, of WINDOW."
2859 (declare (obsolete nil "29.1"))
2860 (- (image-dired-window-width-pixels window)
2861 image-dired-display-window-width-correction))
2862
2863(defun image-dired-display-window-height (window)
2864 "Return height, in pixels, of WINDOW."
2865 (declare (obsolete nil "29.1"))
2866 (- (image-dired-window-height-pixels window)
2867 image-dired-display-window-height-correction))
2868
2869(defun image-dired-window-height-pixels (window)
2870 "Calculate WINDOW height in pixels."
2871 (declare (obsolete nil "29.1"))
2872 ;; Note: The mode-line consumes one line
2873 (* (- (window-height window) 1) (frame-char-height)))
2874
2875(defcustom image-dired-cmd-read-exif-data-program "exiftool"
2876 "Program used to read EXIF data to image.
2877Used together with `image-dired-cmd-read-exif-data-options'."
2878 :type 'file)
2879(make-obsolete-variable 'image-dired-cmd-read-exif-data-program
2880 "use `exif-parse-file' and `exif-field' instead." "29.1")
2881
2882(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f")
2883 "Arguments of command used to read EXIF data.
2884Used with `image-dired-cmd-read-exif-data-program'.
2885Available format specifiers are: %f which is replaced
2886by the image file name and %t which is replaced by the tag name."
2887 :version "26.1"
2888 :type '(repeat (string :tag "Argument")))
2889(make-obsolete-variable 'image-dired-cmd-read-exif-data-options
2890 "use `exif-parse-file' and `exif-field' instead." "29.1")
2891
2892(defun image-dired-get-exif-data (file tag-name)
2893 "From FILE, return EXIF tag TAG-NAME."
2894 (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1"))
2895 (image-dired--check-executable-exists
2896 'image-dired-cmd-read-exif-data-program)
2897 (let ((buf (get-buffer-create "*image-dired-get-exif-data*"))
2898 (spec (list (cons ?f file) (cons ?t tag-name)))
2899 tag-value)
2900 (with-current-buffer buf
2901 (delete-region (point-min) (point-max))
2902 (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program
2903 nil t nil
2904 (mapcar
2905 (lambda (arg) (format-spec arg spec))
2906 image-dired-cmd-read-exif-data-options))
2907 0))
2908 (error "Could not get EXIF tag")
2909 (goto-char (point-min))
2910 ;; Clean buffer from newlines and carriage returns before
2911 ;; getting final info
2912 (while (search-forward-regexp "[\n\r]" nil t)
2913 (replace-match "" nil t))
2914 (setq tag-value (buffer-substring (point-min) (point-max)))))
2915 tag-value))
2916
2917(defcustom image-dired-cmd-rotate-thumbnail-program
2918 (if (executable-find "gm") "gm" "mogrify")
2919 "Executable used to rotate thumbnail.
2920Used together with `image-dired-cmd-rotate-thumbnail-options'."
2921 :type 'file
2922 :version "29.1")
2923(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1")
2924
2925(defcustom image-dired-cmd-rotate-thumbnail-options
2926 (let ((opts '("-rotate" "%d" "%t")))
2927 (if (executable-find "gm") (cons "mogrify" opts) opts))
2928 "Arguments of command used to rotate thumbnail image.
2929Used with `image-dired-cmd-rotate-thumbnail-program'.
2930Available format specifiers are: %d which is replaced by the
2931number of (positive) degrees to rotate the image, normally 90 or 270
2932\(for 90 degrees right and left), %t which is replaced by the file name
2933of the thumbnail file."
2934 :version "29.1"
2935 :type '(repeat (string :tag "Argument")))
2936(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1")
2937
2938(defun image-dired-rotate-thumbnail (degrees)
2939 "Rotate thumbnail DEGREES degrees."
2940 (declare (obsolete image-dired-refresh-thumb "29.1"))
2941 (image-dired--check-executable-exists
2942 'image-dired-cmd-rotate-thumbnail-program)
2943 (if (not (image-dired-image-at-point-p))
2944 (message "No thumbnail at point")
2945 (let* ((file (image-dired-thumb-name (image-dired-original-file-name)))
2946 (thumb (expand-file-name file))
2947 (spec (list (cons ?d degrees) (cons ?t thumb))))
2948 (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil
2949 (mapcar (lambda (arg) (format-spec arg spec))
2950 image-dired-cmd-rotate-thumbnail-options))
2951 (clear-image-cache thumb))))
2952
2953(defun image-dired-rotate-thumbnail-left ()
2954 "Rotate thumbnail left (counter clockwise) 90 degrees."
2955 (declare (obsolete image-dired-refresh-thumb "29.1"))
2956 (interactive)
2957 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2958 (image-dired-rotate-thumbnail "270")))
2959
2960(defun image-dired-rotate-thumbnail-right ()
2961 "Rotate thumbnail counter right (clockwise) 90 degrees."
2962 (declare (obsolete image-dired-refresh-thumb "29.1"))
2963 (interactive)
2964 (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail))
2965 (image-dired-rotate-thumbnail "90")))
2966
2967(defun image-dired-modify-mark-on-thumb-original-file (command)
2968 "Modify mark in Dired buffer.
2969COMMAND is one of `mark' for marking file in Dired, `unmark' for
2970unmarking file in Dired or `flag' for flagging file for delete in
2971Dired."
2972 (declare (obsolete image-dired--on-file-in-dired-buffer "29.1"))
2973 (let ((file-name (image-dired-original-file-name))
2974 (dired-buf (image-dired-associated-dired-buffer)))
2975 (if (not (and dired-buf file-name))
2976 (message "No image, or image with correct properties, at point")
2977 (with-current-buffer dired-buf
2978 (message "%s" file-name)
2979 (when (dired-goto-file file-name)
2980 (cond ((eq command 'mark) (dired-mark 1))
2981 ((eq command 'unmark) (dired-unmark 1))
2982 ((eq command 'toggle)
2983 (if (image-dired-dired-file-marked-p)
2984 (dired-unmark 1)
2985 (dired-mark 1)))
2986 ((eq command 'flag) (dired-flag-file-deletion 1)))
2987 (image-dired-thumb-update-marks))))))
2988
2989(defun image-dired-display-current-image-full ()
2990 "Display current image in full size."
2991 (declare (obsolete image-transform-original "29.1"))
2992 (interactive nil image-dired-thumbnail-mode)
2993 (let ((file (image-dired-original-file-name)))
2994 (if file
2995 (progn
2996 (image-dired-display-image file)
2997 (with-current-buffer image-dired-display-image-buffer
2998 (image-transform-original)))
2999 (error "No original file name at point"))))
3000
3001(defun image-dired-display-current-image-sized ()
3002 "Display current image in sized to fit window dimensions."
3003 (declare (obsolete image-mode-fit-frame "29.1"))
3004 (interactive nil image-dired-thumbnail-mode)
3005 (let ((file (image-dired-original-file-name)))
3006 (if file
3007 (progn
3008 (image-dired-display-image file))
3009 (error "No original file name at point"))))
3010
3011(defun image-dired-add-to-tag-file-list (tag file)
3012 "Add relation between TAG and FILE."
3013 (declare (obsolete nil "29.1"))
3014 (let (curr)
3015 (if image-dired-tag-file-list
3016 (if (setq curr (assoc tag image-dired-tag-file-list))
3017 (if (not (member file curr))
3018 (setcdr curr (cons file (cdr curr))))
3019 (setcdr image-dired-tag-file-list
3020 (cons (list tag file) (cdr image-dired-tag-file-list))))
3021 (setq image-dired-tag-file-list (list (list tag file))))))
3022
3023(defun image-dired-display-thumb-properties ()
3024 "Display thumbnail properties in the echo area."
3025 (declare (obsolete image-dired-update-header-line "29.1"))
3026 (image-dired-update-header-line))
3027
3028(defvar image-dired-slideshow-count 0
3029 "Keeping track on number of images in slideshow.")
3030(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1")
3031
3032(defvar image-dired-slideshow-times 0
3033 "Number of pictures to display in slideshow.")
3034(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1")
3035
3036(define-obsolete-function-alias 'image-dired-create-display-image-buffer
3037 #'ignore "29.1")
3038(define-obsolete-function-alias 'image-dired-create-gallery-lists
3039 #'image-dired--create-gallery-lists "29.1")
3040(define-obsolete-function-alias 'image-dired-add-to-file-comment-list
3041 #'image-dired--add-to-file-comment-list "29.1")
3042(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists
3043 #'image-dired--add-to-tag-file-lists "29.1")
3044(define-obsolete-function-alias 'image-dired-hidden-p
3045 #'image-dired--hidden-p "29.1")
3046
3047;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3048;;;;;;;;; TEST-SECTION ;;;;;;;;;;;
3049;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3050
3051;; (defvar image-dired-dir-max-size 12300000)
3052
3053;; (defun image-dired-test-clean-old-files ()
3054;; "Clean `image-dired-dir' from old thumbnail files.
3055;; \"Oldness\" measured using last access time. If the total size of all
3056;; thumbnail files in `image-dired-dir' is larger than 'image-dired-dir-max-size',
3057;; old files are deleted until the max size is reached."
3058;; (let* ((files
3059;; (sort
3060;; (mapcar
3061;; (lambda (f)
3062;; (let ((fattribs (file-attributes f)))
3063;; `(,(file-attribute-access-time fattribs)
3064;; ,(file-attribute-size fattribs) ,f)))
3065;; (directory-files (image-dired-dir) t ".+\\.thumb\\..+$"))
3066;; ;; Sort function. Compare time between two files.
3067;; (lambda (l1 l2)
3068;; (time-less-p (car l1) (car l2)))))
3069;; (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files))))
3070;; (while (> dirsize image-dired-dir-max-size)
3071;; (y-or-n-p
3072;; (format "Size of thumbnail directory: %d, delete old file %s? "
3073;; dirsize (cadr (cdar files))))
3074;; (delete-file (cadr (cdar files)))
3075;; (setq dirsize (- dirsize (car (cdar files))))
3076;; (setq files (cdr files)))))
3077
3078(provide 'image-dired)
3079
3080;;; image-dired.el ends here
diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image/image-dired-tests.el
index 00df72487fd..00df72487fd 100644
--- a/test/lisp/image-dired-tests.el
+++ b/test/lisp/image/image-dired-tests.el