/[emacs]/emacs/lisp/thumbs.el
ViewVC logotype

Diff of /emacs/lisp/thumbs.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.4.1 by handa, Fri Apr 16 12:50:10 2004 UTC revision 1.2.4.2 by miles, Mon Jun 28 07:28:46 2004 UTC
# Line 1  Line 1 
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
# Line 26  Line 21 
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    
# Line 52  Line 52 
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
# Line 148  see some of your images." Line 139  see some of your images."
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    
# Line 182  see some of your images." Line 173  see some of your images."
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)
# Line 208  Otherwise, return result of last FORM." Line 180  Otherwise, return result of last FORM."
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))))
# Line 229  reached." Line 201  reached."
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.
# Line 274  ACTION-PREFIX is the symbol to place bef Line 246  ACTION-PREFIX is the symbol to place bef
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
# Line 289  if INCREMENT is set, make the image bigg Line 261  if INCREMENT is set, make the image bigg
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
# Line 315  Or, alternatively, a SIZE may be specifi Line 288  Or, alternatively, a SIZE may be specifi
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)
# Line 326  Or, alternatively, a SIZE may be specifi Line 299  Or, alternatively, a SIZE may be specifi
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
# Line 353  Return the resulting (new) string.  -- ( Line 314  Return the resulting (new) string.  -- (
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)
# Line 372  Return the resulting (new) string.  -- ( Line 337  Return the resulting (new) string.  -- (
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."
# Line 397  if MARKED is non-nil, the image is marke Line 362  if MARKED is non-nil, the image is marke
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)
# Line 452  and SAME-WINDOW to show thumbs in the sa Line 415  and SAME-WINDOW to show thumbs in the sa
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) " - "
# Line 466  and SAME-WINDOW to show thumbs in the sa Line 429  and SAME-WINDOW to show thumbs in the sa
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    
# Line 475  and SAME-WINDOW to show thumbs in the sa Line 436  and SAME-WINDOW to show thumbs in the sa
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.
# Line 486  Open another window." Line 445  Open another window."
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)
# Line 494  Open another window." Line 459  Open another window."
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."
# Line 507  Open another window." Line 473  Open another window."
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)
# Line 604  ACTION and ARG should be legal convert c Line 650  ACTION and ARG should be legal convert c
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 ()
# Line 628  ACTION and ARG should be legal convert c Line 674  ACTION and ARG should be legal convert c
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 ()
# Line 656  ACTION and ARG should be legal convert c Line 709  ACTION and ARG should be legal convert c
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    
# Line 678  ACTION and ARG should be legal convert c Line 731  ACTION and ARG should be legal convert c
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)
# Line 687  ACTION and ARG should be legal convert c Line 741  ACTION and ARG should be legal convert c
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
# Line 715  ACTION and ARG should be legal convert c Line 774  ACTION and ARG should be legal convert c
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    

Legend:
Removed from v.1.2.4.1  
changed lines
  Added in v.1.2.4.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26