1;;; thumbs.el --- Thumbnails previewer for images files
2
3;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
4
5;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca>
6;; Maintainer: FSF
7;; Keywords: Multimedia
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 2, or (at your option)
14;; 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; see the file COPYING.  If not, write to the
23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;; This package create two new modes: thumbs-mode and thumbs-view-image-mode.
29;; It is used for basic browsing and viewing of images from within Emacs.
30;; Minimal image manipulation functions are also available via external
31;; programs.  If you want to do more complex tasks like categorise and tag
32;; your images, use image-dired.el
33;;
34;; The 'convert' program from 'ImageMagick'
35;; [URL:http://www.imagemagick.org/] is required.
36;;
37;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some
38;;         time.  The peoples at #emacs@freenode.net for numerous help.  RMS
39;;         for emacs and the GNU project.
40;;
41;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42;;
43;; CHANGELOG
44;;
45;; This is version 2.0
46;;
47;; USAGE
48;;
49;; Type M-x thumbs RET DIR RET to view the directory DIR in Thumbs mode.
50;; That should be a directory containing image files.
51;; from dired, C-t m enter in thumbs-mode with all marked files
52;;             C-t a enter in thumbs-mode with all files in current-directory
53;; In thumbs-mode, pressing <return> on a image will bring you in image view
54;; mode for that image.  C-h m will give you a list of available keybinding.
55
56;;; History:
57;;
58
59;;; Code:
60
61(require 'dired)
62
63;; CUSTOMIZATIONS
64
65(defgroup thumbs nil
66  "Thumbnails previewer."
67  :version "22.1"
68  :group 'multimedia)
69
70(defcustom thumbs-thumbsdir "~/.emacs.d/thumbs"
71  "*Directory to store thumbnails."
72  :type 'directory
73  :group 'thumbs)
74
75(defcustom thumbs-geometry "100x100"
76  "*Size of thumbnails."
77  :type 'string
78  :group 'thumbs)
79
80(defcustom thumbs-per-line 4
81  "Number of thumbnails per line to show in directory."
82  :type 'integer
83  :group 'thumbs)
84
85(defcustom thumbs-max-image-number 16
86 "Maximum number of images initially displayed in thumbs buffer."
87  :type 'integer
88  :group 'thumbs)
89
90(defcustom thumbs-thumbsdir-max-size 50000000
91  "Maximum size for thumbnails directory.
92When it reaches that size (in bytes), a warning is sent."
93  :type 'integer
94  :group 'thumbs)
95
96(defcustom thumbs-conversion-program
97  (if (eq system-type 'windows-nt)
98      "convert.exe"
99    (or (executable-find "convert")
100	"/usr/X11R6/bin/convert"))
101  "*Name of conversion program for thumbnails generation.
102It must be 'convert'."
103  :type 'string
104  :group 'thumbs)
105
106(defcustom thumbs-setroot-command
107  "xloadimage -onroot -fullscreen *"
108  "Command to set the root window."
109  :type 'string
110  :group 'thumbs)
111
112(defcustom thumbs-relief 5
113  "*Size of button-like border around thumbnails."
114  :type 'integer
115  :group 'thumbs)
116
117(defcustom thumbs-margin 2
118  "*Size of the margin around thumbnails.
119This is where you see the cursor."
120  :type 'integer
121  :group 'thumbs)
122
123(defcustom thumbs-thumbsdir-auto-clean t
124  "If set, delete older file in the thumbnails directory.
125Deletion is done at load time when the directory size is bigger
126than `thumbs-thumbsdir-max-size'."
127  :type 'boolean
128  :group 'thumbs)
129
130(defcustom thumbs-image-resizing-step 10
131  "Step by which to resize image as a percentage."
132  :type 'integer
133  :group 'thumbs)
134
135(defcustom thumbs-temp-dir temporary-file-directory
136  "Temporary directory to use.
137Defaults to `temporary-file-directory'.  Leaving it to
138this value can let another user see some of your images."
139  :type 'directory
140  :group 'thumbs)
141
142(defcustom thumbs-temp-prefix "emacsthumbs"
143  "Prefix to add to temp files."
144  :type 'string
145  :group 'thumbs)
146
147;; Initialize some variable, for later use.
148(defvar thumbs-current-tmp-filename nil
149  "Temporary filename of current image.")
150(make-variable-buffer-local 'thumbs-current-tmp-filename)
151
152(defvar thumbs-current-image-filename nil
153  "Filename of current image.")
154(make-variable-buffer-local 'thumbs-current-image-filename)
155
156(defvar thumbs-extra-images 1
157  "Counter for showing extra images in thumbs buffer.")
158(make-variable-buffer-local 'thumbs-extra-images)
159(put 'thumbs-extra-images 'permanent-local t)
160
161(defvar thumbs-current-image-size nil
162  "Size of current image.")
163
164(defvar thumbs-image-num nil
165  "Number of current image.")
166(make-variable-buffer-local 'thumbs-image-num)
167
168(defvar thumbs-buffer nil
169  "Name of buffer containing thumbnails associated with image.")
170(make-variable-buffer-local 'thumbs-buffer)
171
172(defvar thumbs-current-dir nil
173  "Current directory.")
174
175(defvar thumbs-marked-list nil
176  "List of marked files.")
177(make-variable-buffer-local 'thumbs-marked-list)
178(put 'thumbs-marked-list 'permanent-local t)
179
180(defalias 'thumbs-gensym
181    (if (fboundp 'gensym)
182        'gensym
183      ;; Copied from cl-macs.el
184      (defvar thumbs-gensym-counter 0)
185      (lambda (&optional prefix)
186	"Generate a new uninterned symbol.
187The name is made by appending a number to PREFIX, default \"G\"."
188	(let ((pfix (if (stringp prefix) prefix "G"))
189	      (num (if (integerp prefix) prefix
190		     (prog1 thumbs-gensym-counter
191		       (setq thumbs-gensym-counter
192			     (1+ thumbs-gensym-counter))))))
193	  (make-symbol (format "%s%d" pfix num))))))
194
195(defsubst thumbs-temp-dir ()
196  (file-name-as-directory (expand-file-name thumbs-temp-dir)))
197
198(defun thumbs-temp-file ()
199  "Return a unique temporary filename for an image."
200  (format "%s%s-%s.jpg"
201          (thumbs-temp-dir)
202          thumbs-temp-prefix
203          (thumbs-gensym "T")))
204
205(defun thumbs-thumbsdir ()
206  "Return the current thumbnails directory (from `thumbs-thumbsdir').
207Create the thumbnails directory if it does not exist."
208  (let ((thumbs-thumbsdir (file-name-as-directory
209                           (expand-file-name thumbs-thumbsdir))))
210    (unless (file-directory-p thumbs-thumbsdir)
211      (make-directory thumbs-thumbsdir t)
212      (message "Creating thumbnails directory"))
213    thumbs-thumbsdir))
214
215(defun thumbs-cleanup-thumbsdir ()
216  "Clean the thumbnails directory.
217If the total size of all files in `thumbs-thumbsdir' is bigger than
218`thumbs-thumbsdir-max-size', files are deleted until the max size is
219reached."
220  (let* ((files-list
221	  (sort
222	   (mapcar
223	    (lambda (f)
224	      (let ((fattribs-list (file-attributes f)))
225		`(,(nth 4 fattribs-list) ,(nth 7 fattribs-list) ,f)))
226	    (directory-files (thumbs-thumbsdir) t (image-file-name-regexp)))
227	   '(lambda (l1 l2) (time-less-p (car l1) (car l2)))))
228	 (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files-list))))
229    (while (> dirsize thumbs-thumbsdir-max-size)
230      (progn
231	(message "Deleting file %s" (cadr (cdar files-list))))
232      (delete-file (cadr (cdar files-list)))
233      (setq dirsize (- dirsize (car (cdar files-list))))
234      (setq files-list (cdr files-list)))))
235
236;; Check the thumbsnail directory size and clean it if necessary.
237(when thumbs-thumbsdir-auto-clean
238  (thumbs-cleanup-thumbsdir))
239
240(defun thumbs-call-convert (filein fileout action
241				   &optional arg output-format action-prefix)
242  "Call the convert program.
243FILEIN is the input file,
244FILEOUT is the output file,
245ACTION is the command to send to convert.
246Optional arguments are:
247ARG any arguments to the ACTION command,
248OUTPUT-FORMAT is the file format to output (default is jpeg),
249ACTION-PREFIX is the symbol to place before the ACTION command
250              (defaults to '-' but can sometimes be '+')."
251  (let ((command (format "%s %s%s %s \"%s\" \"%s:%s\""
252			 thumbs-conversion-program
253			 (or action-prefix "-")
254			 action
255			 (or arg "")
256			 filein
257			 (or output-format "jpeg")
258			 fileout)))
259    (call-process shell-file-name nil nil nil shell-command-switch command)))
260
261(defun thumbs-new-image-size (s increment)
262  "New image (a cons of width x height)."
263  (let ((d (* increment thumbs-image-resizing-step)))
264    (cons
265     (round (+ (car s) (/ (* d (car s)) 100)))
266     (round (+ (cdr s) (/ (* d (cdr s)) 100))))))
267
268(defun thumbs-resize-image-1 (&optional increment size)
269  "Resize image in current buffer.
270If SIZE is specified use it.  Otherwise make the image larger or
271smaller according to whether INCREMENT is 1 or -1."
272  (let* ((buffer-read-only nil)
273	 (old thumbs-current-tmp-filename)
274	 (x (or size
275		(thumbs-new-image-size thumbs-current-image-size increment)))
276	 (tmp (thumbs-temp-file)))
277    (erase-buffer)
278    (thumbs-call-convert (or old thumbs-current-image-filename)
279			 tmp "sample"
280			 (concat (number-to-string (car x)) "x"
281				 (number-to-string (cdr x))))
282    (save-excursion
283      (thumbs-insert-image tmp 'jpeg 0))
284    (setq thumbs-current-tmp-filename tmp)))
285
286(defun thumbs-resize-image (width height)
287  "Resize image interactively to specified WIDTH and HEIGHT."
288  (interactive "nWidth: \nnHeight: ")
289  (thumbs-resize-image-1 nil (cons width height)))
290
291(defun thumbs-shrink-image ()
292  "Resize image (smaller)."
293  (interactive)
294  (thumbs-resize-image-1 -1))
295
296(defun thumbs-enlarge-image ()
297  "Resize image (bigger)."
298  (interactive)
299  (thumbs-resize-image-1 1))
300
301(defun thumbs-thumbname (img)
302  "Return a thumbnail name for the image IMG."
303  (convert-standard-filename
304   (let ((filename (expand-file-name img)))
305     (format "%s%08x-%s.jpg"
306             (thumbs-thumbsdir)
307             (sxhash filename)
308             (subst-char-in-string
309              ?\s ?\_
310              (apply
311               'concat
312               (split-string filename "/")))))))
313
314(defun thumbs-make-thumb (img)
315  "Create the thumbnail for IMG."
316  (let ((fn (expand-file-name img))
317        (tn (thumbs-thumbname img)))
318    (if (or (not (file-exists-p tn))
319	    ;;  This is not the right fix, but I don't understand
320	    ;;  the external program or why it produces a geometry
321	    ;;  unequal to the one requested -- rms.
322;;;	    (not (equal (thumbs-file-size tn) thumbs-geometry))
323	    )
324	(thumbs-call-convert fn tn "sample" thumbs-geometry))
325    tn))
326
327(defun thumbs-image-type (img)
328  "Return image type from filename IMG."
329  (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg)
330	((string-match ".*\\.xpm\\'" img) 'xpm)
331	((string-match ".*\\.xbm\\'" img) 'xbm)
332	((string-match ".*\\.pbm\\'" img) 'pbm)
333	((string-match ".*\\.gif\\'" img) 'gif)
334	((string-match ".*\\.bmp\\'" img) 'bmp)
335	((string-match ".*\\.png\\'" img) 'png)
336	((string-match ".*\\.tiff?\\'" img) 'tiff)))
337
338(defun thumbs-file-size (img)
339  (let ((i (image-size
340	    (find-image `((:type ,(thumbs-image-type img) :file ,img))) t)))
341    (concat (number-to-string (round (car i))) "x"
342	    (number-to-string (round (cdr i))))))
343
344;;;###autoload
345(defun thumbs-find-thumb (img)
346  "Display the thumbnail for IMG."
347  (interactive "f")
348  (find-file (thumbs-make-thumb img)))
349
350(defun thumbs-insert-image (img type relief &optional marked)
351  "Insert image IMG at point.
352TYPE and RELIEF will be used in constructing the image; see `image'
353in the emacs-lisp manual for further documentation.
354If MARKED is non-nil, the image is marked."
355  (let ((i `(image :type ,type
356		   :file ,img
357		   :relief ,relief
358		   :conversion ,(if marked 'disabled)
359		   :margin ,thumbs-margin)))
360    (insert-image i)
361    (set (make-local-variable 'thumbs-current-image-size)
362         (image-size i t))))
363
364(defun thumbs-insert-thumb (img &optional marked)
365  "Insert the thumbnail for IMG at point.
366If MARKED is non-nil, the image is marked."
367  (thumbs-insert-image
368   (thumbs-make-thumb img) 'jpeg thumbs-relief marked)
369  (add-text-properties (1- (point)) (point)
370		     `(thumb-image-file ,img
371		       help-echo ,(file-name-nondirectory img)
372		       rear-nonsticky help-echo)))
373
374(defun thumbs-do-thumbs-insertion (list)
375  "Insert all thumbnails into thumbs buffer."
376  (let* ((i 0)
377	(length (length list))
378	(diff (- length (* thumbs-max-image-number thumbs-extra-images))))
379    (nbutlast list diff)
380    (dolist (img list)
381      (thumbs-insert-thumb img
382			   (member img thumbs-marked-list))
383      (when (= 0 (mod (setq i (1+ i)) thumbs-per-line))
384	(newline)))
385    (unless (bobp) (newline))
386    (if (> diff 0) (message "Type + to display more images."))))
387
388(defun thumbs-show-thumbs-list (list &optional dir same-window)
389  (unless (and (display-images-p)
390               (image-type-available-p 'jpeg))
391    (error "Required image type is not supported in this Emacs session"))
392  (funcall (if same-window 'switch-to-buffer 'pop-to-buffer)
393	   (if dir (concat "*Thumbs: " dir) "*THUMB-View*"))
394  (let ((inhibit-read-only t))
395    (erase-buffer)
396    (thumbs-mode)
397    (setq thumbs-buffer (current-buffer))
398    (if dir (setq default-directory dir))
399    (thumbs-do-thumbs-insertion list)
400    (goto-char (point-min))
401    (set (make-local-variable 'thumbs-current-dir) default-directory)))
402
403;;;###autoload
404(defun thumbs-show-from-dir (dir &optional reg same-window)
405  "Make a preview buffer for all images in DIR.
406Optional argument REG to select file matching a regexp,
407and SAME-WINDOW to show thumbs in the same window."
408  (interactive "DDir: ")
409  (thumbs-show-thumbs-list
410   (directory-files dir t (or reg (image-file-name-regexp)))
411   dir same-window))
412
413;;;###autoload
414(defun thumbs-dired-show-marked ()
415  "In dired, make a thumbs buffer with marked files."
416  (interactive)
417  (thumbs-show-thumbs-list (dired-get-marked-files) nil t))
418
419;;;###autoload
420(defun thumbs-dired-show ()
421  "In dired, make a thumbs buffer with all files in current directory."
422  (interactive)
423  (thumbs-show-from-dir default-directory nil t))
424
425;;;###autoload
426(defalias 'thumbs 'thumbs-show-from-dir)
427
428(defun thumbs-find-image (img &optional num otherwin)
429  (let ((buffer (current-buffer)))
430    (funcall
431     (if otherwin 'switch-to-buffer-other-window 'switch-to-buffer)
432     "*Image*")
433    (thumbs-view-image-mode)
434    (setq mode-name
435	  (concat "image-view-mode: " (file-name-nondirectory img)
436		  " - " (number-to-string num)))
437    (setq thumbs-buffer buffer)
438    (let ((inhibit-read-only t))
439      (setq thumbs-current-image-filename img
440	    thumbs-current-tmp-filename nil
441	    thumbs-image-num (or num 0))
442      (delete-region (point-min)(point-max))
443      (save-excursion
444	(thumbs-insert-image img (thumbs-image-type img) 0)))))
445
446(defun thumbs-find-image-at-point (&optional img otherwin)
447  "Display image IMG for thumbnail at point.
448Use another window if OTHERWIN is t."
449  (interactive)
450  (let* ((i (or img (thumbs-current-image))))
451    (thumbs-find-image i (point) otherwin)))
452
453(defun thumbs-find-image-at-point-other-window ()
454  "Display image for thumbnail at point in the preview buffer.
455Open another window."
456  (interactive)
457  (thumbs-find-image-at-point nil t))
458
459(defun thumbs-mouse-find-image (event)
460  "Display image for thumbnail at mouse click EVENT."
461  (interactive "e")
462  (mouse-set-point event)
463  (thumbs-find-image-at-point))
464
465(defun thumbs-call-setroot-command (img)
466  "Call the setroot program for IMG."
467  (run-hooks 'thumbs-before-setroot-hook)
468  (shell-command (replace-regexp-in-string
469		  "\\*"
470		  (shell-quote-argument (expand-file-name img))
471		  thumbs-setroot-command nil t))
472  (run-hooks 'thumbs-after-setroot-hook))
473
474(defun thumbs-set-image-at-point-to-root-window ()
475  "Set the image at point as the desktop wallpaper."
476  (interactive)
477  (thumbs-call-setroot-command
478   (thumbs-current-image)))
479
480(defun thumbs-set-root ()
481  "Set the current image as root."
482  (interactive)
483  (thumbs-call-setroot-command
484   (or thumbs-current-tmp-filename
485       thumbs-current-image-filename)))
486
487(defun thumbs-file-alist ()
488  "Make an alist of elements (POS . FILENAME) for all images in thumb buffer."
489  (with-current-buffer thumbs-buffer
490    (save-excursion
491      (let (list)
492	(goto-char (point-min))
493	(while (not (eobp))
494	  (unless (eolp)
495	    (if (thumbs-current-image)
496		(push (cons (point-marker)
497			    (thumbs-current-image))
498		    list)))
499	  (forward-char 1))
500	(nreverse list)))))
501
502(defun thumbs-file-list ()
503  "Make a list of file names for all images in thumb buffer."
504  (save-excursion
505    (let (list)
506      (goto-char (point-min))
507      (while (not (eobp))
508	(if (thumbs-current-image)
509	    (push (thumbs-current-image) list))
510	(forward-char 1))
511      (nreverse list))))
512
513(defun thumbs-delete-images ()
514  "Delete the image at point (and its thumbnail) (or marked files if any)."
515  (interactive)
516  (let ((files (or thumbs-marked-list (list (thumbs-current-image)))))
517    (if (yes-or-no-p (format "Really delete %d files? " (length files)))
518	(let ((thumbs-file-list (thumbs-file-alist))
519	      (inhibit-read-only t))
520	  (dolist (x files)
521	    (let (failure)
522	      (condition-case ()
523		  (progn
524		    (delete-file x)
525		    (delete-file (thumbs-thumbname x)))
526		(file-error (setq failure t)))
527	      (unless failure
528		(when (rassoc x thumbs-file-list)
529		  (goto-char (car (rassoc x thumbs-file-list)))
530		  (delete-region (point) (1+ (point))))
531		(setq thumbs-marked-list
532		      (delq x thumbs-marked-list)))))))))
533
534(defun thumbs-rename-images (newfile)
535  "Rename the image at point (and its thumbnail) (or marked files if any)."
536  (interactive "FRename to file or directory: ")
537  (let ((files (or thumbs-marked-list (list (thumbs-current-image))))
538	failures)
539    (if (and (not (file-directory-p newfile))
540	     thumbs-marked-list)
541	(if (file-exists-p newfile)
542	    (error "Renaming marked files to file name `%s'" newfile)
543	  (make-directory newfile t)))
544    (if (yes-or-no-p (format "Really rename %d files? " (length files)))
545	(let ((thumbs-file-list (thumbs-file-alist))
546	      (inhibit-read-only t))
547	  (dolist (file files)
548	    (let (failure)
549	      (condition-case ()
550		  (if (file-directory-p newfile)
551		      (rename-file file
552				   (expand-file-name
553				    (file-name-nondirectory file)
554				    newfile))
555		    (rename-file file newfile))
556		(file-error (setq failure t)
557			    (push file failures)))
558	      (unless failure
559		(when (rassoc file thumbs-file-list)
560		  (goto-char (car (rassoc file thumbs-file-list)))
561		  (delete-region (point) (1+ (point))))
562		(setq thumbs-marked-list
563		      (delq file thumbs-marked-list)))))))
564    (if failures
565	(display-warning 'file-error
566			 (format "Rename failures for %s into %s"
567				 failures newfile)
568			 :error))))
569
570(defun thumbs-kill-buffer ()
571  "Kill the current buffer."
572  (interactive)
573  (quit-window t (selected-window)))
574
575(defun thumbs-show-image-num (num)
576  "Show the image with number NUM."
577  (let ((image-buffer (get-buffer-create "*Image*")))
578    (let ((img (cdr (nth (1- num) (thumbs-file-alist)))))
579      (with-current-buffer image-buffer
580	(setq mode-name
581	      (concat "image-view-mode: " (file-name-nondirectory img)
582		      " - " (number-to-string num)))
583	(let ((inhibit-read-only t))
584	  (erase-buffer)
585	  (thumbs-insert-image img (thumbs-image-type img) 0)
586	  (goto-char (point-min))))
587      (setq thumbs-image-num num
588	    thumbs-current-image-filename img))))
589
590(defun thumbs-previous-image ()
591  "Show the previous image."
592  (interactive)
593  (let* ((i (- thumbs-image-num 1))
594	 (number (length (thumbs-file-alist))))
595    (if (= i 0) (setq i (1- number)))
596    (thumbs-show-image-num i)))
597
598(defun thumbs-next-image ()
599  "Show the next image."
600  (interactive)
601  (let* ((i (1+ thumbs-image-num))
602	 (number (length (thumbs-file-alist))))
603    (if (= i number) (setq i 1))
604    (thumbs-show-image-num i)))
605
606(defun thumbs-display-thumbs-buffer ()
607  "Display the associated thumbs buffer."
608  (interactive)
609  (display-buffer thumbs-buffer))
610
611(defun thumbs-redraw-buffer ()
612  "Redraw the current thumbs buffer."
613  (let ((p (point))
614	(inhibit-read-only t)
615	(files (thumbs-file-list)))
616    (erase-buffer)
617    (thumbs-do-thumbs-insertion files)
618    (goto-char p)))
619
620(defun thumbs-mark ()
621  "Mark the image at point."
622  (interactive)
623  (let ((elt (thumbs-current-image)))
624    (unless elt
625      (error "No image here"))
626    (push elt thumbs-marked-list)
627    (let ((inhibit-read-only t))
628      (delete-char 1)
629      (thumbs-insert-thumb elt t)))
630  (when (eolp) (forward-char)))
631
632(defun thumbs-unmark ()
633  "Unmark the image at point."
634  (interactive)
635  (let ((elt (thumbs-current-image)))
636    (unless elt
637      (error "No image here"))
638    (setq thumbs-marked-list (delete elt thumbs-marked-list))
639    (let ((inhibit-read-only t))
640      (delete-char 1)
641      (thumbs-insert-thumb elt nil)))
642  (when (eolp) (forward-char)))
643
644;; cleaning of old temp files
645(mapc 'delete-file
646      (directory-files (thumbs-temp-dir) t thumbs-temp-prefix))
647
648;; Image modification routines
649
650(defun thumbs-modify-image (action &optional arg)
651  "Call convert to do ACTION on image with argument ARG.
652ACTION and ARG should be a valid convert command."
653  (interactive "sAction: \nsValue: ")
654  (let* ((buffer-read-only nil)
655	 (old thumbs-current-tmp-filename)
656	 (tmp (thumbs-temp-file)))
657    (erase-buffer)
658    (thumbs-call-convert (or old thumbs-current-image-filename)
659			 tmp
660			 action
661			 (or arg ""))
662    (save-excursion
663      (thumbs-insert-image tmp 'jpeg 0))
664    (setq thumbs-current-tmp-filename tmp)))
665
666(defun thumbs-emboss-image (emboss)
667  "Emboss the image with value EMBOSS."
668  (interactive "nEmboss value: ")
669  (if (or (< emboss 3) (> emboss 31) (zerop (% emboss 2)))
670      (error "Arg must be an odd number between 3 and 31"))
671  (thumbs-modify-image "emboss" (number-to-string emboss)))
672
673(defun thumbs-monochrome-image ()
674  "Turn the image to monochrome."
675  (interactive)
676  (thumbs-modify-image "monochrome"))
677
678(defun thumbs-negate-image ()
679  "Negate the image."
680  (interactive)
681  (thumbs-modify-image "negate"))
682
683(defun thumbs-rotate-left ()
684  "Rotate the image 90 degrees counter-clockwise."
685  (interactive)
686  (thumbs-modify-image "rotate" "270"))
687
688(defun thumbs-rotate-right ()
689  "Rotate the image 90 degrees clockwise."
690  (interactive)
691  (thumbs-modify-image "rotate" "90"))
692
693(defun thumbs-current-image ()
694  "Return the name of the image file name at point."
695  (get-text-property (point) 'thumb-image-file))
696
697(defun thumbs-forward-char ()
698  "Move forward one image."
699  (interactive)
700  (forward-char)
701  (while (and (not (eobp)) (not (thumbs-current-image)))
702    (forward-char))
703  (thumbs-show-name))
704
705(defun thumbs-backward-char ()
706  "Move backward one image."
707  (interactive)
708  (forward-char -1)
709  (while (and (not (bobp)) (not (thumbs-current-image)))
710    (forward-char -1))
711  (thumbs-show-name))
712
713(defun thumbs-backward-line ()
714  "Move up one line."
715  (interactive)
716  (forward-line -1)
717  (thumbs-show-name))
718
719(defun thumbs-forward-line ()
720  "Move down one line."
721  (interactive)
722  (forward-line 1)
723  (thumbs-show-name))
724
725(defun thumbs-show-more-images (&optional arg)
726  "Show more than `thumbs-max-image-number' images, if present."
727  (interactive "P")
728  (or arg (setq arg 1))
729  (setq thumbs-extra-images (+ thumbs-extra-images arg))
730  (thumbs-dired-show))
731
732(defun thumbs-show-name ()
733  "Show the name of the current file."
734  (interactive)
735  (let ((f (thumbs-current-image)))
736    (and f (message "%s [%s]" f (thumbs-file-size f)))))
737
738(defun thumbs-save-current-image ()
739  "Save the current image."
740  (interactive)
741  (let ((f (or thumbs-current-tmp-filename
742	       thumbs-current-image-filename))
743	(sa (read-from-minibuffer "Save image file as: "
744				  thumbs-current-image-filename)))
745    (copy-file f sa)))
746
747(defun thumbs-dired ()
748  "Use `dired' on the current thumbs directory."
749  (interactive)
750  (dired thumbs-current-dir))
751
752;; thumbs-mode
753
754(defvar thumbs-mode-map
755  (let ((map (make-sparse-keymap)))
756    (define-key map [return] 'thumbs-find-image-at-point)
757    (define-key map [mouse-2] 'thumbs-mouse-find-image)
758    (define-key map [(meta return)] 'thumbs-find-image-at-point-other-window)
759    (define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window)
760    (define-key map [delete] 'thumbs-delete-images)
761    (define-key map [right] 'thumbs-forward-char)
762    (define-key map [left] 'thumbs-backward-char)
763    (define-key map [up] 'thumbs-backward-line)
764    (define-key map [down] 'thumbs-forward-line)
765    (define-key map "+" 'thumbs-show-more-images)
766    (define-key map "d" 'thumbs-dired)
767    (define-key map "m" 'thumbs-mark)
768    (define-key map "u" 'thumbs-unmark)
769    (define-key map "R" 'thumbs-rename-images)
770    (define-key map "x" 'thumbs-delete-images)
771    (define-key map "s" 'thumbs-show-name)
772    (define-key map "q" 'thumbs-kill-buffer)
773    map)
774  "Keymap for `thumbs-mode'.")
775
776(put 'thumbs-mode 'mode-class 'special)
777(define-derived-mode thumbs-mode
778  fundamental-mode "thumbs"
779  "Preview images in a thumbnails buffer"
780  (setq buffer-read-only t))
781
782(defvar thumbs-view-image-mode-map
783  (let ((map (make-sparse-keymap)))
784    (define-key map [prior] 'thumbs-previous-image)
785    (define-key map [next] 'thumbs-next-image)
786    (define-key map "^" 'thumbs-display-thumbs-buffer)
787    (define-key map "-" 'thumbs-shrink-image)
788    (define-key map "+" 'thumbs-enlarge-image)
789    (define-key map "<" 'thumbs-rotate-left)
790    (define-key map ">" 'thumbs-rotate-right)
791    (define-key map "e" 'thumbs-emboss-image)
792    (define-key map "r" 'thumbs-resize-image)
793    (define-key map "s" 'thumbs-save-current-image)
794    (define-key map "q" 'thumbs-kill-buffer)
795    (define-key map "w" 'thumbs-set-root)
796    map)
797  "Keymap for `thumbs-view-image-mode'.")
798
799;; thumbs-view-image-mode
800(put 'thumbs-view-image-mode 'mode-class 'special)
801(define-derived-mode thumbs-view-image-mode
802  fundamental-mode "image-view-mode"
803  (setq buffer-read-only t))
804
805;;;###autoload
806(defun thumbs-dired-setroot ()
807  "In dired, call the setroot program on the image at point."
808  (interactive)
809  (thumbs-call-setroot-command (dired-get-filename)))
810
811;; Modif to dired mode map
812(define-key dired-mode-map "\C-ta" 'thumbs-dired-show)
813(define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked)
814(define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot)
815
816(provide 'thumbs)
817
818;; arch-tag: f9ac1ef8-83fc-42c0-8069-1fae43fd2e5c
819;;; thumbs.el ends here
820