comparison lisp/thumbs.el @ 55206:c2c29cafaa74

(time-less-p): Remove.

55205:bc07155aabd8

;;; thumbs.el --- Thumbnails previewer for images files
;;;
;; Author: Jean-Philippe Theberge <[e-mail]>
;;              
;; Thanks: Alex Schroeder <[e-mail]> for maintaining the package at some time
;;         The peoples at #[e-mail] for numerous help
;;         RMS for emacs and the GNU project.
;;
;; Keywords: Multimedia

;;             C-t a enter in thumbs-mode with all files in current-directory
;; In thumbs-mode, pressing <return> on a image will bring you in image view mode
;; for that image.  C-h m will give you a list of available keybinding.

;;; History:
;; 

;;; Code:

(require 'dired)

;; 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

  "Prefix to add to temp files."
  :type 'string
  :group 'thumbs)

;; Initialize some variable, for later use.
(defvar thumbs-temp-file 
  (concat thumbs-temp-dir thumbs-temp-prefix) 
  "Temporary filesname for images.")

(defvar thumbs-current-tmp-filename 
  nil 
  "Temporary filename of current image.")
(defvar thumbs-current-image-filename 
  nil
  "Filename of current image.")
(defvar thumbs-current-image-size 
  nil
  "Size of current image.")
(defvar thumbs-image-num 
  nil
  "Number of current image.")
(defvar thumbs-current-dir 
  nil
  "Current directory.")
(defvar thumbs-markedL 
  nil
  "List of marked files.")

;; Make sure auto-image-file-mode is ON.
(auto-image-file-mode t)

(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))))))

(defun thumbs-gensym (&optional arg)
  "Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"Thumbs\"."
  (let ((prefix (if (stringp arg) arg "Thumbs"))
	(num (if (integerp arg) arg
	       (prog1 
		   thumbs-gensym-counter
		 (setq thumbs-gensym-counter (1+ thumbs-gensym-counter))))))
    (make-symbol (format "%s%d" prefix num))))

(defun thumbs-cleanup-thumbsdir ()

  (cons
   (thumbs-increment-image-size-element (car s)
					thumbs-image-resizing-step)
   (thumbs-increment-image-size-element (cdr s)
					thumbs-image-resizing-step)))
 
(defun thumbs-decrement-image-size (s)
  "Decrement S (a cons of width x heigh)."
  (cons
   (thumbs-decrement-image-size-element (car s)
					thumbs-image-resizing-step)

  "Resize image in current buffer.
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 
    (apply 'delete-file
	   (directory-files
	    thumbs-temp-dir t
	    thumbs-temp-prefix)))
  (let ((buffer-read-only nil)

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

	 (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))
  
(defun thumbs-image-type (img)
  "Return image type from filename IMG."
  (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg)
	((string-match ".*\\.xpm\\'" img) 'xpm)
	((string-match ".*\\.xbm\\'" img) 'xbm)

(defun thumbs-file-size (img)
  (let ((i (image-size (find-image `((:type ,(thumbs-image-type img) :file ,img))) t)))
    (concat (number-to-string (round (car i)))
	    "x"
	    (number-to-string (round (cdr i))))))
  
;;;###autoload
(defun thumbs-find-thumb (img)
  "Display the thumbnail for IMG."
  (interactive "f")
  (find-file (thumbs-make-thumb img)))

;;;###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)) "*"))
  (thumbs-view-image-mode)
  (let ((inhibit-read-only t))

  (shell-command (replace-regexp-in-string
		  "\\*"
		  (shell-quote-argument (expand-file-name img))
		  thumbs-setroot-command nil t))
  (run-hooks 'thumbs-after-setroot-hook))
   
(defun thumbs-set-image-at-point-to-root-window ()
  "Set the image at point as the desktop wallpaper."
  (interactive)
  (thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL))))

  (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

(defun thumbs-modify-image (action &optional arg)
  "Call convert to do ACTION on image with argument ARG.
ACTION and ARG should be legal convert command."

55206:c2c29cafaa74

;;; thumbs.el --- Thumbnails previewer for images files
;;;
;; Author: Jean-Philippe Theberge <[e-mail]>
;;
;; Thanks: Alex Schroeder <[e-mail]> for maintaining the package at some time
;;         The peoples at #[e-mail] for numerous help
;;         RMS for emacs and the GNU project.
;;
;; Keywords: Multimedia

;;             C-t a enter in thumbs-mode with all files in current-directory
;; In thumbs-mode, pressing <return> on a image will bring you in image view mode
;; for that image.  C-h m will give you a list of available keybinding.

;;; History:
;;

;;; Code:

(require 'dired)

;; 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

  "Prefix to add to temp files."
  :type 'string
  :group 'thumbs)

;; Initialize some variable, for later use.
(defvar thumbs-temp-file
  (concat thumbs-temp-dir thumbs-temp-prefix)
  "Temporary filesname for images.")

(defvar thumbs-current-tmp-filename
  nil
  "Temporary filename of current image.")
(defvar thumbs-current-image-filename
  nil
  "Filename of current image.")
(defvar thumbs-current-image-size
  nil
  "Size of current image.")
(defvar thumbs-image-num
  nil
  "Number of current image.")
(defvar thumbs-current-dir
  nil
  "Current directory.")
(defvar thumbs-markedL
  nil
  "List of marked files.")

;; Make sure auto-image-file-mode is ON.
(auto-image-file-mode t)

(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 'caddar))
  (defun caddar (x)
    "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
    (car (cdr (cdr (car x))))))

(defun thumbs-gensym (&optional arg)
  "Generate a new uninterned symbol.
The name is made by appending a number to PREFIX, default \"Thumbs\"."
  (let ((prefix (if (stringp arg) arg "Thumbs"))
	(num (if (integerp arg) arg
	       (prog1
		   thumbs-gensym-counter
		 (setq thumbs-gensym-counter (1+ thumbs-gensym-counter))))))
    (make-symbol (format "%s%d" prefix num))))

(defun thumbs-cleanup-thumbsdir ()

  (cons
   (thumbs-increment-image-size-element (car s)
					thumbs-image-resizing-step)
   (thumbs-increment-image-size-element (cdr s)
					thumbs-image-resizing-step)))

(defun thumbs-decrement-image-size (s)
  "Decrement S (a cons of width x heigh)."
  (cons
   (thumbs-decrement-image-size-element (car s)
					thumbs-image-resizing-step)

  "Resize image in current buffer.
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
    (apply 'delete-file
	   (directory-files
	    thumbs-temp-dir t
	    thumbs-temp-prefix)))
  (let ((buffer-read-only nil)

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

(defun thumbs-resize-image-size-down ()
  "Resize image (smaller)."
  (interactive)
  (thumbs-resize-image nil))

	 (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))

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

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

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

;;;###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)) "*"))
  (thumbs-view-image-mode)
  (let ((inhibit-read-only t))

  (shell-command (replace-regexp-in-string
		  "\\*"
		  (shell-quote-argument (expand-file-name img))
		  thumbs-setroot-command nil t))
  (run-hooks 'thumbs-after-setroot-hook))

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

  (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

(defun thumbs-modify-image (action &optional arg)
  "Call convert to do ACTION on image with argument ARG.
ACTION and ARG should be legal convert command."