1 |
;;; thumbs.el --- Thumbnails previewer for images files |
;;; thumbs.el --- Thumbnails previewer for images files |
2 |
;;; |
|
3 |
|
;; Copyright 2004 Free Software Foundation, Inc |
4 |
|
|
5 |
;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca> |
;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca> |
|
;; |
|
|
;; 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. |
|
|
;; |
|
6 |
;; Keywords: Multimedia |
;; Keywords: Multimedia |
7 |
|
|
|
(defconst thumbs-version "2.0") |
|
|
|
|
8 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
9 |
|
|
10 |
;; GNU Emacs is free software; you can redistribute it and/or modify |
;; GNU Emacs is free software; you can redistribute it and/or modify |
21 |
;; along with GNU Emacs; see the file COPYING. If not, write to the |
;; along with GNU Emacs; see the file COPYING. If not, write to the |
22 |
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
23 |
;; Boston, MA 02111-1307, USA. |
;; Boston, MA 02111-1307, USA. |
24 |
|
;; |
25 |
|
;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some time |
26 |
|
;; The peoples at #emacs@freenode.net for numerous help |
27 |
|
;; RMS for emacs and the GNU project. |
28 |
|
;; |
29 |
|
|
30 |
;;; Commentary: |
;;; Commentary: |
31 |
|
|
52 |
;; for that image. C-h m will give you a list of available keybinding. |
;; for that image. C-h m will give you a list of available keybinding. |
53 |
|
|
54 |
;;; History: |
;;; History: |
55 |
;; |
;; |
56 |
|
|
57 |
;;; Code: |
;;; Code: |
58 |
|
|
59 |
(require 'dired) |
(require 'dired) |
60 |
|
|
|
;; Abort if in-line imaging isn't supported (i.e. Emacs-20.7) |
|
|
|
|
|
(when (not (display-images-p)) |
|
|
(error "Your Emacs version (%S) doesn't support in-line images, |
|
|
was not compiled with image support or is run in console mode. |
|
|
Upgrade to Emacs 21.1 or newer, compile it with image support |
|
|
or use a window-system" |
|
|
emacs-version)) |
|
|
|
|
61 |
;; CUSTOMIZATIONS |
;; CUSTOMIZATIONS |
62 |
|
|
63 |
(defgroup thumbs nil |
(defgroup thumbs nil |
139 |
:group 'thumbs) |
:group 'thumbs) |
140 |
|
|
141 |
;; Initialize some variable, for later use. |
;; Initialize some variable, for later use. |
142 |
(defvar thumbs-temp-file |
(defvar thumbs-temp-file |
143 |
(concat thumbs-temp-dir thumbs-temp-prefix) |
(concat thumbs-temp-dir thumbs-temp-prefix) |
144 |
"Temporary filesname for images.") |
"Temporary filesname for images.") |
145 |
|
|
146 |
(defvar thumbs-current-tmp-filename |
(defvar thumbs-current-tmp-filename |
147 |
nil |
nil |
148 |
"Temporary filename of current image.") |
"Temporary filename of current image.") |
149 |
(defvar thumbs-current-image-filename |
(defvar thumbs-current-image-filename |
150 |
nil |
nil |
151 |
"Filename of current image.") |
"Filename of current image.") |
152 |
(defvar thumbs-current-image-size |
(defvar thumbs-current-image-size |
153 |
nil |
nil |
154 |
"Size of current image.") |
"Size of current image.") |
155 |
(defvar thumbs-image-num |
(defvar thumbs-image-num |
156 |
nil |
nil |
157 |
"Number of current image.") |
"Number of current image.") |
158 |
(defvar thumbs-current-dir |
(defvar thumbs-current-dir |
159 |
nil |
nil |
160 |
"Current directory.") |
"Current directory.") |
161 |
(defvar thumbs-markedL |
(defvar thumbs-markedL |
162 |
nil |
nil |
163 |
"List of marked files.") |
"List of marked files.") |
164 |
|
|
173 |
(make-directory thumbs-thumbsdir) |
(make-directory thumbs-thumbsdir) |
174 |
(message "Creating thumbnails directory"))) |
(message "Creating thumbnails directory"))) |
175 |
|
|
|
(when (not (fboundp 'ignore-errors)) |
|
|
(defmacro ignore-errors (&rest body) |
|
|
"Execute FORMS; if anz error occurs, return nil. |
|
|
Otherwise, return result of last FORM." |
|
|
(let ((err (thumbs-gensym))) |
|
|
(list 'condition-case err (cons 'progn body) '(error nil))))) |
|
|
|
|
|
(when (not (fboundp 'time-less-p)) |
|
|
(defun time-less-p (t1 t2) |
|
|
"Say whether time T1 is less than time T2." |
|
|
(or (< (car t1) (car t2)) |
|
|
(and (= (car t1) (car t2)) |
|
|
(< (nth 1 t1) (nth 1 t2)))))) |
|
|
|
|
|
(when (not (fboundp 'caddar)) |
|
|
(defun caddar (x) |
|
|
"Return the `car' of the `cdr' of the `cdr' of the `car' of X." |
|
|
(car (cdr (cdr (car x)))))) |
|
|
|
|
176 |
(defvar thumbs-gensym-counter 0) |
(defvar thumbs-gensym-counter 0) |
177 |
|
|
178 |
(defun thumbs-gensym (&optional arg) |
(defun thumbs-gensym (&optional arg) |
180 |
The name is made by appending a number to PREFIX, default \"Thumbs\"." |
The name is made by appending a number to PREFIX, default \"Thumbs\"." |
181 |
(let ((prefix (if (stringp arg) arg "Thumbs")) |
(let ((prefix (if (stringp arg) arg "Thumbs")) |
182 |
(num (if (integerp arg) arg |
(num (if (integerp arg) arg |
183 |
(prog1 |
(prog1 |
184 |
thumbs-gensym-counter |
thumbs-gensym-counter |
185 |
(setq thumbs-gensym-counter (1+ thumbs-gensym-counter)))))) |
(setq thumbs-gensym-counter (1+ thumbs-gensym-counter)))))) |
186 |
(make-symbol (format "%s%d" prefix num)))) |
(make-symbol (format "%s%d" prefix num)))) |
201 |
(dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL)))) |
(dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL)))) |
202 |
(while (> dirsize thumbs-thumbsdir-max-size) |
(while (> dirsize thumbs-thumbsdir-max-size) |
203 |
(progn |
(progn |
204 |
(message "Deleting file %s" (caddar filesL))) |
(message "Deleting file %s" (cadr (cdar filesL)))) |
205 |
(delete-file (caddar filesL)) |
(delete-file (cadr (cdar filesL))) |
206 |
(setq dirsize (- dirsize (cadar filesL))) |
(setq dirsize (- dirsize (car (cdar filesL)))) |
207 |
(setq filesL (cdr filesL))))) |
(setq filesL (cdr filesL))))) |
208 |
|
|
209 |
;; Check the thumbsnail directory size and clean it if necessary. |
;; Check the thumbsnail directory size and clean it if necessary. |
246 |
thumbs-image-resizing-step) |
thumbs-image-resizing-step) |
247 |
(thumbs-increment-image-size-element (cdr s) |
(thumbs-increment-image-size-element (cdr s) |
248 |
thumbs-image-resizing-step))) |
thumbs-image-resizing-step))) |
249 |
|
|
250 |
(defun thumbs-decrement-image-size (s) |
(defun thumbs-decrement-image-size (s) |
251 |
"Decrement S (a cons of width x heigh)." |
"Decrement S (a cons of width x heigh)." |
252 |
(cons |
(cons |
261 |
Or, alternatively, a SIZE may be specified." |
Or, alternatively, a SIZE may be specified." |
262 |
(interactive) |
(interactive) |
263 |
;; cleaning of old temp file |
;; cleaning of old temp file |
264 |
(ignore-errors |
(condition-case nil |
265 |
(apply 'delete-file |
(apply 'delete-file |
266 |
(directory-files |
(directory-files |
267 |
thumbs-temp-dir t |
thumbs-temp-dir t |
268 |
thumbs-temp-prefix))) |
thumbs-temp-prefix)) |
269 |
|
(error nil)) |
270 |
(let ((buffer-read-only nil) |
(let ((buffer-read-only nil) |
271 |
(x (if size |
(x (if size |
272 |
size |
size |
288 |
"Resize Image interactively to specified WIDTH and HEIGHT." |
"Resize Image interactively to specified WIDTH and HEIGHT." |
289 |
(interactive "nWidth: \nnHeight: ") |
(interactive "nWidth: \nnHeight: ") |
290 |
(thumbs-resize-image nil (cons width height))) |
(thumbs-resize-image nil (cons width height))) |
291 |
|
|
292 |
(defun thumbs-resize-image-size-down () |
(defun thumbs-resize-image-size-down () |
293 |
"Resize image (smaller)." |
"Resize image (smaller)." |
294 |
(interactive) |
(interactive) |
299 |
(interactive) |
(interactive) |
300 |
(thumbs-resize-image t)) |
(thumbs-resize-image t)) |
301 |
|
|
|
(defun thumbs-subst-char-in-string (orig rep string) |
|
|
"Replace occurrences of character ORIG with character REP in STRING. |
|
|
Return the resulting (new) string. -- (defun borowed to Dave Love)" |
|
|
(let ((string (copy-sequence string)) |
|
|
(l (length string)) |
|
|
(i 0)) |
|
|
(while (< i l) |
|
|
(if (= (aref string i) orig) |
|
|
(aset string i rep)) |
|
|
(setq i (1+ i))) |
|
|
string)) |
|
|
|
|
302 |
(defun thumbs-thumbname (img) |
(defun thumbs-thumbname (img) |
303 |
"Return a thumbnail name for the image IMG." |
"Return a thumbnail name for the image IMG." |
304 |
(concat thumbs-thumbsdir "/" |
(concat thumbs-thumbsdir "/" |
305 |
(thumbs-subst-char-in-string |
(subst-char-in-string |
306 |
?\ ?\_ |
?\ ?\_ |
307 |
(apply |
(apply |
308 |
'concat |
'concat |
314 |
(let* ((fn (expand-file-name img)) |
(let* ((fn (expand-file-name img)) |
315 |
(tn (thumbs-thumbname img))) |
(tn (thumbs-thumbname img))) |
316 |
(if (or (not (file-exists-p tn)) |
(if (or (not (file-exists-p tn)) |
317 |
(not (equal (thumbs-file-size tn) thumbs-geometry))) |
;; This is not the right fix, but I don't understand |
318 |
|
;; the external program or why it produces a geometry |
319 |
|
;; unequal to the one requested -- rms. |
320 |
|
;;; (not (equal (thumbs-file-size tn) thumbs-geometry)) |
321 |
|
) |
322 |
(thumbs-call-convert fn tn "sample" thumbs-geometry)) |
(thumbs-call-convert fn tn "sample" thumbs-geometry)) |
323 |
tn)) |
tn)) |
324 |
|
|
325 |
(defun thumbs-image-type (img) |
(defun thumbs-image-type (img) |
326 |
"Return image type from filename IMG." |
"Return image type from filename IMG." |
327 |
(cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg) |
(cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg) |
337 |
(concat (number-to-string (round (car i))) |
(concat (number-to-string (round (car i))) |
338 |
"x" |
"x" |
339 |
(number-to-string (round (cdr i)))))) |
(number-to-string (round (cdr i)))))) |
340 |
|
|
341 |
;;;###autoload |
;;;###autoload |
342 |
(defun thumbs-find-thumb (img) |
(defun thumbs-find-thumb (img) |
343 |
"Display the thumbnail for IMG." |
"Display the thumbnail for IMG." |
362 |
"Insert the thumbnail for IMG at point. |
"Insert the thumbnail for IMG at point. |
363 |
if MARKED is non-nil, the image is marked" |
if MARKED is non-nil, the image is marked" |
364 |
(thumbs-insert-image |
(thumbs-insert-image |
365 |
(thumbs-make-thumb img) 'jpeg thumbs-relief marked)) |
(thumbs-make-thumb img) 'jpeg thumbs-relief marked) |
366 |
|
(put-text-property (1- (point)) (point) |
367 |
|
'thumb-image-file img)) |
368 |
|
|
369 |
(defun thumbs-do-thumbs-insertion (L) |
(defun thumbs-do-thumbs-insertion (L) |
370 |
"Insert all thumbs in list L." |
"Insert all thumbs in list L." |
|
(setq thumbs-fileL nil) |
|
371 |
(let ((i 0)) |
(let ((i 0)) |
372 |
(while L |
(dolist (img L) |
373 |
|
(thumbs-insert-thumb img |
374 |
|
(member img thumbs-markedL)) |
375 |
(when (= 0 (mod (setq i (1+ i)) thumbs-per-line)) |
(when (= 0 (mod (setq i (1+ i)) thumbs-per-line)) |
376 |
(newline)) |
(newline))) |
377 |
(setq thumbs-fileL (cons (cons (point) |
(unless (bobp) (newline)))) |
|
(car L)) |
|
|
thumbs-fileL)) |
|
|
(thumbs-insert-thumb (car L) |
|
|
(member (car L) thumbs-markedL)) |
|
|
(setq L (cdr L))))) |
|
378 |
|
|
379 |
(defun thumbs-show-thumbs-list (L &optional buffer-name same-window) |
(defun thumbs-show-thumbs-list (L &optional buffer-name same-window) |
380 |
|
(when (not (display-images-p)) |
381 |
|
(error "Images are not supported in this Emacs session")) |
382 |
(funcall (if same-window 'switch-to-buffer 'pop-to-buffer) |
(funcall (if same-window 'switch-to-buffer 'pop-to-buffer) |
383 |
(or buffer-name "*THUMB-View*")) |
(or buffer-name "*THUMB-View*")) |
384 |
(let ((inhibit-read-only t)) |
(let ((inhibit-read-only t)) |
385 |
(erase-buffer) |
(erase-buffer) |
386 |
(thumbs-mode) |
(thumbs-mode) |
|
(make-variable-buffer-local 'thumbs-fileL) |
|
|
(setq thumbs-fileL nil) |
|
387 |
(thumbs-do-thumbs-insertion L) |
(thumbs-do-thumbs-insertion L) |
388 |
(goto-char (point-min)) |
(goto-char (point-min)) |
389 |
(setq thumbs-current-dir default-directory) |
(setq thumbs-current-dir default-directory) |
415 |
;;;###autoload |
;;;###autoload |
416 |
(defalias 'thumbs 'thumbs-show-all-from-dir) |
(defalias 'thumbs 'thumbs-show-all-from-dir) |
417 |
|
|
418 |
(defun thumbs-find-image (img L &optional num otherwin) |
(defun thumbs-find-image (img &optional num otherwin) |
419 |
(funcall |
(funcall |
420 |
(if otherwin 'switch-to-buffer-other-window 'switch-to-buffer) |
(if otherwin 'switch-to-buffer-other-window 'switch-to-buffer) |
421 |
(concat "*Image: " (file-name-nondirectory img) " - " |
(concat "*Image: " (file-name-nondirectory img) " - " |
429 |
(make-variable-buffer-local 'thumbs-current-tmp-filename) |
(make-variable-buffer-local 'thumbs-current-tmp-filename) |
430 |
(make-variable-buffer-local 'thumbs-current-image-size) |
(make-variable-buffer-local 'thumbs-current-image-size) |
431 |
(make-variable-buffer-local 'thumbs-image-num) |
(make-variable-buffer-local 'thumbs-image-num) |
|
(make-variable-buffer-local 'thumbs-fileL) |
|
|
(setq thumbs-fileL L) |
|
432 |
(delete-region (point-min)(point-max)) |
(delete-region (point-min)(point-max)) |
433 |
(thumbs-insert-image img (thumbs-image-type img) 0))) |
(thumbs-insert-image img (thumbs-image-type img) 0))) |
434 |
|
|
436 |
"Display image IMG for thumbnail at point. |
"Display image IMG for thumbnail at point. |
437 |
use another window it OTHERWIN is t." |
use another window it OTHERWIN is t." |
438 |
(interactive) |
(interactive) |
439 |
(let* ((L thumbs-fileL) |
(let* ((i (or img (thumbs-current-image)))) |
440 |
(n (point)) |
(thumbs-find-image i (point) otherwin))) |
|
(i (or img (cdr (assoc n L))))) |
|
|
(thumbs-find-image i L n otherwin))) |
|
441 |
|
|
442 |
(defun thumbs-find-image-at-point-other-window () |
(defun thumbs-find-image-at-point-other-window () |
443 |
"Display image for thumbnail at point in the preview buffer. |
"Display image for thumbnail at point in the preview buffer. |
445 |
(interactive) |
(interactive) |
446 |
(thumbs-find-image-at-point nil t)) |
(thumbs-find-image-at-point nil t)) |
447 |
|
|
448 |
|
(defun thumbs-mouse-find-image (event) |
449 |
|
"Display image for thumbnail at mouse click EVENT." |
450 |
|
(interactive "e") |
451 |
|
(mouse-set-point event) |
452 |
|
(thumbs-find-image-at-point)) |
453 |
|
|
454 |
(defun thumbs-call-setroot-command (img) |
(defun thumbs-call-setroot-command (img) |
455 |
"Call the setroot program for IMG." |
"Call the setroot program for IMG." |
456 |
(run-hooks 'thumbs-before-setroot-hook) |
(run-hooks 'thumbs-before-setroot-hook) |
459 |
(shell-quote-argument (expand-file-name img)) |
(shell-quote-argument (expand-file-name img)) |
460 |
thumbs-setroot-command nil t)) |
thumbs-setroot-command nil t)) |
461 |
(run-hooks 'thumbs-after-setroot-hook)) |
(run-hooks 'thumbs-after-setroot-hook)) |
462 |
|
|
463 |
(defun thumbs-set-image-at-point-to-root-window () |
(defun thumbs-set-image-at-point-to-root-window () |
464 |
"Set the image at point as the desktop wallpaper." |
"Set the image at point as the desktop wallpaper." |
465 |
(interactive) |
(interactive) |
466 |
(thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL)))) |
(thumbs-call-setroot-command |
467 |
|
(thumbs-current-image))) |
468 |
|
|
469 |
(defun thumbs-set-root () |
(defun thumbs-set-root () |
470 |
"Set the current image as root." |
"Set the current image as root." |
473 |
(or thumbs-current-tmp-filename |
(or thumbs-current-tmp-filename |
474 |
thumbs-current-image-filename))) |
thumbs-current-image-filename))) |
475 |
|
|
476 |
|
(defun thumbs-file-alist () |
477 |
|
"Make an alist of elements (POS . FILENAME) for all images in thumb buffer." |
478 |
|
(save-excursion |
479 |
|
(let (list) |
480 |
|
(goto-char (point-min)) |
481 |
|
(while (not (eobp)) |
482 |
|
(if (thumbs-current-image) |
483 |
|
(push (cons (point-marker) |
484 |
|
(thumbs-current-image)) |
485 |
|
list)) |
486 |
|
(forward-char 1)) |
487 |
|
list))) |
488 |
|
|
489 |
|
(defun thumbs-file-list () |
490 |
|
"Make a list of file names for all images in thumb buffer." |
491 |
|
(save-excursion |
492 |
|
(let (list) |
493 |
|
(goto-char (point-min)) |
494 |
|
(while (not (eobp)) |
495 |
|
(if (thumbs-current-image) |
496 |
|
(push (thumbs-current-image) list)) |
497 |
|
(forward-char 1)) |
498 |
|
(nreverse list)))) |
499 |
|
|
500 |
(defun thumbs-delete-images () |
(defun thumbs-delete-images () |
501 |
"Delete the image at point (and it's thumbnail) (or marked files if any)." |
"Delete the image at point (and it's thumbnail) (or marked files if any)." |
502 |
(interactive) |
(interactive) |
503 |
(let ((f (or thumbs-markedL (list (cdr (assoc (point) thumbs-fileL)))))) |
(let ((files (or thumbs-markedL (list (thumbs-current-image))))) |
504 |
(if (yes-or-no-p "Really delete %d files?" (length f)) |
(if (yes-or-no-p (format "Really delete %d files? " (length files))) |
505 |
(progn |
(let ((thumbs-fileL (thumbs-file-alist)) |
506 |
(mapcar (lambda (x) |
(inhibit-read-only t)) |
507 |
(setq thumbs-fileL (delete (rassoc x thumbs-fileL) thumbs-fileL)) |
(dolist (x files) |
508 |
|
(let (failure) |
509 |
|
(condition-case () |
510 |
|
(progn |
511 |
(delete-file x) |
(delete-file x) |
512 |
(delete-file (thumbs-thumbname x))) f) |
(delete-file (thumbs-thumbname x))) |
513 |
(thumbs-redraw-buffer))))) |
(file-error (setq failure t))) |
514 |
|
(unless failure |
515 |
|
(when (rassoc x thumbs-fileL) |
516 |
|
(goto-char (car (rassoc x thumbs-fileL))) |
517 |
|
(delete-region (point) (1+ (point)))) |
518 |
|
(setq thumbs-markedL |
519 |
|
(delq x thumbs-markedL))))))))) |
520 |
|
|
521 |
|
(defun thumbs-rename-images (newfile) |
522 |
|
"Rename the image at point (and it's thumbnail) (or marked files if any)." |
523 |
|
(interactive "FRename to file or directory: ") |
524 |
|
(let ((files (or thumbs-markedL (list (thumbs-current-image)))) |
525 |
|
failures) |
526 |
|
(if (and (not (file-directory-p newfile)) |
527 |
|
thumbs-markedL) |
528 |
|
(if (file-exists-p newfile) |
529 |
|
(error "Renaming marked files to file name `%s'" newfile) |
530 |
|
(make-directory newfile t))) |
531 |
|
(if (yes-or-no-p (format "Really rename %d files? " (length files))) |
532 |
|
(let ((thumbs-fileL (thumbs-file-alist)) |
533 |
|
(inhibit-read-only t)) |
534 |
|
(dolist (file files) |
535 |
|
(let (failure) |
536 |
|
(condition-case () |
537 |
|
(if (file-directory-p newfile) |
538 |
|
(rename-file file |
539 |
|
(expand-file-name |
540 |
|
(file-name-nondirectory file) |
541 |
|
newfile)) |
542 |
|
(rename-file file newfile)) |
543 |
|
(file-error (setq failure t) |
544 |
|
(push file failures))) |
545 |
|
(unless failure |
546 |
|
(when (rassoc file thumbs-fileL) |
547 |
|
(goto-char (car (rassoc file thumbs-fileL))) |
548 |
|
(delete-region (point) (1+ (point)))) |
549 |
|
(setq thumbs-markedL |
550 |
|
(delq file thumbs-markedL))))))) |
551 |
|
(if failures |
552 |
|
(display-warning 'file-error |
553 |
|
(format "Rename failures for %s into %s" |
554 |
|
failures newfile) |
555 |
|
:error)))) |
556 |
|
|
557 |
(defun thumbs-kill-buffer () |
(defun thumbs-kill-buffer () |
558 |
"Kill the current buffer." |
"Kill the current buffer." |
559 |
(interactive) |
(interactive) |
560 |
(let ((buffer (current-buffer))) |
(let ((buffer (current-buffer))) |
561 |
(ignore-errors (delete-window (selected-window))) |
(condition-case nil |
562 |
|
(delete-window (selected-window)) |
563 |
|
(error nil)) |
564 |
(kill-buffer buffer))) |
(kill-buffer buffer))) |
565 |
|
|
566 |
(defun thumbs-show-image-num (num) |
(defun thumbs-show-image-num (num) |
567 |
"Show the image with number NUM." |
"Show the image with number NUM." |
568 |
(let ((inhibit-read-only t)) |
(let ((image-buffer (get-buffer-create "*Image*"))) |
569 |
(delete-region (point-min)(point-max)) |
(let ((i (thumbs-current-image))) |
570 |
(let ((i (cdr (assoc num thumbs-fileL)))) |
(with-current-buffer image-buffer |
571 |
(thumbs-insert-image i (thumbs-image-type i) 0) |
(thumbs-insert-image i (thumbs-image-type i) 0)) |
572 |
(sleep-for 2) |
(setq thumbs-image-num num |
573 |
(rename-buffer (concat "*Image: " |
thumbs-current-image-filename i)))) |
|
(file-name-nondirectory i) |
|
|
" - " |
|
|
(number-to-string num) "*"))) |
|
|
(setq thumbs-image-num num |
|
|
thumbs-current-image-filename i))) |
|
574 |
|
|
575 |
(defun thumbs-next-image () |
(defun thumbs-next-image () |
576 |
"Show next image." |
"Show next image." |
577 |
(interactive) |
(interactive) |
578 |
(let* ((i (1+ thumbs-image-num)) |
(let* ((i (1+ thumbs-image-num)) |
579 |
(l (caar thumbs-fileL)) |
(list (thumbs-file-alist)) |
580 |
(num |
(l (caar list))) |
581 |
(cond ((assoc i thumbs-fileL) i) |
(while (and (/= i thumbs-image-num) (not (assoc i list))) |
582 |
((>= i l) 1) |
(setq i (if (>= i l) 1 (1+ i)))) |
583 |
(t (1+ i))))) |
(thumbs-show-image-num i))) |
|
(thumbs-show-image-num num))) |
|
584 |
|
|
585 |
(defun thumbs-previous-image () |
(defun thumbs-previous-image () |
586 |
"Show the previous image." |
"Show the previous image." |
587 |
(interactive) |
(interactive) |
588 |
(let* ((i (- thumbs-image-num 1)) |
(let* ((i (- thumbs-image-num 1)) |
589 |
(l (caar thumbs-fileL)) |
(list (thumbs-file-alist)) |
590 |
(num |
(l (caar list))) |
591 |
(cond ((assoc i thumbs-fileL) i) |
(while (and (/= i thumbs-image-num) (not (assoc i list))) |
592 |
((<= i 1) l) |
(setq i (if (<= i 1) l (1- i)))) |
593 |
(t (- i 1))))) |
(thumbs-show-image-num i))) |
|
(thumbs-show-image-num num))) |
|
594 |
|
|
595 |
(defun thumbs-redraw-buffer () |
(defun thumbs-redraw-buffer () |
596 |
"Redraw the current thumbs buffer." |
"Redraw the current thumbs buffer." |
597 |
(let ((p (point)) |
(let ((p (point)) |
598 |
(inhibit-read-only t)) |
(inhibit-read-only t) |
599 |
(delete-region (point-min)(point-max)) |
(files (thumbs-file-list))) |
600 |
(thumbs-do-thumbs-insertion (reverse (mapcar 'cdr thumbs-fileL))) |
(erase-buffer) |
601 |
(goto-char (1+ p)))) |
(thumbs-do-thumbs-insertion files) |
602 |
|
(goto-char p))) |
603 |
|
|
604 |
(defun thumbs-mark () |
(defun thumbs-mark () |
605 |
"Mark the image at point." |
"Mark the image at point." |
606 |
(interactive) |
(interactive) |
607 |
(setq thumbs-markedL (cons (cdr (assoc (point) thumbs-fileL)) thumbs-markedL)) |
(let ((elt (thumbs-current-image))) |
608 |
(let ((inhibit-read-only t)) |
(unless elt |
609 |
(delete-char 1) |
(error "No image here")) |
610 |
(thumbs-insert-thumb (cdr (assoc (point) thumbs-fileL)) t)) |
(push elt thumbs-markedL) |
611 |
(when (eolp)(forward-char))) |
(let ((inhibit-read-only t)) |
612 |
|
(delete-char 1) |
613 |
|
(thumbs-insert-thumb elt t))) |
614 |
|
(when (eolp) (forward-char))) |
615 |
|
|
616 |
|
(defun thumbs-unmark () |
617 |
|
"Unmark the image at point." |
618 |
|
(interactive) |
619 |
|
(let ((elt (thumbs-current-image))) |
620 |
|
(unless elt |
621 |
|
(error "No image here")) |
622 |
|
(setq thumbs-markedL (delete elt thumbs-markedL)) |
623 |
|
(let ((inhibit-read-only t)) |
624 |
|
(delete-char 1) |
625 |
|
(thumbs-insert-thumb elt nil))) |
626 |
|
(when (eolp) (forward-char))) |
627 |
|
|
628 |
;; Image modification routines |
;; Image modification routines |
629 |
|
|
630 |
(defun thumbs-modify-image (action &optional arg) |
(defun thumbs-modify-image (action &optional arg) |
650 |
(defun thumbs-emboss-image (emboss) |
(defun thumbs-emboss-image (emboss) |
651 |
"Emboss the image with value EMBOSS." |
"Emboss the image with value EMBOSS." |
652 |
(interactive "nEmboss value: ") |
(interactive "nEmboss value: ") |
653 |
(if (or (< emboss 3)(> emboss 31)(evenp emboss)) |
(if (or (< emboss 3) (> emboss 31) (zerop (% emboss 2))) |
654 |
(error "Arg must be a odd number between 3 and 31")) |
(error "Arg must be an odd number between 3 and 31")) |
655 |
(thumbs-modify-image "emboss" (number-to-string emboss))) |
(thumbs-modify-image "emboss" (number-to-string emboss))) |
656 |
|
|
657 |
(defun thumbs-monochrome-image () |
(defun thumbs-monochrome-image () |
674 |
(interactive) |
(interactive) |
675 |
(thumbs-modify-image "rotate" "90")) |
(thumbs-modify-image "rotate" "90")) |
676 |
|
|
677 |
|
(defun thumbs-current-image () |
678 |
|
"Return the name of the image file name at point." |
679 |
|
(get-text-property (point) 'thumb-image-file)) |
680 |
|
|
681 |
(defun thumbs-forward-char () |
(defun thumbs-forward-char () |
682 |
"Move forward one image." |
"Move forward one image." |
683 |
(interactive) |
(interactive) |
684 |
(forward-char) |
(forward-char) |
685 |
(when (eolp)(forward-char)) |
(while (and (not (eobp)) (not (thumbs-current-image))) |
686 |
|
(forward-char)) |
687 |
(thumbs-show-name)) |
(thumbs-show-name)) |
688 |
|
|
689 |
(defun thumbs-backward-char () |
(defun thumbs-backward-char () |
690 |
"Move backward one image." |
"Move backward one image." |
691 |
(interactive) |
(interactive) |
692 |
(forward-char -1) |
(forward-char -1) |
693 |
|
(while (and (not (bobp)) (not (thumbs-current-image))) |
694 |
|
(forward-char -1)) |
695 |
(thumbs-show-name)) |
(thumbs-show-name)) |
696 |
|
|
697 |
(defun thumbs-forward-line () |
(defun thumbs-forward-line () |
709 |
(defun thumbs-show-name () |
(defun thumbs-show-name () |
710 |
"Show the name of the current file." |
"Show the name of the current file." |
711 |
(interactive) |
(interactive) |
712 |
(let ((f (cdr (assoc (point) thumbs-fileL)))) |
(let ((f (thumbs-current-image))) |
713 |
(message "%s [%s]" f (thumbs-file-size f)))) |
(and f (message "%s [%s]" f (thumbs-file-size f))))) |
714 |
|
|
715 |
(defun thumbs-save-current-image () |
(defun thumbs-save-current-image () |
716 |
"Save the current image." |
"Save the current image." |
717 |
(interactive) |
(interactive) |
718 |
(let ((f (or thumbs-current-tmp-filename |
(let ((f (or thumbs-current-tmp-filename |
719 |
thumbs-current-image-filename)) |
thumbs-current-image-filename)) |
720 |
(sa (read-from-minibuffer "save file as: " |
(sa (read-from-minibuffer "Save image file as: " |
721 |
thumbs-current-image-filename))) |
thumbs-current-image-filename))) |
722 |
(copy-file f sa))) |
(copy-file f sa))) |
723 |
|
|
731 |
(defvar thumbs-mode-map |
(defvar thumbs-mode-map |
732 |
(let ((map (make-sparse-keymap))) |
(let ((map (make-sparse-keymap))) |
733 |
(define-key map [return] 'thumbs-find-image-at-point) |
(define-key map [return] 'thumbs-find-image-at-point) |
734 |
|
(define-key map [mouse-2] 'thumbs-mouse-find-image) |
735 |
(define-key map [(meta return)] 'thumbs-find-image-at-point-other-window) |
(define-key map [(meta return)] 'thumbs-find-image-at-point-other-window) |
736 |
(define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window) |
(define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window) |
737 |
(define-key map [delete] 'thumbs-delete-images) |
(define-key map [delete] 'thumbs-delete-images) |
741 |
(define-key map [down] 'thumbs-forward-line) |
(define-key map [down] 'thumbs-forward-line) |
742 |
(define-key map "d" 'thumbs-dired) |
(define-key map "d" 'thumbs-dired) |
743 |
(define-key map "m" 'thumbs-mark) |
(define-key map "m" 'thumbs-mark) |
744 |
|
(define-key map "u" 'thumbs-unmark) |
745 |
|
(define-key map "R" 'thumbs-rename-images) |
746 |
|
(define-key map "x" 'thumbs-delete-images) |
747 |
(define-key map "s" 'thumbs-show-name) |
(define-key map "s" 'thumbs-show-name) |
748 |
(define-key map "q" 'thumbs-kill-buffer) |
(define-key map "q" 'thumbs-kill-buffer) |
749 |
map) |
map) |
750 |
"Keymap for `thumbs-mode'.") |
"Keymap for `thumbs-mode'.") |
751 |
|
|
752 |
|
(put 'thumbs-mode 'mode-class 'special) |
753 |
(define-derived-mode thumbs-mode |
(define-derived-mode thumbs-mode |
754 |
fundamental-mode "thumbs" |
fundamental-mode "thumbs" |
755 |
"Preview images in a thumbnails buffer" |
"Preview images in a thumbnails buffer" |
756 |
(make-variable-buffer-local 'thumbs-markedL) |
(make-variable-buffer-local 'thumbs-markedL) |
757 |
|
(setq buffer-read-only t) |
758 |
(setq thumbs-markedL nil)) |
(setq thumbs-markedL nil)) |
759 |
|
|
760 |
(defvar thumbs-view-image-mode-map |
(defvar thumbs-view-image-mode-map |
774 |
"Keymap for `thumbs-view-image-mode'.") |
"Keymap for `thumbs-view-image-mode'.") |
775 |
|
|
776 |
;; thumbs-view-image-mode |
;; thumbs-view-image-mode |
777 |
|
(put 'thumbs-view-image-mode 'mode-class 'special) |
778 |
(define-derived-mode thumbs-view-image-mode |
(define-derived-mode thumbs-view-image-mode |
779 |
fundamental-mode "image-view-mode") |
fundamental-mode "image-view-mode") |
780 |
|
|