diff options
| -rw-r--r-- | lisp/ChangeLog | 6 | ||||
| -rw-r--r-- | lisp/thumbs.el | 736 |
2 files changed, 742 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index bec9cb224e4..3c09c5f6556 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,9 @@ | |||
| 1 | 2004-02-28 Richard M. Stallman <rms@gnu.org> | ||
| 2 | |||
| 3 | * term.el (term-mouse-paste): Call mouse-set-point. | ||
| 4 | |||
| 5 | * thumbs.el: New file. | ||
| 6 | |||
| 1 | 2004-02-28 Juri Linkov <juri@jurta.org> | 7 | 2004-02-28 Juri Linkov <juri@jurta.org> |
| 2 | 8 | ||
| 3 | * ffap.el (dired-at-point): Additional writability test for | 9 | * ffap.el (dired-at-point): Additional writability test for |
diff --git a/lisp/thumbs.el b/lisp/thumbs.el new file mode 100644 index 00000000000..d7d8a0f58b2 --- /dev/null +++ b/lisp/thumbs.el | |||
| @@ -0,0 +1,736 @@ | |||
| 1 | ;;; thumbs.el --- Thumbnails previewer for images files | ||
| 2 | ;;; | ||
| 3 | ;; Author: Jean-Philippe Theberge <jphiltheberge@videotron.ca> | ||
| 4 | ;; | ||
| 5 | ;; Thanks: Alex Schroeder <alex@gnu.org> for maintaining the package at some time | ||
| 6 | ;; The peoples at #emacs@freenode.net for numerous help | ||
| 7 | ;; RMS for emacs and the GNU project. | ||
| 8 | ;; | ||
| 9 | ;; Keywords: Multimedia | ||
| 10 | |||
| 11 | (defconst thumbs-version "2.0") | ||
| 12 | |||
| 13 | ;; This file is part of GNU Emacs. | ||
| 14 | |||
| 15 | ;; GNU Emacs is free software; you can redistribute it and/or modify | ||
| 16 | ;; it under the terms of the GNU General Public License as published by | ||
| 17 | ;; the Free Software Foundation; either version 2, or (at your option) | ||
| 18 | ;; any later version. | ||
| 19 | |||
| 20 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 21 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 22 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 23 | ;; GNU General Public License for more details. | ||
| 24 | |||
| 25 | ;; You should have received a copy of the GNU General Public License | ||
| 26 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | ||
| 27 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | ||
| 28 | ;; Boston, MA 02111-1307, USA. | ||
| 29 | |||
| 30 | ;;; Commentary: | ||
| 31 | |||
| 32 | ;; This package create two new mode: thumbs-mode and | ||
| 33 | ;; thumbs-view-image-mode. It is used for images browsing and viewing | ||
| 34 | ;; from within emacs. Minimal image manipulation functions are also | ||
| 35 | ;; available via external programs. | ||
| 36 | ;; | ||
| 37 | ;; The 'convert' program from 'ImageMagick' | ||
| 38 | ;; [URL:http://www.imagemagick.org/] is required. | ||
| 39 | ;; | ||
| 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | ||
| 41 | ;; CHANGELOG | ||
| 42 | ;; | ||
| 43 | ;; This is version 2.0 | ||
| 44 | ;; | ||
| 45 | ;; USAGE | ||
| 46 | ;; | ||
| 47 | ;; Type M-x thumbs RET DIR RET to view the directory DIR in Thumbs mode. | ||
| 48 | ;; That should be a directory containing image files. | ||
| 49 | ;; from dired, C-t m enter in thumbs-mode with all marked files | ||
| 50 | ;; C-t a enter in thumbs-mode with all files in current-directory | ||
| 51 | ;; In thumbs-mode, pressing <return> on a image will bring you in image view mode | ||
| 52 | ;; for that image. C-h m will give you a list of available keybinding. | ||
| 53 | |||
| 54 | ;;; History: | ||
| 55 | ;; | ||
| 56 | |||
| 57 | ;;; Code: | ||
| 58 | |||
| 59 | (require 'dired) | ||
| 60 | |||
| 61 | ;; Abort if in-line imaging isn't supported (i.e. Emacs-20.7) | ||
| 62 | |||
| 63 | (when (not (display-images-p)) | ||
| 64 | (error "Your Emacs version (%S) doesn't support in-line images, | ||
| 65 | was not compiled with image support or is run in console mode. | ||
| 66 | Upgrade to Emacs 21.1 or newer, compile it with image support | ||
| 67 | or use a window-system" | ||
| 68 | emacs-version)) | ||
| 69 | |||
| 70 | ;; CUSTOMIZATIONS | ||
| 71 | |||
| 72 | (defgroup thumbs nil | ||
| 73 | "Thumbnails previewer." | ||
| 74 | :group 'multimedia) | ||
| 75 | |||
| 76 | (defcustom thumbs-thumbsdir | ||
| 77 | (expand-file-name "~/.emacs-thumbs") | ||
| 78 | "*Directory to store thumbnails." | ||
| 79 | :type 'directory | ||
| 80 | :group 'thumbs) | ||
| 81 | |||
| 82 | (defcustom thumbs-geometry "100x100" | ||
| 83 | "*Size of thumbnails." | ||
| 84 | :type 'string | ||
| 85 | :group 'thumbs) | ||
| 86 | |||
| 87 | (defcustom thumbs-per-line 5 | ||
| 88 | "*Number of thumbnails per line to show in directory." | ||
| 89 | :type 'string | ||
| 90 | :group 'thumbs) | ||
| 91 | |||
| 92 | (defcustom thumbs-thumbsdir-max-size 50000000 | ||
| 93 | "Max size for thumbnails directory. | ||
| 94 | When it reach that size (in bytes), a warning is send." | ||
| 95 | :type 'string | ||
| 96 | :group 'thumbs) | ||
| 97 | |||
| 98 | (defcustom thumbs-conversion-program | ||
| 99 | (if (equal 'windows-nt system-type) | ||
| 100 | "convert.exe" | ||
| 101 | (or (executable-find "convert") | ||
| 102 | "/usr/X11R6/bin/convert")) | ||
| 103 | "*Name of conversion program for thumbnails generation. | ||
| 104 | It must be 'convert'." | ||
| 105 | :type 'string | ||
| 106 | :group 'thumbs) | ||
| 107 | |||
| 108 | (defcustom thumbs-setroot-command | ||
| 109 | "xloadimage -onroot -fullscreen *" | ||
| 110 | "Command to set the root window." | ||
| 111 | :type 'string | ||
| 112 | :group 'thumbs) | ||
| 113 | |||
| 114 | (defcustom thumbs-relief 5 | ||
| 115 | "*Size of button-like border around thumbnails." | ||
| 116 | :type 'string | ||
| 117 | :group 'thumbs) | ||
| 118 | |||
| 119 | (defcustom thumbs-margin 2 | ||
| 120 | "*Size of the margin around thumbnails. | ||
| 121 | This is where you see the cursor." | ||
| 122 | :type 'string | ||
| 123 | :group 'thumbs) | ||
| 124 | |||
| 125 | (defcustom thumbs-thumbsdir-auto-clean t | ||
| 126 | "If set, delete older file in the thumbnails directory. | ||
| 127 | Deletion is done at load time when the directory size is bigger | ||
| 128 | than 'thumbs-thumbsdir-max-size'." | ||
| 129 | :type 'boolean | ||
| 130 | :group 'thumbs) | ||
| 131 | |||
| 132 | (defcustom thumbs-image-resizing-step 10 | ||
| 133 | "Step by wich to resize image." | ||
| 134 | :type 'string | ||
| 135 | :group 'thumbs) | ||
| 136 | |||
| 137 | (defcustom thumbs-temp-dir | ||
| 138 | "/tmp/" | ||
| 139 | "Temporary directory to use. | ||
| 140 | Leaving it to default '/tmp/' can let another user | ||
| 141 | see some of your images." | ||
| 142 | :type 'directory | ||
| 143 | :group 'thumbs) | ||
| 144 | |||
| 145 | (defcustom thumbs-temp-prefix "emacsthumbs" | ||
| 146 | "Prefix to add to temp files." | ||
| 147 | :type 'string | ||
| 148 | :group 'thumbs) | ||
| 149 | |||
| 150 | ;; Initialize some variable, for later use. | ||
| 151 | (defvar thumbs-temp-file | ||
| 152 | (concat thumbs-temp-dir thumbs-temp-prefix) | ||
| 153 | "Temporary filesname for images.") | ||
| 154 | |||
| 155 | (defvar thumbs-current-tmp-filename | ||
| 156 | nil | ||
| 157 | "Temporary filename of current image.") | ||
| 158 | (defvar thumbs-current-image-filename | ||
| 159 | nil | ||
| 160 | "Filename of current image.") | ||
| 161 | (defvar thumbs-current-image-size | ||
| 162 | nil | ||
| 163 | "Size of current image.") | ||
| 164 | (defvar thumbs-image-num | ||
| 165 | nil | ||
| 166 | "Number of current image.") | ||
| 167 | (defvar thumbs-current-dir | ||
| 168 | nil | ||
| 169 | "Current directory.") | ||
| 170 | (defvar thumbs-markedL | ||
| 171 | nil | ||
| 172 | "List of marked files.") | ||
| 173 | |||
| 174 | ;; Make sure auto-image-file-mode is ON. | ||
| 175 | (auto-image-file-mode t) | ||
| 176 | |||
| 177 | ;; Create the thumbs directory if it does not exists. | ||
| 178 | (setq thumbs-thumbsdir (expand-file-name thumbs-thumbsdir)) | ||
| 179 | |||
| 180 | (when (not (file-directory-p thumbs-thumbsdir)) | ||
| 181 | (progn | ||
| 182 | (make-directory thumbs-thumbsdir) | ||
| 183 | (message "Creating thumbnails directory"))) | ||
| 184 | |||
| 185 | (when (not (fboundp 'ignore-errors)) | ||
| 186 | (defmacro ignore-errors (&rest body) | ||
| 187 | "Execute FORMS; if anz error occurs, return nil. | ||
| 188 | Otherwise, return result of last FORM." | ||
| 189 | (let ((err (thumbs-gensym))) | ||
| 190 | (list 'condition-case err (cons 'progn body) '(error nil))))) | ||
| 191 | |||
| 192 | (when (not (fboundp 'time-less-p)) | ||
| 193 | (defun time-less-p (t1 t2) | ||
| 194 | "Say whether time T1 is less than time T2." | ||
| 195 | (or (< (car t1) (car t2)) | ||
| 196 | (and (= (car t1) (car t2)) | ||
| 197 | (< (nth 1 t1) (nth 1 t2)))))) | ||
| 198 | |||
| 199 | (when (not (fboundp 'caddar)) | ||
| 200 | (defun caddar (x) | ||
| 201 | "Return the `car' of the `cdr' of the `cdr' of the `car' of X." | ||
| 202 | (car (cdr (cdr (car x)))))) | ||
| 203 | |||
| 204 | (defvar thumbs-gensym-counter 0) | ||
| 205 | |||
| 206 | (defun thumbs-gensym (&optional arg) | ||
| 207 | "Generate a new uninterned symbol. | ||
| 208 | The name is made by appending a number to PREFIX, default \"Thumbs\"." | ||
| 209 | (let ((prefix (if (stringp arg) arg "Thumbs")) | ||
| 210 | (num (if (integerp arg) arg | ||
| 211 | (prog1 | ||
| 212 | thumbs-gensym-counter | ||
| 213 | (setq thumbs-gensym-counter (1+ thumbs-gensym-counter)))))) | ||
| 214 | (make-symbol (format "%s%d" prefix num)))) | ||
| 215 | |||
| 216 | (defun thumbs-cleanup-thumbsdir () | ||
| 217 | "Clean the thumbnails directory. | ||
| 218 | If the total size of all files in 'thumbs-thumbsdir' is bigger than | ||
| 219 | 'thumbs-thumbsdir-max-size', files are deleted until the max size is | ||
| 220 | reached." | ||
| 221 | (let* ((filesL | ||
| 222 | (sort | ||
| 223 | (mapcar | ||
| 224 | (lambda (f) | ||
| 225 | (let ((fattribsL (file-attributes f))) | ||
| 226 | `(,(nth 4 fattribsL) ,(nth 7 fattribsL) ,f))) | ||
| 227 | (directory-files thumbs-thumbsdir t (image-file-name-regexp))) | ||
| 228 | '(lambda (l1 l2) (time-less-p (car l1)(car l2))))) | ||
| 229 | (dirsize (apply '+ (mapcar (lambda (x) (cadr x)) filesL)))) | ||
| 230 | (while (> dirsize thumbs-thumbsdir-max-size) | ||
| 231 | (progn | ||
| 232 | (message "Deleting file %s" (caddar filesL))) | ||
| 233 | (delete-file (caddar filesL)) | ||
| 234 | (setq dirsize (- dirsize (cadar filesL))) | ||
| 235 | (setq filesL (cdr filesL))))) | ||
| 236 | |||
| 237 | ;; Check the thumbsnail directory size and clean it if necessary. | ||
| 238 | (when thumbs-thumbsdir-auto-clean | ||
| 239 | (thumbs-cleanup-thumbsdir)) | ||
| 240 | |||
| 241 | (defun thumbs-call-convert (filein fileout action | ||
| 242 | &optional arg output-format action-prefix) | ||
| 243 | "Call the convert program. | ||
| 244 | FILEIN is the input file, | ||
| 245 | FILEOUT is the output file, | ||
| 246 | ACTION is the command to send to convert. | ||
| 247 | Optional argument are: | ||
| 248 | ARG any arguments to the ACTION command, | ||
| 249 | OUTPUT-FORMAT is the file format to output, default is jpeg | ||
| 250 | ACTION-PREFIX is the symbol to place before the ACTION command | ||
| 251 | (default to '-' but can sometime be '+')." | ||
| 252 | (let ((command (format "%s %s%s %s \"%s\" \"%s:%s\"" | ||
| 253 | thumbs-conversion-program | ||
| 254 | (or action-prefix "-") | ||
| 255 | action | ||
| 256 | (or arg "") | ||
| 257 | filein | ||
| 258 | (or output-format "jpeg") | ||
| 259 | fileout))) | ||
| 260 | (shell-command command))) | ||
| 261 | |||
| 262 | (defun thumbs-increment-image-size-element (n d) | ||
| 263 | "Increment number N by D percent." | ||
| 264 | (round (+ n (/ (* d n) 100)))) | ||
| 265 | |||
| 266 | (defun thumbs-decrement-image-size-element (n d) | ||
| 267 | "Decrement number N by D percent." | ||
| 268 | (round (- n (/ (* d n) 100)))) | ||
| 269 | |||
| 270 | (defun thumbs-increment-image-size (s) | ||
| 271 | "Increment S (a cons of width x heigh)." | ||
| 272 | (cons | ||
| 273 | (thumbs-increment-image-size-element (car s) | ||
| 274 | thumbs-image-resizing-step) | ||
| 275 | (thumbs-increment-image-size-element (cdr s) | ||
| 276 | thumbs-image-resizing-step))) | ||
| 277 | |||
| 278 | (defun thumbs-decrement-image-size (s) | ||
| 279 | "Decrement S (a cons of width x heigh)." | ||
| 280 | (cons | ||
| 281 | (thumbs-decrement-image-size-element (car s) | ||
| 282 | thumbs-image-resizing-step) | ||
| 283 | (thumbs-decrement-image-size-element (cdr s) | ||
| 284 | thumbs-image-resizing-step))) | ||
| 285 | |||
| 286 | (defun thumbs-resize-image (&optional increment size) | ||
| 287 | "Resize image in current buffer. | ||
| 288 | if INCREMENT is set, make the image bigger, else smaller. | ||
| 289 | Or, alternatively, a SIZE may be specified." | ||
| 290 | (interactive) | ||
| 291 | ;; cleaning of old temp file | ||
| 292 | (ignore-errors | ||
| 293 | (apply 'delete-file | ||
| 294 | (directory-files | ||
| 295 | thumbs-temp-dir t | ||
| 296 | thumbs-temp-prefix))) | ||
| 297 | (let ((buffer-read-only nil) | ||
| 298 | (x (if size | ||
| 299 | size | ||
| 300 | (if increment | ||
| 301 | (thumbs-increment-image-size | ||
| 302 | thumbs-current-image-size) | ||
| 303 | (thumbs-decrement-image-size | ||
| 304 | thumbs-current-image-size)))) | ||
| 305 | (tmp (format "%s%s.jpg" thumbs-temp-file (thumbs-gensym)))) | ||
| 306 | (erase-buffer) | ||
| 307 | (thumbs-call-convert thumbs-current-image-filename | ||
| 308 | tmp "sample" | ||
| 309 | (concat (number-to-string (car x)) "x" | ||
| 310 | (number-to-string (cdr x)))) | ||
| 311 | (thumbs-insert-image tmp 'jpeg 0) | ||
| 312 | (setq thumbs-current-tmp-filename tmp))) | ||
| 313 | |||
| 314 | (defun thumbs-resize-interactive (width height) | ||
| 315 | "Resize Image interactively to specified WIDTH and HEIGHT." | ||
| 316 | (interactive "nWidth: \nnHeight: ") | ||
| 317 | (thumbs-resize-image nil (cons width height))) | ||
| 318 | |||
| 319 | (defun thumbs-resize-image-size-down () | ||
| 320 | "Resize image (smaller)." | ||
| 321 | (interactive) | ||
| 322 | (thumbs-resize-image nil)) | ||
| 323 | |||
| 324 | (defun thumbs-resize-image-size-up () | ||
| 325 | "Resize image (bigger)." | ||
| 326 | (interactive) | ||
| 327 | (thumbs-resize-image t)) | ||
| 328 | |||
| 329 | (defun thumbs-subst-char-in-string (orig rep string) | ||
| 330 | "Replace occurrences of character ORIG with character REP in STRING. | ||
| 331 | Return the resulting (new) string. -- (defun borowed to Dave Love)" | ||
| 332 | (let ((string (copy-sequence string)) | ||
| 333 | (l (length string)) | ||
| 334 | (i 0)) | ||
| 335 | (while (< i l) | ||
| 336 | (if (= (aref string i) orig) | ||
| 337 | (aset string i rep)) | ||
| 338 | (setq i (1+ i))) | ||
| 339 | string)) | ||
| 340 | |||
| 341 | (defun thumbs-thumbname (img) | ||
| 342 | "Return a thumbnail name for the image IMG." | ||
| 343 | (concat thumbs-thumbsdir "/" | ||
| 344 | (thumbs-subst-char-in-string | ||
| 345 | ?\ ?\_ | ||
| 346 | (apply | ||
| 347 | 'concat | ||
| 348 | (split-string | ||
| 349 | (expand-file-name img) "/"))))) | ||
| 350 | |||
| 351 | (defun thumbs-make-thumb (img) | ||
| 352 | "Create the thumbnail for IMG." | ||
| 353 | (let* ((fn (expand-file-name img)) | ||
| 354 | (tn (thumbs-thumbname img))) | ||
| 355 | (if (or (not (file-exists-p tn)) | ||
| 356 | (not (equal (thumbs-file-size tn) thumbs-geometry))) | ||
| 357 | (thumbs-call-convert fn tn "sample" thumbs-geometry)) | ||
| 358 | tn)) | ||
| 359 | |||
| 360 | (defun thumbs-image-type (img) | ||
| 361 | "Return image type from filename IMG." | ||
| 362 | (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg) | ||
| 363 | ((string-match ".*\\.xpm\\'" img) 'xpm) | ||
| 364 | ((string-match ".*\\.xbm\\'" img) 'xbm) | ||
| 365 | ((string-match ".*\\.gif\\'" img) 'gif) | ||
| 366 | ((string-match ".*\\.bmp\\'" img) 'bmp) | ||
| 367 | ((string-match ".*\\.png\\'" img) 'png) | ||
| 368 | ((string-match ".*\\.tiff?\\'" img) 'tiff))) | ||
| 369 | |||
| 370 | (defun thumbs-file-size (img) | ||
| 371 | (let ((i (image-size (find-image `((:type ,(thumbs-image-type img) :file ,img))) t))) | ||
| 372 | (concat (number-to-string (round (car i))) | ||
| 373 | "x" | ||
| 374 | (number-to-string (round (cdr i)))))) | ||
| 375 | |||
| 376 | ;;;###autoload | ||
| 377 | (defun thumbs-find-thumb (img) | ||
| 378 | "Display the thumbnail for IMG." | ||
| 379 | (interactive "f") | ||
| 380 | (find-file (thumbs-make-thumb img))) | ||
| 381 | |||
| 382 | (defun thumbs-insert-image (img type relief &optional marked) | ||
| 383 | "Insert image IMG at point. | ||
| 384 | TYPE and RELIEF will be used in constructing the image; see `image' | ||
| 385 | in the emacs-lisp manual for further documentation. | ||
| 386 | if MARKED is non-nil, the image is marked." | ||
| 387 | (let ((i `(image :type ,type | ||
| 388 | :file ,img | ||
| 389 | :relief ,relief | ||
| 390 | :conversion ,(if marked 'disabled) | ||
| 391 | :margin ,thumbs-margin))) | ||
| 392 | (insert-image i) | ||
| 393 | (setq thumbs-current-image-size | ||
| 394 | (image-size i t)))) | ||
| 395 | |||
| 396 | (defun thumbs-insert-thumb (img &optional marked) | ||
| 397 | "Insert the thumbnail for IMG at point. | ||
| 398 | if MARKED is non-nil, the image is marked" | ||
| 399 | (thumbs-insert-image | ||
| 400 | (thumbs-make-thumb img) 'jpeg thumbs-relief marked)) | ||
| 401 | |||
| 402 | (defun thumbs-do-thumbs-insertion (L) | ||
| 403 | "Insert all thumbs in list L." | ||
| 404 | (setq thumbs-fileL nil) | ||
| 405 | (let ((i 0)) | ||
| 406 | (while L | ||
| 407 | (when (= 0 (mod (setq i (1+ i)) thumbs-per-line)) | ||
| 408 | (newline)) | ||
| 409 | (setq thumbs-fileL (cons (cons (point) | ||
| 410 | (car L)) | ||
| 411 | thumbs-fileL)) | ||
| 412 | (thumbs-insert-thumb (car L) | ||
| 413 | (member (car L) thumbs-markedL)) | ||
| 414 | (setq L (cdr L))))) | ||
| 415 | |||
| 416 | (defun thumbs-show-thumbs-list (L &optional buffer-name same-window) | ||
| 417 | (funcall (if same-window 'switch-to-buffer 'pop-to-buffer) | ||
| 418 | (or buffer-name "*THUMB-View*")) | ||
| 419 | (let ((inhibit-read-only t)) | ||
| 420 | (erase-buffer) | ||
| 421 | (thumbs-mode) | ||
| 422 | (make-variable-buffer-local 'thumbs-fileL) | ||
| 423 | (setq thumbs-fileL nil) | ||
| 424 | (thumbs-do-thumbs-insertion L) | ||
| 425 | (goto-char (point-min)) | ||
| 426 | (setq thumbs-current-dir default-directory) | ||
| 427 | (make-variable-buffer-local 'thumbs-current-dir))) | ||
| 428 | |||
| 429 | ;;;###autoload | ||
| 430 | (defun thumbs-show-all-from-dir (dir &optional reg same-window) | ||
| 431 | "Make a preview buffer for all images in DIR. | ||
| 432 | Optional argument REG to select file matching a regexp, | ||
| 433 | and SAME-WINDOW to show thumbs in the same window." | ||
| 434 | (interactive "DDir: ") | ||
| 435 | (thumbs-show-thumbs-list | ||
| 436 | (directory-files dir t | ||
| 437 | (or reg (image-file-name-regexp))) | ||
| 438 | (concat "*Thumbs: " dir) same-window)) | ||
| 439 | |||
| 440 | ;;;###autoload | ||
| 441 | (defun thumbs-dired-show-marked () | ||
| 442 | "In Dired, make a thumbs buffer with all marked files." | ||
| 443 | (interactive) | ||
| 444 | (thumbs-show-thumbs-list (dired-get-marked-files) nil t)) | ||
| 445 | |||
| 446 | ;;;###autoload | ||
| 447 | (defun thumbs-dired-show-all () | ||
| 448 | "In dired, make a thumbs buffer with all files in current directory." | ||
| 449 | (interactive) | ||
| 450 | (thumbs-show-all-from-dir default-directory nil t)) | ||
| 451 | |||
| 452 | ;;;###autoload | ||
| 453 | (defalias 'thumbs 'thumbs-show-all-from-dir) | ||
| 454 | |||
| 455 | (defun thumbs-find-image (img L &optional num otherwin) | ||
| 456 | (funcall | ||
| 457 | (if otherwin 'switch-to-buffer-other-window 'switch-to-buffer) | ||
| 458 | (concat "*Image: " (file-name-nondirectory img) " - " | ||
| 459 | (number-to-string (or num 0)) "*")) | ||
| 460 | (thumbs-view-image-mode) | ||
| 461 | (let ((inhibit-read-only t)) | ||
| 462 | (setq thumbs-current-image-filename img | ||
| 463 | thumbs-current-tmp-filename nil | ||
| 464 | thumbs-image-num (or num 0)) | ||
| 465 | (make-variable-buffer-local 'thumbs-current-image-filename) | ||
| 466 | (make-variable-buffer-local 'thumbs-current-tmp-filename) | ||
| 467 | (make-variable-buffer-local 'thumbs-current-image-size) | ||
| 468 | (make-variable-buffer-local 'thumbs-image-num) | ||
| 469 | (make-variable-buffer-local 'thumbs-fileL) | ||
| 470 | (setq thumbs-fileL L) | ||
| 471 | (delete-region (point-min)(point-max)) | ||
| 472 | (thumbs-insert-image img (thumbs-image-type img) 0))) | ||
| 473 | |||
| 474 | (defun thumbs-find-image-at-point (&optional img otherwin) | ||
| 475 | "Display image IMG for thumbnail at point. | ||
| 476 | use another window it OTHERWIN is t." | ||
| 477 | (interactive) | ||
| 478 | (let* ((L thumbs-fileL) | ||
| 479 | (n (point)) | ||
| 480 | (i (or img (cdr (assoc n L))))) | ||
| 481 | (thumbs-find-image i L n otherwin))) | ||
| 482 | |||
| 483 | (defun thumbs-find-image-at-point-other-window () | ||
| 484 | "Display image for thumbnail at point in the preview buffer. | ||
| 485 | Open another window." | ||
| 486 | (interactive) | ||
| 487 | (thumbs-find-image-at-point nil t)) | ||
| 488 | |||
| 489 | (defun thumbs-call-setroot-command (img) | ||
| 490 | "Call the setroot program for IMG." | ||
| 491 | (run-hooks 'thumbs-before-setroot-hook) | ||
| 492 | (shell-command (replace-regexp-in-string | ||
| 493 | "\\*" | ||
| 494 | (shell-quote-argument (expand-file-name img)) | ||
| 495 | thumbs-setroot-command nil t)) | ||
| 496 | (run-hooks 'thumbs-after-setroot-hook)) | ||
| 497 | |||
| 498 | (defun thumbs-set-image-at-point-to-root-window () | ||
| 499 | "Set the image at point as the desktop wallpaper." | ||
| 500 | (interactive) | ||
| 501 | (thumbs-call-setroot-command (cdr (assoc (point) thumbs-fileL)))) | ||
| 502 | |||
| 503 | (defun thumbs-set-root () | ||
| 504 | "Set the current image as root." | ||
| 505 | (interactive) | ||
| 506 | (thumbs-call-setroot-command | ||
| 507 | (or thumbs-current-tmp-filename | ||
| 508 | thumbs-current-image-filename))) | ||
| 509 | |||
| 510 | (defun thumbs-delete-images () | ||
| 511 | "Delete the image at point (and it's thumbnail) (or marked files if any)." | ||
| 512 | (interactive) | ||
| 513 | (let ((f (or thumbs-markedL (list (cdr (assoc (point) thumbs-fileL)))))) | ||
| 514 | (if (yes-or-no-p "Really delete %d files?" (length f)) | ||
| 515 | (progn | ||
| 516 | (mapcar (lambda (x) | ||
| 517 | (setq thumbs-fileL (delete (rassoc x thumbs-fileL) thumbs-fileL)) | ||
| 518 | (delete-file x) | ||
| 519 | (delete-file (thumbs-thumbname x))) f) | ||
| 520 | (thumbs-redraw-buffer))))) | ||
| 521 | |||
| 522 | (defun thumbs-kill-buffer () | ||
| 523 | "Kill the current buffer." | ||
| 524 | (interactive) | ||
| 525 | (let ((buffer (current-buffer))) | ||
| 526 | (ignore-errors (delete-window (selected-window))) | ||
| 527 | (kill-buffer buffer))) | ||
| 528 | |||
| 529 | (defun thumbs-show-image-num (num) | ||
| 530 | "Show the image with number NUM." | ||
| 531 | (let ((inhibit-read-only t)) | ||
| 532 | (delete-region (point-min)(point-max)) | ||
| 533 | (let ((i (cdr (assoc num thumbs-fileL)))) | ||
| 534 | (thumbs-insert-image i (thumbs-image-type i) 0) | ||
| 535 | (sleep-for 2) | ||
| 536 | (rename-buffer (concat "*Image: " | ||
| 537 | (file-name-nondirectory i) | ||
| 538 | " - " | ||
| 539 | (number-to-string num) "*"))) | ||
| 540 | (setq thumbs-image-num num | ||
| 541 | thumbs-current-image-filename i))) | ||
| 542 | |||
| 543 | (defun thumbs-next-image () | ||
| 544 | "Show next image." | ||
| 545 | (interactive) | ||
| 546 | (let* ((i (1+ thumbs-image-num)) | ||
| 547 | (l (caar thumbs-fileL)) | ||
| 548 | (num | ||
| 549 | (cond ((assoc i thumbs-fileL) i) | ||
| 550 | ((>= i l) 1) | ||
| 551 | (t (1+ i))))) | ||
| 552 | (thumbs-show-image-num num))) | ||
| 553 | |||
| 554 | (defun thumbs-previous-image () | ||
| 555 | "Show the previous image." | ||
| 556 | (interactive) | ||
| 557 | (let* ((i (- thumbs-image-num 1)) | ||
| 558 | (l (caar thumbs-fileL)) | ||
| 559 | (num | ||
| 560 | (cond ((assoc i thumbs-fileL) i) | ||
| 561 | ((<= i 1) l) | ||
| 562 | (t (- i 1))))) | ||
| 563 | (thumbs-show-image-num num))) | ||
| 564 | |||
| 565 | (defun thumbs-redraw-buffer () | ||
| 566 | "Redraw the current thumbs buffer." | ||
| 567 | (let ((p (point)) | ||
| 568 | (inhibit-read-only t)) | ||
| 569 | (delete-region (point-min)(point-max)) | ||
| 570 | (thumbs-do-thumbs-insertion (reverse (mapcar 'cdr thumbs-fileL))) | ||
| 571 | (goto-char (1+ p)))) | ||
| 572 | |||
| 573 | (defun thumbs-mark () | ||
| 574 | "Mark the image at point." | ||
| 575 | (interactive) | ||
| 576 | (setq thumbs-markedL (cons (cdr (assoc (point) thumbs-fileL)) thumbs-markedL)) | ||
| 577 | (let ((inhibit-read-only t)) | ||
| 578 | (delete-char 1) | ||
| 579 | (thumbs-insert-thumb (cdr (assoc (point) thumbs-fileL)) t)) | ||
| 580 | (when (eolp)(forward-char))) | ||
| 581 | |||
| 582 | ;; Image modification routines | ||
| 583 | |||
| 584 | (defun thumbs-modify-image (action &optional arg) | ||
| 585 | "Call convert to do ACTION on image with argument ARG. | ||
| 586 | ACTION and ARG should be legal convert command." | ||
| 587 | (interactive "sAction: \nsValue: ") | ||
| 588 | ;; cleaning of old temp file | ||
| 589 | (mapc 'delete-file | ||
| 590 | (directory-files | ||
| 591 | thumbs-temp-dir | ||
| 592 | t | ||
| 593 | thumbs-temp-prefix)) | ||
| 594 | (let ((buffer-read-only nil) | ||
| 595 | (tmp (format "%s%s.jpg" thumbs-temp-file (thumbs-gensym)))) | ||
| 596 | (erase-buffer) | ||
| 597 | (thumbs-call-convert thumbs-current-image-filename | ||
| 598 | tmp | ||
| 599 | action | ||
| 600 | (or arg "")) | ||
| 601 | (thumbs-insert-image tmp 'jpeg 0) | ||
| 602 | (setq thumbs-current-tmp-filename tmp))) | ||
| 603 | |||
| 604 | (defun thumbs-emboss-image (emboss) | ||
| 605 | "Emboss the image with value EMBOSS." | ||
| 606 | (interactive "nEmboss value: ") | ||
| 607 | (if (or (< emboss 3)(> emboss 31)(evenp emboss)) | ||
| 608 | (error "Arg must be a odd number between 3 and 31")) | ||
| 609 | (thumbs-modify-image "emboss" (number-to-string emboss))) | ||
| 610 | |||
| 611 | (defun thumbs-monochrome-image () | ||
| 612 | "Turn the image to monochrome." | ||
| 613 | (interactive) | ||
| 614 | (thumbs-modify-image "monochrome")) | ||
| 615 | |||
| 616 | (defun thumbs-negate-image () | ||
| 617 | "Negate the image." | ||
| 618 | (interactive) | ||
| 619 | (thumbs-modify-image "negate")) | ||
| 620 | |||
| 621 | (defun thumbs-rotate-left () | ||
| 622 | "Rotate the image 90 degrees counter-clockwise." | ||
| 623 | (interactive) | ||
| 624 | (thumbs-modify-image "rotate" "270")) | ||
| 625 | |||
| 626 | (defun thumbs-rotate-right () | ||
| 627 | "Rotate the image 90 degrees clockwise." | ||
| 628 | (interactive) | ||
| 629 | (thumbs-modify-image "rotate" "90")) | ||
| 630 | |||
| 631 | (defun thumbs-forward-char () | ||
| 632 | "Move forward one image." | ||
| 633 | (interactive) | ||
| 634 | (forward-char) | ||
| 635 | (when (eolp)(forward-char)) | ||
| 636 | (thumbs-show-name)) | ||
| 637 | |||
| 638 | (defun thumbs-backward-char () | ||
| 639 | "Move backward one image." | ||
| 640 | (interactive) | ||
| 641 | (forward-char -1) | ||
| 642 | (thumbs-show-name)) | ||
| 643 | |||
| 644 | (defun thumbs-forward-line () | ||
| 645 | "Move down one line." | ||
| 646 | (interactive) | ||
| 647 | (forward-line 1) | ||
| 648 | (thumbs-show-name)) | ||
| 649 | |||
| 650 | (defun thumbs-backward-line () | ||
| 651 | "Move up one line." | ||
| 652 | (interactive) | ||
| 653 | (forward-line -1) | ||
| 654 | (thumbs-show-name)) | ||
| 655 | |||
| 656 | (defun thumbs-show-name () | ||
| 657 | "Show the name of the current file." | ||
| 658 | (interactive) | ||
| 659 | (let ((f (cdr (assoc (point) thumbs-fileL)))) | ||
| 660 | (message "%s [%s]" f (thumbs-file-size f)))) | ||
| 661 | |||
| 662 | (defun thumbs-save-current-image () | ||
| 663 | "Save the current image." | ||
| 664 | (interactive) | ||
| 665 | (let ((f (or thumbs-current-tmp-filename | ||
| 666 | thumbs-current-image-filename)) | ||
| 667 | (sa (read-from-minibuffer "save file as: " | ||
| 668 | thumbs-current-image-filename))) | ||
| 669 | (copy-file f sa))) | ||
| 670 | |||
| 671 | (defun thumbs-dired () | ||
| 672 | "Use `dired' on the current thumbs directory." | ||
| 673 | (interactive) | ||
| 674 | (dired thumbs-current-dir)) | ||
| 675 | |||
| 676 | ;; thumbs-mode | ||
| 677 | |||
| 678 | (defvar thumbs-mode-map | ||
| 679 | (let ((map (make-sparse-keymap))) | ||
| 680 | (define-key map [return] 'thumbs-find-image-at-point) | ||
| 681 | (define-key map [(meta return)] 'thumbs-find-image-at-point-other-window) | ||
| 682 | (define-key map [(control return)] 'thumbs-set-image-at-point-to-root-window) | ||
| 683 | (define-key map [delete] 'thumbs-delete-images) | ||
| 684 | (define-key map [right] 'thumbs-forward-char) | ||
| 685 | (define-key map [left] 'thumbs-backward-char) | ||
| 686 | (define-key map [up] 'thumbs-backward-line) | ||
| 687 | (define-key map [down] 'thumbs-forward-line) | ||
| 688 | (define-key map "d" 'thumbs-dired) | ||
| 689 | (define-key map "m" 'thumbs-mark) | ||
| 690 | (define-key map "s" 'thumbs-show-name) | ||
| 691 | (define-key map "q" 'thumbs-kill-buffer) | ||
| 692 | map) | ||
| 693 | "Keymap for `thumbs-mode'.") | ||
| 694 | |||
| 695 | (define-derived-mode thumbs-mode | ||
| 696 | fundamental-mode "thumbs" | ||
| 697 | "Preview images in a thumbnails buffer" | ||
| 698 | (make-variable-buffer-local 'thumbs-markedL) | ||
| 699 | (setq thumbs-markedL nil)) | ||
| 700 | |||
| 701 | (defvar thumbs-view-image-mode-map | ||
| 702 | (let ((map (make-sparse-keymap))) | ||
| 703 | (define-key map [prior] 'thumbs-previous-image) | ||
| 704 | (define-key map [next] 'thumbs-next-image) | ||
| 705 | (define-key map "-" 'thumbs-resize-image-size-down) | ||
| 706 | (define-key map "+" 'thumbs-resize-image-size-up) | ||
| 707 | (define-key map "<" 'thumbs-rotate-left) | ||
| 708 | (define-key map ">" 'thumbs-rotate-right) | ||
| 709 | (define-key map "e" 'thumbs-emboss-image) | ||
| 710 | (define-key map "r" 'thumbs-resize-interactive) | ||
| 711 | (define-key map "s" 'thumbs-save-current-image) | ||
| 712 | (define-key map "q" 'thumbs-kill-buffer) | ||
| 713 | (define-key map "w" 'thunbs-set-root) | ||
| 714 | map) | ||
| 715 | "Keymap for `thumbs-view-image-mode'.") | ||
| 716 | |||
| 717 | ;; thumbs-view-image-mode | ||
| 718 | (define-derived-mode thumbs-view-image-mode | ||
| 719 | fundamental-mode "image-view-mode") | ||
| 720 | |||
| 721 | ;;;###autoload | ||
| 722 | (defun thumbs-dired-setroot () | ||
| 723 | "In dired, Call the setroot program on the image at point." | ||
| 724 | (interactive) | ||
| 725 | (thumbs-call-setroot-command (dired-get-filename))) | ||
| 726 | |||
| 727 | ;; Modif to dired mode map | ||
| 728 | (define-key dired-mode-map "\C-ta" 'thumbs-dired-show-all) | ||
| 729 | (define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked) | ||
| 730 | (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) | ||
| 731 | |||
| 732 | (provide 'thumbs) | ||
| 733 | |||
| 734 | ;;; thumbs.el ends here | ||
| 735 | |||
| 736 | |||