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