1 ;;; image-mode.el --- support for visiting image files
3 ;; Copyright (C) 2005-2011 Free Software Foundation, Inc.
5 ;; Author: Richard Stallman <rms@gnu.org>
6 ;; Keywords: multimedia
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; Defines a major mode for visiting image files
27 ;; that allows conversion between viewing the text of the file
28 ;; and viewing the file as an image. Viewing the image
29 ;; works by putting a `display' text-property on the
30 ;; image data, with the image-data still present underneath; if the
31 ;; resulting buffer file is saved to another name it will correctly save
32 ;; the image data to the new file.
37 (eval-when-compile (require 'cl
))
39 ;;; Image mode window-info management.
41 (defvar image-mode-winprops-alist t
)
42 (make-variable-buffer-local 'image-mode-winprops-alist
)
44 (defvar image-mode-new-window-functions nil
45 "Special hook run when image data is requested in a new window.
46 It is called with one argument, the initial WINPROPS.")
48 (defun image-mode-winprops (&optional window cleanup
)
49 "Return winprops of WINDOW.
50 A winprops object has the shape (WINDOW . ALIST)."
52 (setq window
(selected-window)))
53 ((not (windowp window
))
54 (error "Not a window: %s" window
)))
56 (setq image-mode-winprops-alist
57 (delq nil
(mapcar (lambda (winprop)
58 (if (window-live-p (car-safe winprop
))
60 image-mode-winprops-alist
))))
61 (let ((winprops (assq window image-mode-winprops-alist
)))
62 ;; For new windows, set defaults from the latest.
64 (setq winprops
(cons window
65 (copy-alist (cdar image-mode-winprops-alist
))))
66 (run-hook-with-args 'image-mode-new-window-functions winprops
))
67 ;; Move window to front.
68 (setq image-mode-winprops-alist
69 (cons winprops
(delq winprops image-mode-winprops-alist
)))
72 (defun image-mode-window-get (prop &optional winprops
)
73 (unless (consp winprops
) (setq winprops
(image-mode-winprops winprops
)))
74 (cdr (assq prop
(cdr winprops
))))
76 (defsetf image-mode-window-get
(prop &optional winprops
) (val)
77 `(image-mode-window-put ,prop
,val
,winprops
))
79 (defun image-mode-window-put (prop val
&optional winprops
)
80 (unless (consp winprops
) (setq winprops
(image-mode-winprops winprops
)))
81 (setcdr winprops
(cons (cons prop val
)
82 (delq (assq prop
(cdr winprops
)) (cdr winprops
)))))
84 (defun image-set-window-vscroll (vscroll)
85 (setf (image-mode-window-get 'vscroll
) vscroll
)
86 (set-window-vscroll (selected-window) vscroll
))
88 (defun image-set-window-hscroll (ncol)
89 (setf (image-mode-window-get 'hscroll
) ncol
)
90 (set-window-hscroll (selected-window) ncol
))
92 (defun image-mode-reapply-winprops ()
93 ;; When set-window-buffer, set hscroll and vscroll to what they were
94 ;; last time the image was displayed in this window.
95 (when (and (image-get-display-property)
96 (listp image-mode-winprops-alist
))
97 (let* ((winprops (image-mode-winprops nil t
))
98 (hscroll (image-mode-window-get 'hscroll winprops
))
99 (vscroll (image-mode-window-get 'vscroll winprops
)))
100 (if hscroll
(set-window-hscroll (selected-window) hscroll
))
101 (if vscroll
(set-window-vscroll (selected-window) vscroll
)))))
103 (defun image-mode-setup-winprops ()
104 ;; Record current scroll settings.
105 (unless (listp image-mode-winprops-alist
)
106 (setq image-mode-winprops-alist nil
))
107 (add-hook 'window-configuration-change-hook
108 'image-mode-reapply-winprops nil t
))
110 ;;; Image scrolling functions
112 (defun image-get-display-property ()
113 (get-char-property (point-min) 'display
114 ;; There might be different images for different displays.
115 (if (eq (window-buffer) (current-buffer))
118 (declare-function image-size
"image.c" (spec &optional pixels frame
))
120 (defun image-display-size (spec &optional pixels frame
)
121 "Wrapper around `image-size', handling slice display properties.
122 Like `image-size', the return value is (WIDTH . HEIGHT).
123 WIDTH and HEIGHT are in canonical character units if PIXELS is
124 nil, and in pixel units if PIXELS is non-nil.
126 If SPEC is an image display property, this function is equivalent
127 to `image-size'. If SPEC is a list of properties containing
128 `image' and `slice' properties, return the display size taking
129 the slice property into account. If the list contains `image'
130 but not `slice', return the `image-size' of the specified image."
131 (if (eq (car spec
) 'image
)
132 (image-size spec pixels frame
)
133 (let ((image (assoc 'image spec
))
134 (slice (assoc 'slice spec
)))
135 (cond ((and image slice
)
137 (cons (nth 3 slice
) (nth 4 slice
))
138 (cons (/ (float (nth 3 slice
)) (frame-char-width frame
))
139 (/ (float (nth 4 slice
)) (frame-char-height frame
)))))
141 (image-size image pixels frame
))
143 (error "Invalid image specification: %s" spec
))))))
145 (defun image-forward-hscroll (&optional n
)
146 "Scroll image in current window to the left by N character widths.
147 Stop if the right edge of the image is reached."
151 (image-set-window-hscroll (max 0 (+ (window-hscroll) n
))))
153 (let* ((image (image-get-display-property))
154 (edges (window-inside-edges))
155 (win-width (- (nth 2 edges
) (nth 0 edges
)))
156 (img-width (ceiling (car (image-display-size image
)))))
157 (image-set-window-hscroll (min (max 0 (- img-width win-width
))
158 (+ n
(window-hscroll))))))))
160 (defun image-backward-hscroll (&optional n
)
161 "Scroll image in current window to the right by N character widths.
162 Stop if the left edge of the image is reached."
164 (image-forward-hscroll (- n
)))
166 (defun image-next-line (&optional n
)
167 "Scroll image in current window upward by N lines.
168 Stop if the bottom edge of the image is reached."
172 (image-set-window-vscroll (max 0 (+ (window-vscroll) n
))))
174 (let* ((image (image-get-display-property))
175 (edges (window-inside-edges))
176 (win-height (- (nth 3 edges
) (nth 1 edges
)))
177 (img-height (ceiling (cdr (image-display-size image
)))))
178 (image-set-window-vscroll (min (max 0 (- img-height win-height
))
179 (+ n
(window-vscroll))))))))
181 (defun image-previous-line (&optional n
)
182 "Scroll image in current window downward by N lines.
183 Stop if the top edge of the image is reached."
185 (image-next-line (- n
)))
187 (defun image-scroll-up (&optional n
)
188 "Scroll image in current window upward by N lines.
189 Stop if the bottom edge of the image is reached.
190 If ARG is omitted or nil, scroll upward by a near full screen.
191 A near full screen is `next-screen-context-lines' less than a full screen.
192 Negative ARG means scroll downward.
193 If ARG is the atom `-', scroll downward by nearly full screen.
194 When calling from a program, supply as argument a number, nil, or `-'."
197 (let* ((edges (window-inside-edges))
198 (win-height (- (nth 3 edges
) (nth 1 edges
))))
200 (max 0 (- win-height next-screen-context-lines
)))))
202 (let* ((edges (window-inside-edges))
203 (win-height (- (nth 3 edges
) (nth 1 edges
))))
205 (min 0 (- next-screen-context-lines win-height
)))))
206 (t (image-next-line (prefix-numeric-value n
)))))
208 (defun image-scroll-down (&optional n
)
209 "Scroll image in current window downward by N lines.
210 Stop if the top edge of the image is reached.
211 If ARG is omitted or nil, scroll downward by a near full screen.
212 A near full screen is `next-screen-context-lines' less than a full screen.
213 Negative ARG means scroll upward.
214 If ARG is the atom `-', scroll upward by nearly full screen.
215 When calling from a program, supply as argument a number, nil, or `-'."
218 (let* ((edges (window-inside-edges))
219 (win-height (- (nth 3 edges
) (nth 1 edges
))))
221 (min 0 (- next-screen-context-lines win-height
)))))
223 (let* ((edges (window-inside-edges))
224 (win-height (- (nth 3 edges
) (nth 1 edges
))))
226 (max 0 (- win-height next-screen-context-lines
)))))
227 (t (image-next-line (- (prefix-numeric-value n
))))))
229 (defun image-bol (arg)
230 "Scroll horizontally to the left edge of the image in the current window.
231 With argument ARG not nil or 1, move forward ARG - 1 lines first,
232 stopping if the top or bottom edge of the image is reached."
235 (/= (setq arg
(prefix-numeric-value arg
)) 1)
236 (image-next-line (- arg
1)))
237 (image-set-window-hscroll 0))
239 (defun image-eol (arg)
240 "Scroll horizontally to the right edge of the image in the current window.
241 With argument ARG not nil or 1, move forward ARG - 1 lines first,
242 stopping if the top or bottom edge of the image is reached."
245 (/= (setq arg
(prefix-numeric-value arg
)) 1)
246 (image-next-line (- arg
1)))
247 (let* ((image (image-get-display-property))
248 (edges (window-inside-edges))
249 (win-width (- (nth 2 edges
) (nth 0 edges
)))
250 (img-width (ceiling (car (image-display-size image
)))))
251 (image-set-window-hscroll (max 0 (- img-width win-width
)))))
254 "Scroll to the top-left corner of the image in the current window."
256 (image-set-window-hscroll 0)
257 (image-set-window-vscroll 0))
260 "Scroll to the bottom-right corner of the image in the current window."
262 (let* ((image (image-get-display-property))
263 (edges (window-inside-edges))
264 (win-width (- (nth 2 edges
) (nth 0 edges
)))
265 (img-width (ceiling (car (image-display-size image
))))
266 (win-height (- (nth 3 edges
) (nth 1 edges
)))
267 (img-height (ceiling (cdr (image-display-size image
)))))
268 (image-set-window-hscroll (max 0 (- img-width win-width
)))
269 (image-set-window-vscroll (max 0 (- img-height win-height
)))))
271 ;; Adjust frame and image size.
273 (defun image-mode-fit-frame ()
274 "Fit the frame to the current image.
275 This function assumes the current frame has only one window."
276 ;; FIXME: This does not take into account decorations like mode-line,
277 ;; minibuffer, header-line, ...
279 (let* ((saved (frame-parameter nil
'image-mode-saved-size
))
280 (display (image-get-display-property))
281 (size (image-display-size display
)))
283 (eq (caar saved
) (frame-width))
284 (eq (cdar saved
) (frame-height)))
285 (progn ;; Toggle back to previous non-fitted size.
286 (set-frame-parameter nil
'image-mode-saved-size nil
)
287 (setq size
(cdr saved
)))
288 ;; Round up size, and save current size so we can toggle back to it.
289 (setcar size
(ceiling (car size
)))
290 (setcdr size
(ceiling (cdr size
)))
291 (set-frame-parameter nil
'image-mode-saved-size
292 (cons size
(cons (frame-width) (frame-height)))))
293 (set-frame-width (selected-frame) (car size
))
294 (set-frame-height (selected-frame) (cdr size
))))
298 (defvar image-type nil
300 This variable is used to display the current image type in the mode line.")
301 (make-variable-buffer-local 'image-type
)
303 (defvar image-mode-previous-major-mode nil
304 "Internal variable to keep the previous non-image major mode.")
306 (defvar image-mode-map
307 (let ((map (make-sparse-keymap)))
308 (suppress-keymap map
)
309 (define-key map
"q" 'quit-window
)
310 (define-key map
"\C-c\C-c" 'image-toggle-display
)
311 (define-key map
(kbd "SPC") 'image-scroll-up
)
312 (define-key map
(kbd "DEL") 'image-scroll-down
)
313 (define-key map
[remap forward-char
] 'image-forward-hscroll
)
314 (define-key map
[remap backward-char
] 'image-backward-hscroll
)
315 (define-key map
[remap right-char
] 'image-forward-hscroll
)
316 (define-key map
[remap left-char
] 'image-backward-hscroll
)
317 (define-key map
[remap previous-line
] 'image-previous-line
)
318 (define-key map
[remap next-line
] 'image-next-line
)
319 (define-key map
[remap scroll-up
] 'image-scroll-up
)
320 (define-key map
[remap scroll-down
] 'image-scroll-down
)
321 (define-key map
[remap scroll-up-command
] 'image-scroll-up
)
322 (define-key map
[remap scroll-down-command
] 'image-scroll-down
)
323 (define-key map
[remap move-beginning-of-line
] 'image-bol
)
324 (define-key map
[remap move-end-of-line
] 'image-eol
)
325 (define-key map
[remap beginning-of-buffer
] 'image-bob
)
326 (define-key map
[remap end-of-buffer
] 'image-eob
)
328 "Major mode keymap for viewing images in Image mode.")
330 (defvar image-minor-mode-map
331 (let ((map (make-sparse-keymap)))
332 (define-key map
"\C-c\C-c" 'image-toggle-display
)
334 "Minor mode keymap for viewing images as text in Image mode.")
336 (defvar bookmark-make-record-function
)
338 (put 'image-mode
'mode-class
'special
)
342 "Major mode for image files.
343 You can use \\<image-mode-map>\\[image-toggle-display]
344 to toggle between display as an image and display as text."
348 (unless (display-images-p)
349 (error "Display does not support images"))
351 (kill-all-local-variables)
352 (setq major-mode
'image-mode
)
354 (if (not (image-get-display-property))
356 (image-toggle-display-image)
357 ;; If attempt to display the image fails.
358 (if (not (image-get-display-property))
359 (error "Invalid image")))
360 ;; Set next vars when image is already displayed but local
361 ;; variables were cleared by kill-all-local-variables
362 (setq cursor-type nil truncate-lines t
363 image-type
(plist-get (cdr (image-get-display-property)) :type
)))
365 (setq mode-name
(if image-type
(format "Image[%s]" image-type
) "Image"))
366 (use-local-map image-mode-map
)
368 ;; Use our own bookmarking function for images.
369 (set (make-local-variable 'bookmark-make-record-function
)
370 'image-bookmark-make-record
)
372 ;; Keep track of [vh]scroll when switching buffers
373 (image-mode-setup-winprops)
375 (add-hook 'change-major-mode-hook
'image-toggle-display-text nil t
)
376 (add-hook 'after-revert-hook
'image-after-revert-hook nil t
)
377 (run-mode-hooks 'image-mode-hook
)
378 (message "%s" (concat
379 (substitute-command-keys
380 "Type \\[image-toggle-display] to view the image as ")
381 (if (image-get-display-property)
382 "text" "an image") ".")))
386 (if (called-interactively-p 'any
) 'error
'message
)
387 "Cannot display image: %s" (cdr err
)))))
390 (define-minor-mode image-minor-mode
391 "Toggle Image minor mode.
392 With arg, turn Image minor mode on if arg is positive, off otherwise.
393 It provides the key \\<image-mode-map>\\[image-toggle-display] \
394 to switch back to `image-mode'
395 to display an image file as the actual image."
396 nil
(:eval
(if image-type
(format " Image[%s]" image-type
) " Image"))
401 (add-hook 'change-major-mode-hook
(lambda () (image-minor-mode -
1)) nil t
)))
404 (defun image-mode-as-text ()
405 "Set a non-image mode as major mode in combination with image minor mode.
406 A non-image major mode found from `auto-mode-alist' or Fundamental mode
407 displays an image file as text. `image-minor-mode' provides the key
408 \\<image-mode-map>\\[image-toggle-display] to switch back to `image-mode'
409 to display an image file as the actual image.
411 You can use `image-mode-as-text' in `auto-mode-alist' when you want
412 to display an image file as text initially.
414 See commands `image-mode' and `image-minor-mode' for more information
417 ;; image-mode-as-text = normal-mode + image-minor-mode
418 (let ((previous-image-type image-type
)) ; preserve `image-type'
419 (if image-mode-previous-major-mode
420 ;; Restore previous major mode that was already found by this
421 ;; function and cached in `image-mode-previous-major-mode'
422 (funcall image-mode-previous-major-mode
)
423 (let ((auto-mode-alist
426 (unless (memq (or (car-safe (cdr elt
)) (cdr elt
))
427 '(image-mode image-mode-maybe image-mode-as-text
))
430 (magic-fallback-mode-alist
433 (unless (memq (or (car-safe (cdr elt
)) (cdr elt
))
434 '(image-mode image-mode-maybe image-mode-as-text
))
436 magic-fallback-mode-alist
))))
438 (set (make-local-variable 'image-mode-previous-major-mode
) major-mode
)))
439 ;; Restore `image-type' after `kill-all-local-variables' in `normal-mode'.
440 (setq image-type previous-image-type
)
441 ;; Enable image minor mode with `C-c C-c'.
443 ;; Show the image file as text.
444 (image-toggle-display-text)
445 (message "%s" (concat
446 (substitute-command-keys
447 "Type \\[image-toggle-display] to view the image as ")
448 (if (image-get-display-property)
449 "text" "an image") "."))))
451 (define-obsolete-function-alias 'image-mode-maybe
'image-mode
"23.2")
453 (defun image-toggle-display-text ()
454 "Show the image file as text.
455 Remove text properties that display the image."
456 (let ((inhibit-read-only t
)
458 (modified (buffer-modified-p)))
459 (remove-list-of-text-properties (point-min) (point-max)
460 '(display intangible read-nonsticky
461 read-only front-sticky
))
462 (set-buffer-modified-p modified
)
463 (if (called-interactively-p 'any
)
464 (message "Repeat this command to go back to displaying the image"))))
466 (defvar archive-superior-buffer
)
467 (defvar tar-superior-buffer
)
468 (declare-function image-flush
"image.c" (spec &optional frame
))
470 (defun image-toggle-display-image ()
471 "Show the image of the image file.
472 Turn the image data into a real image, but only if the whole file
474 (let* ((filename (buffer-file-name))
475 (data-p (not (and filename
476 (file-readable-p filename
)
477 (not (file-remote-p filename
))
478 (not (buffer-modified-p))
479 (not (and (boundp 'archive-superior-buffer
)
480 archive-superior-buffer
))
481 (not (and (boundp 'tar-superior-buffer
)
482 tar-superior-buffer
)))))
483 (file-or-data (if data-p
485 (buffer-substring-no-properties (point-min) (point-max)))
487 (type (image-type file-or-data nil data-p
))
488 (image0 (create-animated-image file-or-data type data-p
))
489 (image (append image0
490 (image-transform-properties image0
)
495 rear-nonsticky
(display intangible
)
496 read-only t front-sticky
(read-only)))
497 (inhibit-read-only t
)
499 (modified (buffer-modified-p)))
501 (let ((buffer-file-truename nil
)) ; avoid changing dir mtime by lock_file
502 (add-text-properties (point-min) (point-max) props
)
503 (restore-buffer-modified-p modified
))
504 ;; Inhibit the cursor when the buffer contains only an image,
505 ;; because cursors look very strange on top of images.
506 (setq cursor-type nil
)
507 ;; This just makes the arrow displayed in the right fringe
508 ;; area look correct when the image is wider than the window.
509 (setq truncate-lines t
)
510 ;; Allow navigation of large images
511 (set (make-local-variable 'auto-hscroll-mode
) nil
)
512 (setq image-type type
)
513 (if (eq major-mode
'image-mode
)
514 (setq mode-name
(format "Image[%s]" type
)))
515 (if (called-interactively-p 'any
)
516 (message "Repeat this command to go back to displaying the file as text"))))
518 (defun image-toggle-display ()
519 "Start or stop displaying an image file as the actual image.
520 This command toggles between `image-mode-as-text' showing the text of
521 the image file and `image-mode' showing the image as an image."
523 (if (image-get-display-property)
527 (defun image-after-revert-hook ()
528 (when (image-get-display-property)
529 (image-toggle-display-text)
530 ;; Update image display.
531 (redraw-frame (selected-frame))
532 (image-toggle-display-image)))
535 ;;; Support for bookmark.el
536 (declare-function bookmark-make-record-default
537 "bookmark" (&optional no-file no-context posn
))
538 (declare-function bookmark-prop-get
"bookmark" (bookmark prop
))
539 (declare-function bookmark-default-handler
"bookmark" (bmk))
541 (defun image-bookmark-make-record ()
542 `(,@(bookmark-make-record-default nil
'no-context
0)
543 (image-type .
,image-type
)
544 (handler . image-bookmark-jump
)))
547 (defun image-bookmark-jump (bmk)
548 ;; This implements the `handler' function interface for record type
549 ;; returned by `bookmark-make-record-function', which see.
550 (prog1 (bookmark-default-handler bmk
)
551 (when (not (string= image-type
(bookmark-prop-get bmk
'image-type
)))
552 (image-toggle-display))))
555 (defvar image-transform-minor-mode-map
556 (let ((map (make-sparse-keymap)))
557 ; (define-key map [(control ?+)] 'image-scale-in)
558 ; (define-key map [(control ?-)] 'image-scale-out)
559 ; (define-key map [(control ?=)] 'image-scale-none)
560 ;; (define-key map "c f h" 'image-scale-fit-height)
561 ;; (define-key map "c ]" 'image-rotate-right)
563 "Minor mode keymap for transforming the view of images Image mode.")
565 (define-minor-mode image-transform-mode
566 "minor mode for scaleing and rotation"
567 nil
"image-transform"
568 image-transform-minor-mode-map
)
570 (defvar image-transform-resize nil
571 "The image resize operation. See the command
572 `image-transform-set-scale' for more information." )
574 (defvar image-transform-rotation
0.0)
577 (defun image-transform-properties (display)
578 "Calculate the display properties for transformations; scaling
581 ((size (image-size display t
))
584 ((and (numberp image-transform-resize
) (eq 100 image-transform-resize
))
586 ((numberp image-transform-resize
)
587 (* image-transform-resize
(cdr size
)))
588 ((eq image-transform-resize
'fit-height
)
589 (- (nth 3 (window-inside-pixel-edges)) (nth 1 (window-inside-pixel-edges))))
591 (width (if (eq image-transform-resize
'fit-width
)
592 (- (nth 2 (window-inside-pixel-edges)) (nth 0 (window-inside-pixel-edges))))))
594 `(,@(if height
(list :height height
))
595 ,@(if width
(list :width width
))
596 ,@(if (not (equal 0.0 image-transform-rotation
))
597 (list :rotation image-transform-rotation
))
598 ;;TODO fit-to-* should consider the rotation angle
601 (defun image-transform-set-scale (scale)
602 "SCALE sets the scaling for images. "
603 (interactive "nscale:")
604 (image-transform-set-resize (float scale
)))
606 (defun image-transform-fit-to-height ()
607 "Fit image height to window height. "
609 (image-transform-set-resize 'fit-height
))
611 (defun image-transform-fit-to-width ()
612 "Fit image width to window width. "
614 (image-transform-set-resize 'fit-width
))
616 (defun image-transform-set-resize (resize)
617 "Set the resize mode for images. The RESIZE value can be the
618 symbol fit-height which fits the image to the window height. The
619 symbol fit-width fits the image to the window width. A number
620 indicates a scaling factor. nil indicates scale to 100%. "
621 (setq image-transform-resize resize
)
622 (if (eq 'image-mode major-mode
) (image-toggle-display-image)))
624 (defun image-transform-set-rotation (rotation)
625 "Set the image ROTATION angle. "
626 (interactive "nrotation:")
627 ;;TODO 0 90 180 270 degrees are the only reasonable angles here
628 ;;otherwise combining with rescaling will get very awkward
629 (setq image-transform-rotation
(float rotation
))
630 (if (eq major-mode
'image-mode
) (image-toggle-display-image)))
632 (provide 'image-mode
)
634 ;;; image-mode.el ends here