Source

emacs / lisp / thumbs.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
;;; thumbs.el --- Thumbnails previewer for images files

;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.

;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca>
;; Maintainer: FSF
;; Keywords: Multimedia

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; This package create two new modes: thumbs-mode and thumbs-view-image-mode.
;; It is used for basic browsing and viewing of images from within Emacs.
;; Minimal image manipulation functions are also available via external
;; programs.  If you want to do more complex tasks like categorise and tag
;; your images, use tumme.el
;;
;; The 'convert' program from 'ImageMagick'
;; [URL:http://www.imagemagick.org/] is required.
;;
;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some
;;         time.  The peoples at #emacs@freenode.net for numerous help.  RMS
;;         for emacs and the GNU project.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; CHANGELOG
;;
;; This is version 2.0
;;
;; USAGE
;;
;; Type M-x thumbs RET DIR RET to view the directory DIR in Thumbs mode.
;; That should be a directory containing image files.
;; from dired, C-t m enter in thumbs-mode with all marked files
;;             C-t a enter in thumbs-mode with all files in current-directory
;; In thumbs-mode, pressing <return> on a image will bring you in image view
;; mode for that image.  C-h m will give you a list of available keybinding.

;;; History:
;;

;;; Code:

(require 'dired)

;; CUSTOMIZATIONS

(defgroup thumbs nil
  "Thumbnails previewer."
  :version "22.1"
  :group 'multimedia)

(defcustom thumbs-thumbsdir "~/.emacs.d/thumbs"
  "*Directory to store thumbnails."
  :type 'directory
  :group 'thumbs)

(defcustom thumbs-geometry "100x100"
  "*Size of thumbnails."
  :type 'string
  :group 'thumbs)

(defcustom thumbs-per-line 4
  "Number of thumbnails per line to show in directory."
  :type 'integer
  :group 'thumbs)

(defcustom thumbs-max-image-number 16
 "Maximum number of images initially displayed in thumbs buffer."
  :type 'integer
  :group 'thumbs)

(defcustom thumbs-thumbsdir-max-size 50000000
  "Maximum size for thumbnails directory.
When it reaches that size (in bytes), a warning is sent."
  :type 'integer
  :group 'thumbs)

(defcustom thumbs-conversion-program
  (if (eq system-type 'windows-nt)
      "convert.exe"
    (or (executable-find "convert")
	"/usr/X11R6/bin/convert"))
  "*Name of conversion program for thumbnails generation.
It must be 'convert'."
  :type 'string
  :group 'thumbs)

(defcustom thumbs-setroot-command
  "xloadimage -onroot -fullscreen *"
  "Command to set the root window."
  :type 'string
  :group 'thumbs)

(defcustom thumbs-relief 5
  "*Size of button-like border around thumbnails."
  :type 'integer
  :group 'thumbs)

(defcustom thumbs-margin 2
  "*Size of the margin around thumbnails.
This is where you see the cursor."
  :type 'integer
  :group 'thumbs)

(defcustom thumbs-thumbsdir-auto-clean t
  "If set, delete older file in the thumbnails directory.
Deletion is done at load time when the directory size is bigger
than `thumbs-thumbsdir-max-size'."
  :type 'boolean
  :group 'thumbs)

(defcustom thumbs-image-resizing-step 10
  "Step by which to resize image as a percentage."
  :type 'integer
  :group 'thumbs)

(defcustom thumbs-temp-dir temporary-file-directory
  "Temporary directory to use.
Defaults to `temporary-file-directory'.  Leaving it to
this value can let another user see some of your images."
  :type 'directory
  :group 'thumbs)

(defcustom thumbs-temp-prefix "emacsthumbs"
  "Prefix to add to temp files."
  :type 'string
  :group 'thumbs)

;; Initialize some variable, for later use.
(defvar thumbs-current-tmp-filename nil
  "Temporary filename of current image.")
(make-variable-buffer-local 'thumbs-current-tmp-filename)

(defvar thumbs-current-image-filename nil
  "Filename of current image.")
(make-variable-buffer-local 'thumbs-current-image-filename)

(defvar thumbs-extra-images 1
  "Counter for showing extra images in thumbs buffer.")
(make-variable-buffer-local 'thumbs-extra-images)
(put 'thumbs-extra-images 'permanent-local t)

(defvar thumbs-current-image-size nil
  "Size of current image.")

(defvar thumbs-image-num nil
  "Number of current image.")
(make-variable-buffer-local 'thumbs-image-num)

(defvar thumbs-buffer nil
  "Name of buffer containing thumbnails associated with image.")
(make-variable-buffer-local 'thumbs-buffer)

(defvar thumbs-current-dir nil
  "Current directory.")

(defvar thumbs-marked-list nil
  "List of marked files.")
(make-variable-buffer-local 'thumbs-marked-list)
(put 'thumbs-marked-list 'permanent-local t)

(defalias 'thumbs-gensym
    (if (fboundp 'gensym)
        'gensym
      ;; Copied from cl-macs.el
      (defvar thumbs-gensym-counter 0)
      (lambda (&optional prefix)
	"Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"G\"."
	(let ((pfix (if (stringp prefix) prefix "G"))
	      (num (if (integerp prefix) prefix
		     (prog1 thumbs-gensym-counter
		       (setq thumbs-gensym-counter
			     (1+ thumbs-gensym-counter))))))
	  (make-symbol (format "%s%d" pfix num))))))

(defsubst thumbs-temp-dir ()
  (file-name-as-directory (expand-file-name thumbs-temp-dir)))

(defun thumbs-temp-file ()
  "Return a unique temporary filename for an image."
  (format "%s%s-%s.jpg"
          (thumbs-temp-dir)
          thumbs-temp-prefix
          (thumbs-gensym "T")))

(defun thumbs-thumbsdir ()
  "Return the current thumbnails directory (from `thumbs-thumbsdir').
Create the thumbnails directory if it does not exist."
  (let ((thumbs-thumbsdir (file-name-as-directory
                           (expand-file-name thumbs-thumbsdir))))
    (unless (file-directory-p thumbs-thumbsdir)
      (make-directory thumbs-thumbsdir t)
      (message "Creating thumbnails directory"))
    thumbs-thumbsdir))

(defun thumbs-cleanup-thumbsdir ()
  "Clean the thumbnails directory.
If the total size of all files in `thumbs-thumbsdir' is bigger than
`thumbs-thumbsdir-max-size', files are deleted until the max size is
reached."
  (let* ((files-list
	  (sort
	   (mapcar
	    (lambda (f)
	      (let ((fattribs-list (file-attributes f)))
		`(,(nth 4 fattribs-list) ,(nth 7 fattribs-list) ,f)))
	    (directory-files (thumbs-thumbsdir) t (image-file-name-regexp)))
	   '(lambda (l1 l2) (time-less-p (car l1) (car l2)))))
	 (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) files-list))))
    (while (> dirsize thumbs-thumbsdir-max-size)
      (progn
	(message "Deleting file %s" (cadr (cdar files-list))))
      (delete-file (cadr (cdar files-list)))
      (setq dirsize (- dirsize (car (cdar files-list))))
      (setq files-list (cdr files-list)))))

;; Check the thumbsnail directory size and clean it if necessary.
(when thumbs-thumbsdir-auto-clean
  (thumbs-cleanup-thumbsdir))

(defun thumbs-call-convert (filein fileout action
				   &optional arg output-format action-prefix)
  "Call the convert program.
FILEIN is the input file,
FILEOUT is the output file,
ACTION is the command to send to convert.
Optional arguments are:
ARG any arguments to the ACTION command,
OUTPUT-FORMAT is the file format to output (default is jpeg),
ACTION-PREFIX is the symbol to place before the ACTION command
              (defaults to '-' but can sometimes be '+')."
  (let ((command (format "%s %s%s %s \"%s\" \"%s:%s\""
			 thumbs-conversion-program
			 (or action-prefix "-")
			 action
			 (or arg "")
			 filein
			 (or output-format "jpeg")
			 fileout)))
    (call-process shell-file-name nil nil nil shell-command-switch command)))

(defun thumbs-new-image-size (s increment)
  "New image (a cons of width x height)."
  (let ((d (* increment thumbs-image-resizing-step)))
    (cons
     (round (+ (car s) (/ (* d (car s)) 100)))
     (round (+ (cdr s) (/ (* d (cdr s)) 100))))))

(defun thumbs-resize-image-1 (&optional increment size)
  "Resize image in current buffer.
If SIZE is specified use it.  Otherwise make the image larger or
smaller according to whether INCREMENT is 1 or -1."
  (let* ((buffer-read-only nil)
	 (old thumbs-current-tmp-filename)
	 (x (or size
		(thumbs-new-image-size thumbs-current-image-size increment)))
	 (tmp (thumbs-temp-file)))
    (erase-buffer)
    (thumbs-call-convert (or old thumbs-current-image-filename)
			 tmp "sample"
			 (concat (number-to-string (car x)) "x"
				 (number-to-string (cdr x))))
    (save-excursion
      (thumbs-insert-image tmp 'jpeg 0))
    (setq thumbs-current-tmp-filename tmp)))

(defun thumbs-resize-image (width height)
  "Resize image interactively to specified WIDTH and HEIGHT."
  (interactive "nWidth: \nnHeight: ")
  (thumbs-resize-image-1 nil (cons width height)))

(defun thumbs-shrink-image ()
  "Resize image (smaller)."
  (interactive)
  (thumbs-resize-image-1 -1))

(defun thumbs-enlarge-image ()
  "Resize image (bigger)."
  (interactive)
  (thumbs-resize-image-1 1))

(defun thumbs-thumbname (img)
  "Return a thumbnail name for the image IMG."
  (convert-standard-filename
   (let ((filename (expand-file-name img)))
     (format "%s%08x-%s.jpg"
             (thumbs-thumbsdir)
             (sxhash filename)
             (subst-char-in-string
              ?\s ?\_
              (apply
               'concat
               (split-string filename "/")))))))

(defun thumbs-make-thumb (img)
  "Create the thumbnail for IMG."
  (let ((fn (expand-file-name img))
        (tn (thumbs-thumbname img)))
    (if (or (not (file-exists-p tn))
	    ;;  This is not the right fix, but I don't understand
	    ;;  the external program or why it produces a geometry
	    ;;  unequal to the one requested -- rms.
;;;	    (not (equal (thumbs-file-size tn) thumbs-geometry))
	    )
	(thumbs-call-convert fn tn "sample" thumbs-geometry))
    tn))

(defun thumbs-image-type (img)
  "Return image type from filename IMG."
  (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg)
	((string-match ".*\\.xpm\\'" img) 'xpm)
	((string-match ".*\\.xbm\\'" img) 'xbm)
	((string-match ".*\\.pbm\\'" img) 'pbm)
	((string-match ".*\\.gif\\'" img) 'gif)
	((string-match ".*\\.bmp\\'" img) 'bmp)
	((string-match ".*\\.png\\'" img) 'png)
	((string-match ".*\\.tiff?\\'" img) 'tiff)))

(defun thumbs-file-size (img)
  (let ((i (image-size
	    (find-image `((:type ,(thumbs-image-type img) :file ,img))) t)))
    (concat (number-to-string (round (car i))) "x"
	    (number-to-string (round (cdr i))))))

;;;###autoload
(defun thumbs-find-thumb (img)
  "Display the thumbnail for IMG."
  (interactive "f")
  (find-file (thumbs-make-thumb img)))

(defun thumbs-insert-image (img type relief &optional marked)
  "Insert image IMG at point.
TYPE and RELIEF will be used in constructing the image; see `image'
in the emacs-lisp manual for further documentation.
If MARKED is non-nil, the image is marked."
  (let ((i `(image :type ,type
		   :file ,img
		   :relief ,relief
		   :conversion ,(if marked 'disabled)
		   :margin ,thumbs-margin)))
    (insert-image i)
    (set (make-local-variable 'thumbs-current-image-size)
         (image-size i t))))

(defun thumbs-insert-thumb (img &optional marked)
  "Insert the thumbnail for IMG at point.
If MARKED is non-nil, the image is marked."
  (thumbs-insert-image
   (thumbs-make-thumb img) 'jpeg thumbs-relief marked)
  (add-text-properties (1- (point)) (point)
		     `(thumb-image-file ,img
		       help-echo ,(file-name-nondirectory img)
		       rear-nonsticky help-echo)))

(defun thumbs-do-thumbs-insertion (list)
  "Insert all thumbnails into thumbs buffer."
  (let* ((i 0)
	(length (length list))
	(diff (- length (* thumbs-max-image-number thumbs-extra-images))))
    (nbutlast list diff)
    (dolist (img list)
      (thumbs-insert-thumb img
			   (member img thumbs-marked-list))
      (when (= 0 (mod (setq i (1+ i)) thumbs-per-line))
	(newline)))
    (unless (bobp) (newline))
    (if (> diff 0) (message "Type + to display more images."))))

(defun thumbs-show-thumbs-list (list &optional dir same-window)
  (unless (and (display-images-p)
               (image-type-available-p 'jpeg))
    (error "Required image type is not supported in this Emacs session"))
  (funcall (if same-window 'switch-to-buffer 'pop-to-buffer)
	   (if dir (concat "*Thumbs: " dir) "*THUMB-View*"))
  (let ((inhibit-read-only t))
    (erase-buffer)
    (thumbs-mode)
    (setq thumbs-buffer (current-buffer))
    (if dir (setq default-directory dir))
    (thumbs-do-thumbs-insertion list)
    (goto-char (point-min))
    (set (make-local-variable 'thumbs-current-dir) default-directory)))

;;;###autoload
(defun thumbs-show-from-dir (dir &optional reg same-window)
  "Make a preview buffer for all images in DIR.
Optional argument REG to select file matching a regexp,
and SAME-WINDOW to show thumbs in the same window."
  (interactive "DDir: ")
  (thumbs-show-thumbs-list
   (directory-files dir t (or reg (image-file-name-regexp)))
   dir same-window))

;;;###autoload
(defun thumbs-dired-show-marked ()
  "In dired, make a thumbs buffer with marked files."
  (interactive)
  (thumbs-show-thumbs-list (dired-get-marked-files) nil t))

;;;###autoload
(defun thumbs-dired-show ()
  "In dired, make a thumbs buffer with all files in current directory."
  (interactive)
  (thumbs-show-from-dir default-directory nil t))

;;;###autoload
(defalias 'thumbs 'thumbs-show-from-dir)

(defun thumbs-find-image (img &optional num otherwin)
  (let ((buffer (current-buffer)))
    (funcall
     (if otherwin 'switch-to-buffer-other-window 'switch-to-buffer)
     "*Image*")
    (thumbs-view-image-mode)
    (setq mode-name
	  (concat "image-view-mode: " (file-name-nondirectory img)
		  " - " (number-to-string num)))
    (setq thumbs-buffer buffer)
    (let ((inhibit-read-only t))
      (setq thumbs-current-image-filename img
	    thumbs-current-tmp-filename nil
	    thumbs-image-num (or num 0))
      (delete-region (point-min)(point-max))
      (save-excursion
	(thumbs-insert-image img (thumbs-image-type img) 0)))))

(defun thumbs-find-image-at-point (&optional img otherwin)
  "Display image IMG for thumbnail at point.
Use another window if OTHERWIN is t."
  (interactive)
  (let* ((i (or img (thumbs-current-image))))
    (thumbs-find-image i (point) otherwin)))

(defun thumbs-find-image-at-point-other-window ()
  "Display image for thumbnail at point in the preview buffer.
Open another window."
  (interactive)
  (thumbs-find-image-at-point nil t))

(defun thumbs-mouse-find-image (event)
  "Display image for thumbnail at mouse click EVENT."
  (interactive "e")
  (mouse-set-point event)
  (thumbs-find-image-at-point))

(defun thumbs-call-setroot-command (img)
  "Call the setroot program for IMG."
  (run-hooks 'thumbs-before-setroot-hook)
  (shell-command (replace-regexp-in-string
		  "\\*"
		  (shell-quote-argument (expand-file-name img))
		  thumbs-setroot-command nil t))
  (run-hooks 'thumbs-after-setroot-hook))

(defun thumbs-set-image-at-point-to-root-window ()
  "Set the image at point as the desktop wallpaper."
  (interactive)
  (thumbs-call-setroot-command
   (thumbs-current-image)))

(defun thumbs-set-root ()
  "Set the current image as root."
  (interactive)
  (thumbs-call-setroot-command
   (or thumbs-current-tmp-filename
       thumbs-current-image-filename)))

(defun thumbs-file-alist ()
  "Make an alist of elements (POS . FILENAME) for all images in thumb buffer."
  (with-current-buffer thumbs-buffer
    (save-excursion
      (let (list)
	(goto-char (point-min))
	(while (not (eobp))
	  (unless (eolp)
	    (if (thumbs-current-image)
		(push (cons (point-marker)
			    (thumbs-current-image))
		    list)))
	  (forward-char 1))
	(nreverse list)))))

(defun thumbs-file-list ()
  "Make a list of file names for all images in thumb buffer."
  (save-excursion
    (let (list)
      (goto-char (point-min))
      (while (not (eobp))
	(if (thumbs-current-image)
	    (push (thumbs-current-image) list))
	(forward-char 1))
      (nreverse list))))

(defun thumbs-delete-images ()
  "Delete the image at point (and its thumbnail) (or marked files if any)."
  (interactive)
  (let ((files (or thumbs-marked-list (list (thumbs-current-image)))))
    (if (yes-or-no-p (format "Really delete %d files? " (length files)))
	(let ((thumbs-file-list (thumbs-file-alist))
	      (inhibit-read-only t))
	  (dolist (x files)
	    (let (failure)
	      (condition-case ()
		  (progn
		    (delete-file x)
		    (delete-file (thumbs-thumbname x)))
		(file-error (setq failure t)))
	      (unless failure
		(when (rassoc x thumbs-file-list)
		  (goto-char (car (rassoc x thumbs-file-list)))
		  (delete-region (point) (1+ (point))))
		(setq thumbs-marked-list
		      (delq x thumbs-marked-list)))))))))

(defun thumbs-rename-images (newfile)
  "Rename the image at point (and its thumbnail) (or marked files if any)."
  (interactive "FRename to file or directory: ")
  (let ((files (or thumbs-marked-list (list (thumbs-current-image))))
	failures)
    (if (and (not (file-directory-p newfile))
	     thumbs-marked-list)
	(if (file-exists-p newfile)
	    (error "Renaming marked files to file name `%s'" newfile)
	  (make-directory newfile t)))
    (if (yes-or-no-p (format "Really rename %d files? " (length files)))
	(let ((thumbs-file-list (thumbs-file-alist))
	      (inhibit-read-only t))
	  (dolist (file files)
	    (let (failure)
	      (condition-case ()
		  (if (file-directory-p newfile)
		      (rename-file file
				   (expand-file-name
				    (file-name-nondirectory file)
				    newfile))
		    (rename-file file newfile))
		(file-error (setq failure t)
			    (push file failures)))
	      (unless failure
		(when (rassoc file thumbs-file-list)
		  (goto-char (car (rassoc file thumbs-file-list)))
		  (delete-region (point) (1+ (point))))
		(setq thumbs-marked-list
		      (delq file thumbs-marked-list)))))))
    (if failures
	(display-warning 'file-error
			 (format "Rename failures for %s into %s"
				 failures newfile)
			 :error))))

(defun thumbs-kill-buffer ()
  "Kill the current buffer."
  (interactive)
  (quit-window t (selected-window)))

(defun thumbs-show-image-num (num)
  "Show the image with number NUM."
  (let ((image-buffer (get-buffer-create "*Image*")))
    (let ((img (cdr (nth (1- num) (thumbs-file-alist)))))
      (with-current-buffer image-buffer
	(setq mode-name
	      (concat "image-view-mode: " (file-name-nondirectory img)
		      " - " (number-to-string num)))
	(let ((inhibit-read-only t))
	  (erase-buffer)
	  (thumbs-insert-image img (thumbs-image-type img) 0)
	  (goto-char (point-min))))
      (setq thumbs-image-num num
	    thumbs-current-image-filename img))))

(defun thumbs-previous-image ()
  "Show the previous image."
  (interactive)
  (let* ((i (- thumbs-image-num 1))
	 (number (length (thumbs-file-alist))))
    (if (= i 0) (setq i (1- number)))
    (thumbs-show-image-num i)))

(defun thumbs-next-image ()
  "Show the next image."
  (interactive)
  (let* ((i (1+ thumbs-image-num))
	 (number (length (thumbs-file-alist))))
    (if (= i number) (setq i 1))
    (thumbs-show-image-num i)))

(defun thumbs-display-thumbs-buffer ()
  "Display the associated thumbs buffer."
  (interactive)
  (display-buffer thumbs-buffer))

(defun thumbs-redraw-buffer ()
  "Redraw the current thumbs buffer."
  (let ((p (point))
	(inhibit-read-only t)
	(files (thumbs-file-list)))
    (erase-buffer)
    (thumbs-do-thumbs-insertion files)
    (goto-char p)))

(defun thumbs-mark ()
  "Mark the image at point."
  (interactive)
  (let ((elt (thumbs-current-image)))
    (unless elt
      (error "No image here"))
    (push elt thumbs-marked-list)
    (let ((inhibit-read-only t))
      (delete-char 1)
      (thumbs-insert-thumb elt t)))
  (when (eolp) (forward-char)))

(defun thumbs-unmark ()
  "Unmark the image at point."
  (interactive)
  (let ((elt (thumbs-current-image)))
    (unless elt
      (error "No image here"))
    (setq thumbs-marked-list (delete elt thumbs-marked-list))
    (let ((inhibit-read-only t))
      (delete-char 1)
      (thumbs-insert-thumb elt nil)))
  (when (eolp) (forward-char)))

;; cleaning of old temp files
(mapc 'delete-file
      (directory-files (thumbs-temp-dir) t thumbs-temp-prefix))

;; Image modification routines

(defun thumbs-modify-image (action &optional arg)
  "Call convert to do ACTION on image with argument ARG.
ACTION and ARG should be a valid convert command."
  (interactive "sAction: \nsValue: ")
  (let* ((buffer-read-only nil)
	 (old thumbs-current-tmp-filename)
	 (tmp (thumbs-temp-file)))
    (erase-buffer)
    (thumbs-call-convert (or old thumbs-current-image-filename)
			 tmp
			 action
			 (or arg ""))
    (save-excursion
      (thumbs-insert-image tmp 'jpeg 0))
    (setq thumbs-current-tmp-filename tmp)))

(defun thumbs-emboss-image (emboss)
  "Emboss the image with value EMBOSS."
  (interactive "nEmboss value: ")
  (if (or (< emboss 3) (> emboss 31) (zerop (% emboss 2)))
      (error "Arg must be an odd number between 3 and 31"))
  (thumbs-modify-image "emboss" (number-to-string emboss)))

(defun thumbs-monochrome-image ()
  "Turn the image to monochrome."
  (interactive)
  (thumbs-modify-image "monochrome"))

(defun thumbs-negate-image ()
  "Negate the image."
  (interactive)
  (thumbs-modify-image "negate"))

(defun thumbs-rotate-left ()
  "Rotate the image 90 degrees counter-clockwise."
  (interactive)
  (thumbs-modify-image "rotate" "270"))

(defun thumbs-rotate-right ()
  "Rotate the image 90 degrees clockwise."
  (interactive)
  (thumbs-modify-image "rotate" "90"))

(defun thumbs-current-image ()
  "Return the name of the image file name at point."
  (get-text-property (point) 'thumb-image-file))

(defun thumbs-forward-char ()
  "Move forward one image."
  (interactive)
  (forward-char)
  (while (and (not (eobp)) (not (thumbs-current-image)))
    (forward-char))
  (thumbs-show-name))

(defun thumbs-backward-char ()
  "Move backward one image."
  (interactive)
  (forward-char -1)
  (while (and (not (bobp)) (not (thumbs-current-image)))
    (forward-char -1))
  (thumbs-show-name))

(defun thumbs-backward-line ()
  "Move up one line."
  (interactive)
  (forward-line -1)
  (thumbs-show-name))

(defun thumbs-forward-line ()
  "Move down one line."
  (interactive)
  (forward-line 1)
  (thumbs-show-name))

(defun thumbs-show-more-images (&optional arg)
  "Show more than `thumbs-max-image-number' images, if present."
  (interactive "P")
  (or arg (setq arg 1))
  (setq thumbs-extra-images (+ thumbs-extra-images arg))
  (thumbs-dired-show))

(defun thumbs-show-name ()
  "Show the name of the current file."
  (interactive)
  (let ((f (thumbs-current-image)))
    (and f (message "%s [%s]" f (thumbs-file-size f)))))

(defun thumbs-save-current-image ()
  "Save the current image."
  (interactive)
  (let ((f (or thumbs-current-tmp-filename
	       thumbs-current-image-filename))
	(sa (read-from-minibuffer "Save image file as: "
				  thumbs-current-image-filename)))
    (copy-file f sa)))

(defun thumbs-dired ()
  "Use `dired' on the current thumbs directory."
  (interactive)
  (dired thumbs-current-dir))

;; thumbs-mode

(defvar thumbs-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [return] 'thumbs-find-image-at-point)
    (define-key map [mouse-2] 'thumbs-mouse-find-image)
    (define-key map [(meta return)] 'thumbs-find-image-at-point-other-window)
    (define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window)
    (define-key map [delete] 'thumbs-delete-images)
    (define-key map [right] 'thumbs-forward-char)
    (define-key map [left] 'thumbs-backward-char)
    (define-key map [up] 'thumbs-backward-line)
    (define-key map [down] 'thumbs-forward-line)
    (define-key map "+" 'thumbs-show-more-images)
    (define-key map "d" 'thumbs-dired)
    (define-key map "m" 'thumbs-mark)
    (define-key map "u" 'thumbs-unmark)
    (define-key map "R" 'thumbs-rename-images)
    (define-key map "x" 'thumbs-delete-images)
    (define-key map "s" 'thumbs-show-name)
    (define-key map "q" 'thumbs-kill-buffer)
    map)
  "Keymap for `thumbs-mode'.")

(put 'thumbs-mode 'mode-class 'special)
(define-derived-mode thumbs-mode
  fundamental-mode "thumbs"
  "Preview images in a thumbnails buffer"
  (setq buffer-read-only t))

(defvar thumbs-view-image-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [prior] 'thumbs-previous-image)
    (define-key map [next] 'thumbs-next-image)
    (define-key map "^" 'thumbs-display-thumbs-buffer)
    (define-key map "-" 'thumbs-shrink-image)
    (define-key map "+" 'thumbs-enlarge-image)
    (define-key map "<" 'thumbs-rotate-left)
    (define-key map ">" 'thumbs-rotate-right)
    (define-key map "e" 'thumbs-emboss-image)
    (define-key map "r" 'thumbs-resize-image)
    (define-key map "s" 'thumbs-save-current-image)
    (define-key map "q" 'thumbs-kill-buffer)
    (define-key map "w" 'thumbs-set-root)
    map)
  "Keymap for `thumbs-view-image-mode'.")

;; thumbs-view-image-mode
(put 'thumbs-view-image-mode 'mode-class 'special)
(define-derived-mode thumbs-view-image-mode
  fundamental-mode "image-view-mode"
  (setq buffer-read-only t))

;;;###autoload
(defun thumbs-dired-setroot ()
  "In dired, call the setroot program on the image at point."
  (interactive)
  (thumbs-call-setroot-command (dired-get-filename)))

;; Modif to dired mode map
(define-key dired-mode-map "\C-ta" 'thumbs-dired-show)
(define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked)
(define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot)

(provide 'thumbs)

;; arch-tag: f9ac1ef8-83fc-42c0-8069-1fae43fd2e5c
;;; thumbs.el ends here