[Emacs-diffs] Changes to emacs/lisp/thumbs.el

[Richard M . Stallman]

Index: emacs/lisp/thumbs.el
diff -c emacs/lisp/thumbs.el:1.5 emacs/lisp/thumbs.el:1.6
*** emacs/lisp/thumbs.el:1.5    Wed Apr 28 23:19:43 2004
--- emacs/lisp/thumbs.el        Sat May 29 15:22:55 2004
***************
*** 1,15 ****
  ;;; thumbs.el --- Thumbnails previewer for images files
! ;;;
  ;; Author: Jean-Philippe Theberge <address@hidden>
- ;;
- ;; Thanks: Alex Schroeder <address@hidden> for maintaining the package at 
some time
- ;;         The peoples at address@hidden for numerous help
- ;;         RMS for emacs and the GNU project.
- ;;
  ;; Keywords: Multimedia
  
- (defconst thumbs-version "2.0")
- 
  ;; This file is part of GNU Emacs.
  
  ;; GNU Emacs is free software; you can redistribute it and/or modify
--- 1,10 ----
  ;;; thumbs.el --- Thumbnails previewer for images files
! 
! ;; Copyright 2004 Free Software Foundation, Inc
! 
  ;; Author: Jean-Philippe Theberge <address@hidden>
  ;; Keywords: Multimedia
  
  ;; This file is part of GNU Emacs.
  
  ;; GNU Emacs is free software; you can redistribute it and/or modify
***************
*** 26,31 ****
--- 21,31 ----
  ;; 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 <address@hidden> for maintaining the package at 
some time
+ ;;         The peoples at address@hidden for numerous help
+ ;;         RMS for emacs and the GNU project.
+ ;;
  
  ;;; Commentary:
  
***************
*** 56,74 ****
  
  ;;; 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
--- 56,63 ----
***************
*** 212,220 ****
         (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)))
        (setq filesL (cdr filesL)))))
  
  ;; Check the thumbsnail directory size and clean it if necessary.
--- 201,209 ----
         (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL))))
      (while (> dirsize thumbs-thumbsdir-max-size)
        (progn
!       (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,282 ****
  Or, alternatively, a SIZE may be specified."
    (interactive)
    ;; cleaning of old temp file
!   (ignore-errors
      (apply 'delete-file
           (directory-files
            thumbs-temp-dir t
!           thumbs-temp-prefix)))
    (let ((buffer-read-only nil)
        (x (if size
               size
--- 261,272 ----
  Or, alternatively, a SIZE may be specified."
    (interactive)
    ;; cleaning of old temp file
!   (condition-case nil
      (apply 'delete-file
           (directory-files
            thumbs-temp-dir t
!           thumbs-temp-prefix))
!     (error nil))
    (let ((buffer-read-only nil)
        (x (if size
               size
***************
*** 309,330 ****
    (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
           ?\  ?\_
           (apply
            'concat
--- 299,308 ----
    (interactive)
    (thumbs-resize-image t))
  
  (defun thumbs-thumbname (img)
    "Return a thumbnail name for the image IMG."
    (concat thumbs-thumbsdir "/"
!         (subst-char-in-string
           ?\  ?\_
           (apply
            'concat
***************
*** 336,342 ****
    (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)))
        (thumbs-call-convert fn tn "sample" thumbs-geometry))
      tn))
  
--- 314,324 ----
    (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))
  
***************
*** 380,409 ****
    "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))
  
  (defun thumbs-do-thumbs-insertion (L)
    "Insert all thumbs in list L."
-   (setq thumbs-fileL nil)
    (let ((i 0))
!     (while L
        (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)))))
  
  (defun thumbs-show-thumbs-list (L &optional buffer-name same-window)
    (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)
--- 362,389 ----
    "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)
!   (put-text-property (1- (point)) (point)
!                    'thumb-image-file img))
  
  (defun thumbs-do-thumbs-insertion (L)
    "Insert all thumbs in list L."
    (let ((i 0))
!     (dolist (img L)
!       (thumbs-insert-thumb img
!                          (member img thumbs-markedL))
        (when (= 0 (mod (setq i (1+ i)) thumbs-per-line))
!       (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)
      (thumbs-do-thumbs-insertion L)
      (goto-char (point-min))
      (setq thumbs-current-dir default-directory)
***************
*** 435,442 ****
  ;;;###autoload
  (defalias 'thumbs 'thumbs-show-all-from-dir)
  
! (defun thumbs-find-image (img L &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)) "*"))
--- 415,422 ----
  ;;;###autoload
  (defalias 'thumbs 'thumbs-show-all-from-dir)
  
! (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,456 ****
      (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)))
  
--- 429,434 ----
***************
*** 458,467 ****
    "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)))
  
  (defun thumbs-find-image-at-point-other-window ()
    "Display image for thumbnail at point in the preview buffer.
--- 436,443 ----
    "Display image IMG for thumbnail at point.
  use another window it 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.
***************
*** 469,474 ****
--- 445,456 ----
    (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,487 ****
  (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))))
  
  (defun thumbs-set-root ()
    "Set the current image as root."
--- 463,470 ----
  (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."
***************
*** 490,525 ****
     (or thumbs-current-tmp-filename
         thumbs-current-image-filename)))
  
  (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))
                    (delete-file x)
!                   (delete-file (thumbs-thumbname x))) f)
!         (thumbs-redraw-buffer)))))
  
  (defun thumbs-kill-buffer ()
    "Kill the current buffer."
    (interactive)
    (let ((buffer (current-buffer)))
!     (ignore-errors (delete-window (selected-window)))
      (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) "*"))
        (setq thumbs-image-num num
            thumbs-current-image-filename i))))
  
--- 473,574 ----
     (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 ((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)))
!               (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)))
!     (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 ((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,566 ****
    "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)))
  
  (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)))
  
  (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))))
  
  (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)))
  
  ;; Image modification routines
  
--- 576,629 ----
    "Show next image."
    (interactive)
    (let* ((i (1+ thumbs-image-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))
!        (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)
!       (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-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,594 ****
  (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"))
    (thumbs-modify-image "emboss" (number-to-string emboss)))
  
  (defun thumbs-monochrome-image ()
--- 650,657 ----
  (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 ()
***************
*** 611,627 ****
    (interactive)
    (thumbs-modify-image "rotate" "90"))
  
  (defun thumbs-forward-char ()
    "Move forward one image."
    (interactive)
    (forward-char)
!   (when (eolp)(forward-char))
    (thumbs-show-name))
  
  (defun thumbs-backward-char ()
    "Move backward one image."
    (interactive)
    (forward-char -1)
    (thumbs-show-name))
  
  (defun thumbs-forward-line ()
--- 674,697 ----
    (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-forward-line ()
***************
*** 639,653 ****
  (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))))
  
  (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: "
                                  thumbs-current-image-filename)))
      (copy-file f sa)))
  
--- 709,723 ----
  (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)))
  
***************
*** 661,666 ****
--- 731,737 ----
  (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,684 ****
--- 741,760 ----
      (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,703 ****
--- 774,780 ----
    "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")