1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-26 19:18:50 +00:00

Don't include cl. Don't bother with old Emacs versions.

(thumbs-subst-char-in-string): Deleted.
(thumbs-thumbname): Use subst-char-in-string.
(thumbs-resize-image): Use condition-case, not ignore-errors.
(thumbs-kill-buffer): Likewise.

(thumbs-mode): Make buffer read-only.
(thumbs-make-thumb): Unconditionally accept an existing file.
(thumbs-insert-thumb): Add thumb-image-file property to the image.
(thumbs-do-thumbs-insertion): Be smarter about where to put newlines.
(thumbs-show-thumbs-list): Error if images not supported.
(thumbs-save-current-image): Improve prompt string.
(thumbs-mode-map): Define u, R, x.
(thumbs-unmark): New command.
(thumbs-emboss-image): Minor cleanup.
(thumbs-forward-char, thumbs-backward-char): Skip chars with no image.
(thumbs-rename-images): New command.
(thumbs-show-image-num): Rewrite.  Don't rename the buffer.

(thumbs-current-image): New function.
(thumbs-file-list, thumbs-file-alist): New functions.
(thumbs-find-image): Delete arg L.
Don't set up thumbs-fileL as buffer-local global var.
(thumbs-find-image-at-point): Use thumbs-current-image.
(thumbs-set-image-at-point-to-root-window): Likewise.
(thumbs-delete-images): Use thumbs-current-image, thumbs-file-alist.
Record and warn about errors.  Update thumbs-markedL for deletions.
(thumbs-next-image, thumbs-previous-image): Use thumbs-file-alist.
(thumbs-redraw-buffer): Use thumbs-file-list.
(thumbs-mark): Use thumbs-current-image.
(thumbs-show-name): Use thumbs-current-image.

(thumbs-show-name): Do nothing if no image at point.
(thumbs-mouse-find-image): New command.
(thumbs-mode-map): Bind it to mouse-2.
(thumbs-mode): Make mode-class special.
(thumbs-view-image-mode): Likewise.
This commit is contained in:
Richard M. Stallman 2004-05-29 15:22:55 +00:00
parent bcaa1cef05
commit 0658b86f75

View File

@ -1,14 +1,9 @@
;;; thumbs.el --- Thumbnails previewer for images files
;;;
;; 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.
;;
;; Keywords: Multimedia
(defconst thumbs-version "2.0")
;; Copyright 2004 Free Software Foundation, Inc
;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca>
;; Keywords: Multimedia
;; This file is part of GNU Emacs.
@ -26,6 +21,11 @@
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;; 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.
;;
;;; Commentary:
@ -56,19 +56,8 @@
;;; Code:
(eval-when-compile
(require 'cl))
(require 'dired)
;; 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))
;; CUSTOMIZATIONS
(defgroup thumbs nil
@ -212,9 +201,9 @@ reached."
(dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL))))
(while (> dirsize thumbs-thumbsdir-max-size)
(progn
(message "Deleting file %s" (caddar filesL)))
(delete-file (caddar filesL))
(setq dirsize (- dirsize (cadar filesL)))
(message "Deleting file %s" (cadr (cdar filesL))))
(delete-file (cadr (cdar filesL)))
(setq dirsize (- dirsize (car (cdar filesL))))
(setq filesL (cdr filesL)))))
;; Check the thumbsnail directory size and clean it if necessary.
@ -272,11 +261,12 @@ if INCREMENT is set, make the image bigger, else smaller.
Or, alternatively, a SIZE may be specified."
(interactive)
;; cleaning of old temp file
(ignore-errors
(condition-case nil
(apply 'delete-file
(directory-files
thumbs-temp-dir t
thumbs-temp-prefix)))
thumbs-temp-prefix))
(error nil))
(let ((buffer-read-only nil)
(x (if size
size
@ -309,22 +299,10 @@ Or, alternatively, a SIZE may be specified."
(interactive)
(thumbs-resize-image t))
(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))
(defun thumbs-thumbname (img)
"Return a thumbnail name for the image IMG."
(concat thumbs-thumbsdir "/"
(thumbs-subst-char-in-string
(subst-char-in-string
?\ ?\_
(apply
'concat
@ -336,7 +314,11 @@ Return the resulting (new) string. -- (defun borowed to Dave Love)"
(let* ((fn (expand-file-name img))
(tn (thumbs-thumbname img)))
(if (or (not (file-exists-p tn))
(not (equal (thumbs-file-size tn) thumbs-geometry)))
;; 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))
@ -380,30 +362,28 @@ if MARKED is non-nil, the image is 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))
(thumbs-make-thumb img) 'jpeg thumbs-relief marked)
(put-text-property (1- (point)) (point)
'thumb-image-file img))
(defun thumbs-do-thumbs-insertion (L)
"Insert all thumbs in list L."
(setq thumbs-fileL nil)
(let ((i 0))
(while L
(dolist (img L)
(thumbs-insert-thumb img
(member img thumbs-markedL))
(when (= 0 (mod (setq i (1+ i)) thumbs-per-line))
(newline))
(setq thumbs-fileL (cons (cons (point)
(car L))
thumbs-fileL))
(thumbs-insert-thumb (car L)
(member (car L) thumbs-markedL))
(setq L (cdr L)))))
(newline)))
(unless (bobp) (newline))))
(defun thumbs-show-thumbs-list (L &optional buffer-name same-window)
(when (not (display-images-p))
(error "Images are not supported in this Emacs session"))
(funcall (if same-window 'switch-to-buffer 'pop-to-buffer)
(or buffer-name "*THUMB-View*"))
(let ((inhibit-read-only t))
(erase-buffer)
(thumbs-mode)
(make-variable-buffer-local 'thumbs-fileL)
(setq thumbs-fileL nil)
(thumbs-do-thumbs-insertion L)
(goto-char (point-min))
(setq thumbs-current-dir default-directory)
@ -435,8 +415,8 @@ and SAME-WINDOW to show thumbs in the same window."
;;;###autoload
(defalias 'thumbs 'thumbs-show-all-from-dir)
(defun thumbs-find-image (img L &optional num otherwin)
(funcall
(defun thumbs-find-image (img &optional num otherwin)
(funcall
(if otherwin 'switch-to-buffer-other-window 'switch-to-buffer)
(concat "*Image: " (file-name-nondirectory img) " - "
(number-to-string (or num 0)) "*"))
@ -449,8 +429,6 @@ and SAME-WINDOW to show thumbs in the same window."
(make-variable-buffer-local 'thumbs-current-tmp-filename)
(make-variable-buffer-local 'thumbs-current-image-size)
(make-variable-buffer-local 'thumbs-image-num)
(make-variable-buffer-local 'thumbs-fileL)
(setq thumbs-fileL L)
(delete-region (point-min)(point-max))
(thumbs-insert-image img (thumbs-image-type img) 0)))
@ -458,10 +436,8 @@ and SAME-WINDOW to show thumbs in the same window."
"Display image IMG for thumbnail at point.
use another window it OTHERWIN is t."
(interactive)
(let* ((L thumbs-fileL)
(n (point))
(i (or img (cdr (assoc n L)))))
(thumbs-find-image i L n otherwin)))
(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.
@ -469,6 +445,12 @@ 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)
@ -481,7 +463,8 @@ Open another window."
(defun thumbs-set-image-at-point-to-root-window ()
"Set the image at point as the desktop wallpaper."
(interactive)
(thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL))))
(thumbs-call-setroot-command
(thumbs-current-image)))
(defun thumbs-set-root ()
"Set the current image as root."
@ -490,36 +473,102 @@ Open another window."
(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."
(save-excursion
(let (list)
(goto-char (point-min))
(while (not (eobp))
(if (thumbs-current-image)
(push (cons (point-marker)
(thumbs-current-image))
list))
(forward-char 1))
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 it's thumbnail) (or marked files if any)."
(interactive)
(let ((f (or thumbs-markedL (list (cdr (assoc (point) thumbs-fileL))))))
(if (yes-or-no-p (format "Really delete %d files? " (length f)))
(progn
(mapcar (lambda (x)
(setq thumbs-fileL (delete (rassoc x thumbs-fileL) thumbs-fileL))
(let ((files (or thumbs-markedL (list (thumbs-current-image)))))
(if (yes-or-no-p (format "Really delete %d files? " (length files)))
(let ((thumbs-fileL (thumbs-file-alist))
(inhibit-read-only t))
(dolist (x files)
(let (failure)
(condition-case ()
(progn
(delete-file x)
(delete-file (thumbs-thumbname x))) f)
(thumbs-redraw-buffer)))))
(delete-file (thumbs-thumbname x)))
(file-error (setq failure t)))
(unless failure
(when (rassoc x thumbs-fileL)
(goto-char (car (rassoc x thumbs-fileL)))
(delete-region (point) (1+ (point))))
(setq thumbs-markedL
(delq x thumbs-markedL)))))))))
(defun thumbs-rename-images (newfile)
"Rename the image at point (and it's thumbnail) (or marked files if any)."
(interactive "FRename to file or directory: ")
(let ((files (or thumbs-markedL (list (thumbs-current-image))))
failures)
(if (and (not (file-directory-p newfile))
thumbs-markedL)
(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-fileL (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-fileL)
(goto-char (car (rassoc file thumbs-fileL)))
(delete-region (point) (1+ (point))))
(setq thumbs-markedL
(delq file thumbs-markedL)))))))
(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)
(let ((buffer (current-buffer)))
(ignore-errors (delete-window (selected-window)))
(condition-case nil
(delete-window (selected-window))
(error nil))
(kill-buffer buffer)))
(defun thumbs-show-image-num (num)
"Show the image with number NUM."
(let ((inhibit-read-only t))
(delete-region (point-min)(point-max))
(let ((i (cdr (assoc num thumbs-fileL))))
(thumbs-insert-image i (thumbs-image-type i) 0)
(sleep-for 2)
(rename-buffer (concat "*Image: "
(file-name-nondirectory i)
" - "
(number-to-string num) "*"))
(let ((image-buffer (get-buffer-create "*Image*")))
(let ((i (thumbs-current-image)))
(with-current-buffer image-buffer
(thumbs-insert-image i (thumbs-image-type i) 0))
(setq thumbs-image-num num
thumbs-current-image-filename i))))
@ -527,40 +576,54 @@ Open another window."
"Show next image."
(interactive)
(let* ((i (1+ thumbs-image-num))
(l (caar thumbs-fileL))
(num
(cond ((assoc i thumbs-fileL) i)
((>= i l) 1)
(t (1+ i)))))
(thumbs-show-image-num num)))
(list (thumbs-file-alist))
(l (caar list)))
(while (and (/= i thumbs-image-num) (not (assoc i list)))
(setq i (if (>= i l) 1 (1+ i))))
(thumbs-show-image-num i)))
(defun thumbs-previous-image ()
"Show the previous image."
(interactive)
(let* ((i (- thumbs-image-num 1))
(l (caar thumbs-fileL))
(num
(cond ((assoc i thumbs-fileL) i)
((<= i 1) l)
(t (- i 1)))))
(thumbs-show-image-num num)))
(list (thumbs-file-alist))
(l (caar list)))
(while (and (/= i thumbs-image-num) (not (assoc i list)))
(setq i (if (<= i 1) l (1- i))))
(thumbs-show-image-num i)))
(defun thumbs-redraw-buffer ()
"Redraw the current thumbs buffer."
(let ((p (point))
(inhibit-read-only t))
(delete-region (point-min)(point-max))
(thumbs-do-thumbs-insertion (reverse (mapcar 'cdr thumbs-fileL)))
(goto-char (1+ p))))
(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)
(setq thumbs-markedL (cons (cdr (assoc (point) thumbs-fileL)) thumbs-markedL))
(let ((inhibit-read-only t))
(delete-char 1)
(thumbs-insert-thumb (cdr (assoc (point) thumbs-fileL)) t))
(when (eolp)(forward-char)))
(let ((elt (thumbs-current-image)))
(unless elt
(error "No image here"))
(push elt thumbs-markedL)
(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-markedL (delete elt thumbs-markedL))
(let ((inhibit-read-only t))
(delete-char 1)
(thumbs-insert-thumb elt nil)))
(when (eolp) (forward-char)))
;; Image modification routines
@ -587,8 +650,8 @@ ACTION and ARG should be legal convert command."
(defun thumbs-emboss-image (emboss)
"Emboss the image with value EMBOSS."
(interactive "nEmboss value: ")
(if (or (< emboss 3) (> emboss 31) (zerop (logand emboss 1)))
(error "Arg must be a odd number between 3 and 31"))
(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 ()
@ -611,17 +674,24 @@ ACTION and ARG should be legal convert command."
(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)
(when (eolp)(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-forward-line ()
@ -639,15 +709,15 @@ ACTION and ARG should be legal convert command."
(defun thumbs-show-name ()
"Show the name of the current file."
(interactive)
(let ((f (cdr (assoc (point) thumbs-fileL))))
(message "%s [%s]" f (thumbs-file-size f))))
(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 file as: "
(sa (read-from-minibuffer "Save image file as: "
thumbs-current-image-filename)))
(copy-file f sa)))
@ -661,6 +731,7 @@ ACTION and ARG should be legal convert command."
(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)
@ -670,15 +741,20 @@ ACTION and ARG should be legal convert command."
(define-key map [down] 'thumbs-forward-line)
(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"
(make-variable-buffer-local 'thumbs-markedL)
(setq buffer-read-only t)
(setq thumbs-markedL nil))
(defvar thumbs-view-image-mode-map
@ -698,6 +774,7 @@ ACTION and ARG should be legal convert command."
"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")