1 ;;; thumbs.el --- Thumbnails previewer for images files
3 ;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca>
5 ;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some time
6 ;; The peoples at #emacs@freenode.net for numerous help
7 ;; RMS for emacs and the GNU project.
9 ;; Keywords: Multimedia
11 (defconst thumbs-version
"2.0")
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software; you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation; either version 2, or (at your option)
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs; see the file COPYING. If not, write to the
27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
28 ;; Boston, MA 02111-1307, USA.
32 ;; This package create two new mode: thumbs-mode and
33 ;; thumbs-view-image-mode. It is used for images browsing and viewing
34 ;; from within emacs. Minimal image manipulation functions are also
35 ;; available via external programs.
37 ;; The 'convert' program from 'ImageMagick'
38 ;; [URL:http://www.imagemagick.org/] is required.
40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
43 ;; This is version 2.0
47 ;; Type M-x thumbs RET DIR RET to view the directory DIR in Thumbs mode.
48 ;; That should be a directory containing image files.
49 ;; from dired, C-t m enter in thumbs-mode with all marked files
50 ;; C-t a enter in thumbs-mode with all files in current-directory
51 ;; In thumbs-mode, pressing <return> on a image will bring you in image view mode
52 ;; for that image. C-h m will give you a list of available keybinding.
61 ;; Abort if in-line imaging isn't supported (i.e. Emacs-20.7)
63 (when (not (display-images-p))
64 (error "Your Emacs version (%S) doesn't support in-line images,
65 was not compiled with image support or is run in console mode.
66 Upgrade to Emacs 21.1 or newer, compile it with image support
67 or use a window-system"
73 "Thumbnails previewer."
76 (defcustom thumbs-thumbsdir
77 (expand-file-name "~/.emacs-thumbs")
78 "*Directory to store thumbnails."
82 (defcustom thumbs-geometry
"100x100"
83 "*Size of thumbnails."
87 (defcustom thumbs-per-line
5
88 "*Number of thumbnails per line to show in directory."
92 (defcustom thumbs-thumbsdir-max-size
50000000
93 "Max size for thumbnails directory.
94 When it reach that size (in bytes), a warning is send."
98 (defcustom thumbs-conversion-program
99 (if (equal 'windows-nt system-type
)
101 (or (executable-find "convert")
102 "/usr/X11R6/bin/convert"))
103 "*Name of conversion program for thumbnails generation.
104 It must be 'convert'."
108 (defcustom thumbs-setroot-command
109 "xloadimage -onroot -fullscreen *"
110 "Command to set the root window."
114 (defcustom thumbs-relief
5
115 "*Size of button-like border around thumbnails."
119 (defcustom thumbs-margin
2
120 "*Size of the margin around thumbnails.
121 This is where you see the cursor."
125 (defcustom thumbs-thumbsdir-auto-clean t
126 "If set, delete older file in the thumbnails directory.
127 Deletion is done at load time when the directory size is bigger
128 than 'thumbs-thumbsdir-max-size'."
132 (defcustom thumbs-image-resizing-step
10
133 "Step by wich to resize image."
137 (defcustom thumbs-temp-dir
139 "Temporary directory to use.
140 Leaving it to default '/tmp/' can let another user
141 see some of your images."
145 (defcustom thumbs-temp-prefix
"emacsthumbs"
146 "Prefix to add to temp files."
150 ;; Initialize some variable, for later use.
151 (defvar thumbs-temp-file
152 (concat thumbs-temp-dir thumbs-temp-prefix
)
153 "Temporary filesname for images.")
155 (defvar thumbs-current-tmp-filename
157 "Temporary filename of current image.")
158 (defvar thumbs-current-image-filename
160 "Filename of current image.")
161 (defvar thumbs-current-image-size
163 "Size of current image.")
164 (defvar thumbs-image-num
166 "Number of current image.")
167 (defvar thumbs-current-dir
169 "Current directory.")
170 (defvar thumbs-markedL
172 "List of marked files.")
174 ;; Make sure auto-image-file-mode is ON.
175 (auto-image-file-mode t
)
177 ;; Create the thumbs directory if it does not exists.
178 (setq thumbs-thumbsdir
(expand-file-name thumbs-thumbsdir
))
180 (when (not (file-directory-p thumbs-thumbsdir
))
182 (make-directory thumbs-thumbsdir
)
183 (message "Creating thumbnails directory")))
185 (when (not (fboundp 'ignore-errors
))
186 (defmacro ignore-errors
(&rest body
)
187 "Execute FORMS; if anz error occurs, return nil.
188 Otherwise, return result of last FORM."
189 (let ((err (thumbs-gensym)))
190 (list 'condition-case err
(cons 'progn body
) '(error nil
)))))
192 (when (not (fboundp 'time-less-p
))
193 (defun time-less-p (t1 t2
)
194 "Say whether time T1 is less than time T2."
195 (or (< (car t1
) (car t2
))
196 (and (= (car t1
) (car t2
))
197 (< (nth 1 t1
) (nth 1 t2
))))))
199 (when (not (fboundp 'caddar
))
201 "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
202 (car (cdr (cdr (car x
))))))
204 (defvar thumbs-gensym-counter
0)
206 (defun thumbs-gensym (&optional arg
)
207 "Generate a new uninterned symbol.
208 The name is made by appending a number to PREFIX, default \"Thumbs\"."
209 (let ((prefix (if (stringp arg
) arg
"Thumbs"))
210 (num (if (integerp arg
) arg
212 thumbs-gensym-counter
213 (setq thumbs-gensym-counter
(1+ thumbs-gensym-counter
))))))
214 (make-symbol (format "%s%d" prefix num
))))
216 (defun thumbs-cleanup-thumbsdir ()
217 "Clean the thumbnails directory.
218 If the total size of all files in 'thumbs-thumbsdir' is bigger than
219 'thumbs-thumbsdir-max-size', files are deleted until the max size is
225 (let ((fattribsL (file-attributes f
)))
226 `(,(nth 4 fattribsL
) ,(nth 7 fattribsL
) ,f
)))
227 (directory-files thumbs-thumbsdir t
(image-file-name-regexp)))
228 '(lambda (l1 l2
) (time-less-p (car l1
)(car l2
)))))
229 (dirsize (apply '+ (mapcar (lambda (x) (cadr x
)) filesL
))))
230 (while (> dirsize thumbs-thumbsdir-max-size
)
232 (message "Deleting file %s" (caddar filesL
)))
233 (delete-file (caddar filesL
))
234 (setq dirsize
(- dirsize
(cadar filesL
)))
235 (setq filesL
(cdr filesL
)))))
237 ;; Check the thumbsnail directory size and clean it if necessary.
238 (when thumbs-thumbsdir-auto-clean
239 (thumbs-cleanup-thumbsdir))
241 (defun thumbs-call-convert (filein fileout action
242 &optional arg output-format action-prefix
)
243 "Call the convert program.
244 FILEIN is the input file,
245 FILEOUT is the output file,
246 ACTION is the command to send to convert.
247 Optional argument are:
248 ARG any arguments to the ACTION command,
249 OUTPUT-FORMAT is the file format to output, default is jpeg
250 ACTION-PREFIX is the symbol to place before the ACTION command
251 (default to '-' but can sometime be '+')."
252 (let ((command (format "%s %s%s %s \"%s\" \"%s:%s\""
253 thumbs-conversion-program
254 (or action-prefix
"-")
258 (or output-format
"jpeg")
260 (shell-command command
)))
262 (defun thumbs-increment-image-size-element (n d
)
263 "Increment number N by D percent."
264 (round (+ n
(/ (* d n
) 100))))
266 (defun thumbs-decrement-image-size-element (n d
)
267 "Decrement number N by D percent."
268 (round (- n
(/ (* d n
) 100))))
270 (defun thumbs-increment-image-size (s)
271 "Increment S (a cons of width x heigh)."
273 (thumbs-increment-image-size-element (car s
)
274 thumbs-image-resizing-step
)
275 (thumbs-increment-image-size-element (cdr s
)
276 thumbs-image-resizing-step
)))
278 (defun thumbs-decrement-image-size (s)
279 "Decrement S (a cons of width x heigh)."
281 (thumbs-decrement-image-size-element (car s
)
282 thumbs-image-resizing-step
)
283 (thumbs-decrement-image-size-element (cdr s
)
284 thumbs-image-resizing-step
)))
286 (defun thumbs-resize-image (&optional increment size
)
287 "Resize image in current buffer.
288 if INCREMENT is set, make the image bigger, else smaller.
289 Or, alternatively, a SIZE may be specified."
291 ;; cleaning of old temp file
296 thumbs-temp-prefix
)))
297 (let ((buffer-read-only nil
)
301 (thumbs-increment-image-size
302 thumbs-current-image-size
)
303 (thumbs-decrement-image-size
304 thumbs-current-image-size
))))
305 (tmp (format "%s%s.jpg" thumbs-temp-file
(thumbs-gensym))))
307 (thumbs-call-convert thumbs-current-image-filename
309 (concat (number-to-string (car x
)) "x"
310 (number-to-string (cdr x
))))
311 (thumbs-insert-image tmp
'jpeg
0)
312 (setq thumbs-current-tmp-filename tmp
)))
314 (defun thumbs-resize-interactive (width height
)
315 "Resize Image interactively to specified WIDTH and HEIGHT."
316 (interactive "nWidth: \nnHeight: ")
317 (thumbs-resize-image nil
(cons width height
)))
319 (defun thumbs-resize-image-size-down ()
320 "Resize image (smaller)."
322 (thumbs-resize-image nil
))
324 (defun thumbs-resize-image-size-up ()
325 "Resize image (bigger)."
327 (thumbs-resize-image t
))
329 (defun thumbs-subst-char-in-string (orig rep string
)
330 "Replace occurrences of character ORIG with character REP in STRING.
331 Return the resulting (new) string. -- (defun borowed to Dave Love)"
332 (let ((string (copy-sequence string
))
336 (if (= (aref string i
) orig
)
341 (defun thumbs-thumbname (img)
342 "Return a thumbnail name for the image IMG."
343 (concat thumbs-thumbsdir
"/"
344 (thumbs-subst-char-in-string
349 (expand-file-name img
) "/")))))
351 (defun thumbs-make-thumb (img)
352 "Create the thumbnail for IMG."
353 (let* ((fn (expand-file-name img
))
354 (tn (thumbs-thumbname img
)))
355 (if (or (not (file-exists-p tn
))
356 (not (equal (thumbs-file-size tn
) thumbs-geometry
)))
357 (thumbs-call-convert fn tn
"sample" thumbs-geometry
))
360 (defun thumbs-image-type (img)
361 "Return image type from filename IMG."
362 (cond ((string-match ".*\\.jpe?g\\'" img
) 'jpeg
)
363 ((string-match ".*\\.xpm\\'" img
) 'xpm
)
364 ((string-match ".*\\.xbm\\'" img
) 'xbm
)
365 ((string-match ".*\\.gif\\'" img
) 'gif
)
366 ((string-match ".*\\.bmp\\'" img
) 'bmp
)
367 ((string-match ".*\\.png\\'" img
) 'png
)
368 ((string-match ".*\\.tiff?\\'" img
) 'tiff
)))
370 (defun thumbs-file-size (img)
371 (let ((i (image-size (find-image `((:type
,(thumbs-image-type img
) :file
,img
))) t
)))
372 (concat (number-to-string (round (car i
)))
374 (number-to-string (round (cdr i
))))))
377 (defun thumbs-find-thumb (img)
378 "Display the thumbnail for IMG."
380 (find-file (thumbs-make-thumb img
)))
382 (defun thumbs-insert-image (img type relief
&optional marked
)
383 "Insert image IMG at point.
384 TYPE and RELIEF will be used in constructing the image; see `image'
385 in the emacs-lisp manual for further documentation.
386 if MARKED is non-nil, the image is marked."
387 (let ((i `(image :type
,type
390 :conversion
,(if marked
'disabled
)
391 :margin
,thumbs-margin
)))
393 (setq thumbs-current-image-size
396 (defun thumbs-insert-thumb (img &optional marked
)
397 "Insert the thumbnail for IMG at point.
398 if MARKED is non-nil, the image is marked"
400 (thumbs-make-thumb img
) 'jpeg thumbs-relief marked
))
402 (defun thumbs-do-thumbs-insertion (L)
403 "Insert all thumbs in list L."
404 (setq thumbs-fileL nil
)
407 (when (= 0 (mod (setq i
(1+ i
)) thumbs-per-line
))
409 (setq thumbs-fileL
(cons (cons (point)
412 (thumbs-insert-thumb (car L
)
413 (member (car L
) thumbs-markedL
))
416 (defun thumbs-show-thumbs-list (L &optional buffer-name same-window
)
417 (funcall (if same-window
'switch-to-buffer
'pop-to-buffer
)
418 (or buffer-name
"*THUMB-View*"))
419 (let ((inhibit-read-only t
))
422 (make-variable-buffer-local 'thumbs-fileL
)
423 (setq thumbs-fileL nil
)
424 (thumbs-do-thumbs-insertion L
)
425 (goto-char (point-min))
426 (setq thumbs-current-dir default-directory
)
427 (make-variable-buffer-local 'thumbs-current-dir
)))
430 (defun thumbs-show-all-from-dir (dir &optional reg same-window
)
431 "Make a preview buffer for all images in DIR.
432 Optional argument REG to select file matching a regexp,
433 and SAME-WINDOW to show thumbs in the same window."
434 (interactive "DDir: ")
435 (thumbs-show-thumbs-list
436 (directory-files dir t
437 (or reg
(image-file-name-regexp)))
438 (concat "*Thumbs: " dir
) same-window
))
441 (defun thumbs-dired-show-marked ()
442 "In Dired, make a thumbs buffer with all marked files."
444 (thumbs-show-thumbs-list (dired-get-marked-files) nil t
))
447 (defun thumbs-dired-show-all ()
448 "In dired, make a thumbs buffer with all files in current directory."
450 (thumbs-show-all-from-dir default-directory nil t
))
453 (defalias 'thumbs
'thumbs-show-all-from-dir
)
455 (defun thumbs-find-image (img L
&optional num otherwin
)
457 (if otherwin
'switch-to-buffer-other-window
'switch-to-buffer
)
458 (concat "*Image: " (file-name-nondirectory img
) " - "
459 (number-to-string (or num
0)) "*"))
460 (thumbs-view-image-mode)
461 (let ((inhibit-read-only t
))
462 (setq thumbs-current-image-filename img
463 thumbs-current-tmp-filename nil
464 thumbs-image-num
(or num
0))
465 (make-variable-buffer-local 'thumbs-current-image-filename
)
466 (make-variable-buffer-local 'thumbs-current-tmp-filename
)
467 (make-variable-buffer-local 'thumbs-current-image-size
)
468 (make-variable-buffer-local 'thumbs-image-num
)
469 (make-variable-buffer-local 'thumbs-fileL
)
470 (setq thumbs-fileL L
)
471 (delete-region (point-min)(point-max))
472 (thumbs-insert-image img
(thumbs-image-type img
) 0)))
474 (defun thumbs-find-image-at-point (&optional img otherwin
)
475 "Display image IMG for thumbnail at point.
476 use another window it OTHERWIN is t."
478 (let* ((L thumbs-fileL
)
480 (i (or img
(cdr (assoc n L
)))))
481 (thumbs-find-image i L n otherwin
)))
483 (defun thumbs-find-image-at-point-other-window ()
484 "Display image for thumbnail at point in the preview buffer.
485 Open another window."
487 (thumbs-find-image-at-point nil t
))
489 (defun thumbs-call-setroot-command (img)
490 "Call the setroot program for IMG."
491 (run-hooks 'thumbs-before-setroot-hook
)
492 (shell-command (replace-regexp-in-string
494 (shell-quote-argument (expand-file-name img
))
495 thumbs-setroot-command nil t
))
496 (run-hooks 'thumbs-after-setroot-hook
))
498 (defun thumbs-set-image-at-point-to-root-window ()
499 "Set the image at point as the desktop wallpaper."
501 (thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL
))))
503 (defun thumbs-set-root ()
504 "Set the current image as root."
506 (thumbs-call-setroot-command
507 (or thumbs-current-tmp-filename
508 thumbs-current-image-filename
)))
510 (defun thumbs-delete-images ()
511 "Delete the image at point (and it's thumbnail) (or marked files if any)."
513 (let ((f (or thumbs-markedL
(list (cdr (assoc (point) thumbs-fileL
))))))
514 (if (yes-or-no-p "Really delete %d files?" (length f
))
517 (setq thumbs-fileL
(delete (rassoc x thumbs-fileL
) thumbs-fileL
))
519 (delete-file (thumbs-thumbname x
))) f
)
520 (thumbs-redraw-buffer)))))
522 (defun thumbs-kill-buffer ()
523 "Kill the current buffer."
525 (let ((buffer (current-buffer)))
526 (ignore-errors (delete-window (selected-window)))
527 (kill-buffer buffer
)))
529 (defun thumbs-show-image-num (num)
530 "Show the image with number NUM."
531 (let ((inhibit-read-only t
))
532 (delete-region (point-min)(point-max))
533 (let ((i (cdr (assoc num thumbs-fileL
))))
534 (thumbs-insert-image i
(thumbs-image-type i
) 0)
536 (rename-buffer (concat "*Image: "
537 (file-name-nondirectory i
)
539 (number-to-string num
) "*")))
540 (setq thumbs-image-num num
541 thumbs-current-image-filename i
)))
543 (defun thumbs-next-image ()
546 (let* ((i (1+ thumbs-image-num
))
547 (l (caar thumbs-fileL
))
549 (cond ((assoc i thumbs-fileL
) i
)
552 (thumbs-show-image-num num
)))
554 (defun thumbs-previous-image ()
555 "Show the previous image."
557 (let* ((i (- thumbs-image-num
1))
558 (l (caar thumbs-fileL
))
560 (cond ((assoc i thumbs-fileL
) i
)
563 (thumbs-show-image-num num
)))
565 (defun thumbs-redraw-buffer ()
566 "Redraw the current thumbs buffer."
568 (inhibit-read-only t
))
569 (delete-region (point-min)(point-max))
570 (thumbs-do-thumbs-insertion (reverse (mapcar 'cdr thumbs-fileL
)))
573 (defun thumbs-mark ()
574 "Mark the image at point."
576 (setq thumbs-markedL
(cons (cdr (assoc (point) thumbs-fileL
)) thumbs-markedL
))
577 (let ((inhibit-read-only t
))
579 (thumbs-insert-thumb (cdr (assoc (point) thumbs-fileL
)) t
))
580 (when (eolp)(forward-char)))
582 ;; Image modification routines
584 (defun thumbs-modify-image (action &optional arg
)
585 "Call convert to do ACTION on image with argument ARG.
586 ACTION and ARG should be legal convert command."
587 (interactive "sAction: \nsValue: ")
588 ;; cleaning of old temp file
594 (let ((buffer-read-only nil
)
595 (tmp (format "%s%s.jpg" thumbs-temp-file
(thumbs-gensym))))
597 (thumbs-call-convert thumbs-current-image-filename
601 (thumbs-insert-image tmp
'jpeg
0)
602 (setq thumbs-current-tmp-filename tmp
)))
604 (defun thumbs-emboss-image (emboss)
605 "Emboss the image with value EMBOSS."
606 (interactive "nEmboss value: ")
607 (if (or (< emboss
3)(> emboss
31)(evenp emboss
))
608 (error "Arg must be a odd number between 3 and 31"))
609 (thumbs-modify-image "emboss" (number-to-string emboss
)))
611 (defun thumbs-monochrome-image ()
612 "Turn the image to monochrome."
614 (thumbs-modify-image "monochrome"))
616 (defun thumbs-negate-image ()
619 (thumbs-modify-image "negate"))
621 (defun thumbs-rotate-left ()
622 "Rotate the image 90 degrees counter-clockwise."
624 (thumbs-modify-image "rotate" "270"))
626 (defun thumbs-rotate-right ()
627 "Rotate the image 90 degrees clockwise."
629 (thumbs-modify-image "rotate" "90"))
631 (defun thumbs-forward-char ()
632 "Move forward one image."
635 (when (eolp)(forward-char))
638 (defun thumbs-backward-char ()
639 "Move backward one image."
644 (defun thumbs-forward-line ()
645 "Move down one line."
650 (defun thumbs-backward-line ()
656 (defun thumbs-show-name ()
657 "Show the name of the current file."
659 (let ((f (cdr (assoc (point) thumbs-fileL
))))
660 (message "%s [%s]" f
(thumbs-file-size f
))))
662 (defun thumbs-save-current-image ()
663 "Save the current image."
665 (let ((f (or thumbs-current-tmp-filename
666 thumbs-current-image-filename
))
667 (sa (read-from-minibuffer "save file as: "
668 thumbs-current-image-filename
)))
671 (defun thumbs-dired ()
672 "Use `dired' on the current thumbs directory."
674 (dired thumbs-current-dir
))
678 (defvar thumbs-mode-map
679 (let ((map (make-sparse-keymap)))
680 (define-key map
[return] 'thumbs-find-image-at-point)
681 (define-key map [(meta return)] 'thumbs-find-image-at-point-other-window)
682 (define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window)
683 (define-key map [delete] 'thumbs-delete-images)
684 (define-key map [right] 'thumbs-forward-char)
685 (define-key map [left] 'thumbs-backward-char)
686 (define-key map [up] 'thumbs-backward-line)
687 (define-key map [down] 'thumbs-forward-line)
688 (define-key map "d" 'thumbs-dired)
689 (define-key map "m" 'thumbs-mark)
690 (define-key map "s" 'thumbs-show-name)
691 (define-key map "q" 'thumbs-kill-buffer)
693 "Keymap for `thumbs-mode'.")
695 (define-derived-mode thumbs-mode
696 fundamental-mode "thumbs"
697 "Preview images in a thumbnails buffer"
698 (make-variable-buffer-local 'thumbs-markedL)
699 (setq thumbs-markedL nil))
701 (defvar thumbs-view-image-mode-map
702 (let ((map (make-sparse-keymap)))
703 (define-key map [prior] 'thumbs-previous-image)
704 (define-key map [next] 'thumbs-next-image)
705 (define-key map "-" 'thumbs-resize-image-size-down)
706 (define-key map "+" 'thumbs-resize-image-size-up)
707 (define-key map "<" 'thumbs-rotate-left)
708 (define-key map ">" 'thumbs-rotate-right)
709 (define-key map "e" 'thumbs-emboss-image)
710 (define-key map "r" 'thumbs-resize-interactive)
711 (define-key map "s" 'thumbs-save-current-image)
712 (define-key map "q" 'thumbs-kill-buffer)
713 (define-key map "w" 'thunbs-set-root)
715 "Keymap for `thumbs-view-image-mode'.")
717 ;; thumbs-view-image-mode
718 (define-derived-mode thumbs-view-image-mode
719 fundamental-mode "image-view-mode")
722 (defun thumbs-dired-setroot ()
723 "In dired, Call the setroot program on the image at point."
725 (thumbs-call-setroot-command (dired-get-filename)))
727 ;; Modif to dired mode map
728 (define-key dired-mode-map "\C-ta" 'thumbs-dired-show-all)
729 (define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked)
730 (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot)
734 ;;; thumbs.el ends here
737 ;;; arch-tag: f9ac1ef8-83fc-42c0-8069-1fae43fd2e5c