lisp/image-mode.el

   1 ;;; image-mode.el --- support for visiting image files
   2 ;;
   3 ;; Copyright (C) 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Richard Stallman <rms@gnu.org>
   6 ;; Keywords: multimedia
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Defines a major mode for visiting image files
  28 ;; that allows conversion between viewing the text of the file
  29 ;; and viewing the file as an image.  Viewing the image
  30 ;; works by putting a `display' text-property on the
  31 ;; image data, with the image-data still present underneath; if the
  32 ;; resulting buffer file is saved to another name it will correctly save
  33 ;; the image data to the new file.
  34
  35 ;;; Code:
  36
  37 (require 'image)
  38
  39 ;;;###autoload (push '("\\.jpe?g\\'"    . image-mode) auto-mode-alist)
  40 ;;;###autoload (push '("\\.png\\'"      . image-mode) auto-mode-alist)
  41 ;;;###autoload (push '("\\.gif\\'"      . image-mode) auto-mode-alist)
  42 ;;;###autoload (push '("\\.tiff?\\'"    . image-mode) auto-mode-alist)
  43 ;;;###autoload (push '("\\.p[bpgn]m\\'" . image-mode) auto-mode-alist)
  44
  45 ;;;###autoload (push '("\\.x[bp]m\\'"   . c-mode)     auto-mode-alist)
  46 ;;;###autoload (push '("\\.x[bp]m\\'"   . image-mode-maybe) auto-mode-alist)
  47
  48 ;;;###autoload (push '("\\.svgz?\\'"    . xml-mode)   auto-mode-alist)
  49 ;;;###autoload (push '("\\.svgz?\\'"    . image-mode-maybe) auto-mode-alist)
  50
  51 ;;; Image scrolling functions
  52
  53 (defvar image-mode-current-vscroll nil
  54   "An alist with elements (WINDOW . VSCROLL).")
  55
  56 (defvar image-mode-current-hscroll nil
  57   "An alist with elements (WINDOW . HSCROLL).")
  58
  59 (defun image-set-window-vscroll (window vscroll &optional pixels-p)
  60   (setq image-mode-current-vscroll
  61         (append (list (cons window vscroll))
  62                 (delete (assoc window image-mode-current-vscroll)
  63                         image-mode-current-vscroll)))
  64   (set-window-vscroll window vscroll pixels-p))
  65
  66 (defun image-set-window-hscroll (window ncol)
  67   (setq image-mode-current-hscroll
  68         (append (list (cons window ncol))
  69                 (delete (assoc window image-mode-current-hscroll)
  70                         image-mode-current-hscroll)))
  71   (set-window-hscroll window ncol))
  72
  73 (defun image-reset-current-vhscroll ()
  74   (let ((win (selected-window)))
  75     (when (assoc win image-mode-current-hscroll)
  76       (set-window-hscroll win (cdr (assoc win image-mode-current-hscroll))))
  77     (when (assoc win image-mode-current-vscroll)
  78       (set-window-vscroll win (cdr (assoc win image-mode-current-vscroll))))))
  79
  80 (defun image-forward-hscroll (&optional n)
  81   "Scroll image in current window to the left by N character widths.
  82 Stop if the right edge of the image is reached."
  83   (interactive "p")
  84   (cond ((= n 0) nil)
  85         ((< n 0)
  86          (image-set-window-hscroll (selected-window)
  87                                    (max 0 (+ (window-hscroll) n))))
  88         (t
  89          (let* ((image (get-char-property (point-min) 'display))
  90                 (edges (window-inside-edges))
  91                 (win-width (- (nth 2 edges) (nth 0 edges)))
  92                 (img-width (ceiling (car (image-size image)))))
  93            (image-set-window-hscroll (selected-window)
  94                                      (min (max 0 (- img-width win-width))
  95                                           (+ n (window-hscroll))))))))
  96
  97 (defun image-backward-hscroll (&optional n)
  98   "Scroll image in current window to the right by N character widths.
  99 Stop if the left edge of the image is reached."
 100   (interactive "p")
 101   (image-forward-hscroll (- n)))
 102
 103 (defun image-next-line (&optional n)
 104   "Scroll image in current window upward by N lines.
 105 Stop if the bottom edge of the image is reached."
 106   (interactive "p")
 107   (cond ((= n 0) nil)
 108         ((< n 0)
 109          (image-set-window-vscroll (selected-window)
 110                                    (max 0 (+ (window-vscroll) n))))
 111         (t
 112          (let* ((image (get-char-property (point-min) 'display))
 113                 (edges (window-inside-edges))
 114                 (win-height (- (nth 3 edges) (nth 1 edges)))
 115                 (img-height (ceiling (cdr (image-size image)))))
 116            (image-set-window-vscroll (selected-window)
 117                                      (min (max 0 (- img-height win-height))
 118                                           (+ n (window-vscroll))))))))
 119
 120 (defun image-previous-line (&optional n)
 121   "Scroll image in current window downward by N lines.
 122 Stop if the top edge of the image is reached."
 123   (interactive "p")
 124   (image-next-line (- n)))
 125
 126 (defun image-scroll-up (&optional n)
 127   "Scroll image in current window upward by N lines.
 128 Stop if the bottom edge of the image is reached.
 129 If ARG is omitted or nil, scroll upward by a near full screen.
 130 A near full screen is `next-screen-context-lines' less than a full screen.
 131 Negative ARG means scroll downward.
 132 If ARG is the atom `-', scroll downward by nearly full screen.
 133 When calling from a program, supply as argument a number, nil, or `-'."
 134   (interactive "P")
 135   (cond ((null n)
 136          (let* ((edges (window-inside-edges))
 137                 (win-height (- (nth 3 edges) (nth 1 edges))))
 138            (image-next-line
 139             (max 0 (- win-height next-screen-context-lines)))))
 140         ((eq n '-)
 141          (let* ((edges (window-inside-edges))
 142                 (win-height (- (nth 3 edges) (nth 1 edges))))
 143            (image-next-line
 144             (min 0 (- next-screen-context-lines win-height)))))
 145         (t (image-next-line (prefix-numeric-value n)))))
 146
 147 (defun image-scroll-down (&optional n)
 148   "Scroll image in current window downward by N lines
 149 Stop if the top edge of the image is reached.
 150 If ARG is omitted or nil, scroll downward by a near full screen.
 151 A near full screen is `next-screen-context-lines' less than a full screen.
 152 Negative ARG means scroll upward.
 153 If ARG is the atom `-', scroll upward by nearly full screen.
 154 When calling from a program, supply as argument a number, nil, or `-'."
 155   (interactive "P")
 156   (cond ((null n)
 157          (let* ((edges (window-inside-edges))
 158                 (win-height (- (nth 3 edges) (nth 1 edges))))
 159            (image-next-line
 160             (min 0 (- next-screen-context-lines win-height)))))
 161         ((eq n '-)
 162          (let* ((edges (window-inside-edges))
 163                 (win-height (- (nth 3 edges) (nth 1 edges))))
 164            (image-next-line
 165             (max 0 (- win-height next-screen-context-lines)))))
 166         (t (image-next-line (- (prefix-numeric-value n))))))
 167
 168 (defun image-bol (arg)
 169   "Scroll horizontally to the left edge of the image in the current window.
 170 With argument ARG not nil or 1, move forward ARG - 1 lines first,
 171 stopping if the top or bottom edge of the image is reached."
 172   (interactive "p")
 173   (and arg
 174        (/= (setq arg (prefix-numeric-value arg)) 1)
 175        (image-next-line (- arg 1)))
 176   (image-set-window-hscroll (selected-window) 0))
 177
 178 (defun image-eol (arg)
 179   "Scroll horizontally to the right edge of the image in the current window.
 180 With argument ARG not nil or 1, move forward ARG - 1 lines first,
 181 stopping if the top or bottom edge of the image is reached."
 182   (interactive "p")
 183   (and arg
 184        (/= (setq arg (prefix-numeric-value arg)) 1)
 185        (image-next-line (- arg 1)))
 186   (let* ((image (get-char-property (point-min) 'display))
 187          (edges (window-inside-edges))
 188          (win-width (- (nth 2 edges) (nth 0 edges)))
 189          (img-width (ceiling (car (image-size image)))))
 190     (image-set-window-hscroll (selected-window)
 191                               (max 0 (- img-width win-width)))))
 192
 193 (defun image-bob ()
 194   "Scroll to the top-left corner of the image in the current window."
 195   (interactive)
 196   (image-set-window-hscroll (selected-window) 0)
 197   (image-set-window-vscroll (selected-window) 0))
 198
 199 (defun image-eob ()
 200   "Scroll to the bottom-right corner of the image in the current window."
 201   (interactive)
 202   (let* ((image (get-char-property (point-min) 'display))
 203          (edges (window-inside-edges))
 204          (win-width (- (nth 2 edges) (nth 0 edges)))
 205          (img-width (ceiling (car (image-size image))))
 206          (win-height (- (nth 3 edges) (nth 1 edges)))
 207          (img-height (ceiling (cdr (image-size image)))))
 208     (image-set-window-hscroll (selected-window) (max 0 (- img-width win-width)))
 209     (image-set-window-vscroll (selected-window) (max 0 (- img-height win-height)))))
 210
 211 ;;; Image Mode setup
 212
 213 (defvar image-type nil
 214   "Current image type.
 215 This variable is used to display the current image type in the mode line.")
 216 (make-variable-buffer-local 'image-type)
 217
 218 (defvar image-mode-map
 219   (let ((map (make-sparse-keymap)))
 220     (define-key map "\C-c\C-c" 'image-toggle-display)
 221     (define-key map [remap forward-char] 'image-forward-hscroll)
 222     (define-key map [remap backward-char] 'image-backward-hscroll)
 223     (define-key map [remap previous-line] 'image-previous-line)
 224     (define-key map [remap next-line] 'image-next-line)
 225     (define-key map [remap scroll-up] 'image-scroll-up)
 226     (define-key map [remap scroll-down] 'image-scroll-down)
 227     (define-key map [remap move-beginning-of-line] 'image-bol)
 228     (define-key map [remap move-end-of-line] 'image-eol)
 229     (define-key map [remap beginning-of-buffer] 'image-bob)
 230     (define-key map [remap end-of-buffer] 'image-eob)
 231     map)
 232   "Major mode keymap for viewing images in Image mode.")
 233
 234 (defvar image-mode-text-map
 235   (let ((map (make-sparse-keymap)))
 236     (define-key map "\C-c\C-c" 'image-toggle-display)
 237     map)
 238   "Major mode keymap for viewing images as text in Image mode.")
 239
 240 (defvar bookmark-make-cell-function)
 241
 242 ;;;###autoload
 243 (defun image-mode ()
 244   "Major mode for image files.
 245 You can use \\<image-mode-map>\\[image-toggle-display]
 246 to toggle between display as an image and display as text."
 247   (interactive)
 248   (kill-all-local-variables)
 249   (setq mode-name "Image[text]")
 250   (setq major-mode 'image-mode)
 251   ;; Use our own bookmarking function for images.
 252   (set (make-local-variable 'bookmark-make-cell-function)
 253        'image-bookmark-make-cell)
 254
 255   ;; Keep track of [vh]scroll when switching buffers
 256   (make-local-variable 'image-mode-current-hscroll)
 257   (make-local-variable 'image-mode-current-vscroll)
 258   (image-set-window-hscroll (selected-window) (window-hscroll))
 259   (image-set-window-vscroll (selected-window) (window-vscroll))
 260   (add-hook 'window-configuration-change-hook
 261             'image-reset-current-vhscroll nil t)
 262
 263   (add-hook 'change-major-mode-hook 'image-toggle-display-text nil t)
 264   (if (and (display-images-p)
 265            (not (get-char-property (point-min) 'display)))
 266       (image-toggle-display)
 267     ;; Set next vars when image is already displayed but local
 268     ;; variables were cleared by kill-all-local-variables
 269     (use-local-map image-mode-map)
 270     (setq cursor-type nil truncate-lines t))
 271   (run-mode-hooks 'image-mode-hook)
 272   (if (display-images-p)
 273       (message "%s" (concat
 274                      (substitute-command-keys
 275                       "Type \\[image-toggle-display] to view as ")
 276                      (if (get-char-property (point-min) 'display)
 277                          "text" "an image") "."))))
 278
 279 ;;;###autoload
 280 (define-minor-mode image-minor-mode
 281   "Toggle Image minor mode.
 282 With arg, turn Image minor mode on if arg is positive, off otherwise.
 283 See the command `image-mode' for more information on this mode."
 284   nil (:eval (format " Image[%s]" image-type)) image-mode-text-map
 285   :group 'image
 286   :version "22.1"
 287   (if (not image-minor-mode)
 288       (image-toggle-display-text)
 289     (if (get-char-property (point-min) 'display)
 290         (setq cursor-type nil truncate-lines t)
 291       (setq image-type "text"))
 292     (add-hook 'change-major-mode-hook (lambda () (image-minor-mode -1)) nil t)
 293     (message "%s" (concat (substitute-command-keys
 294                            "Type \\[image-toggle-display] to view the image as ")
 295                           (if (get-char-property (point-min) 'display)
 296                               "text" "an image") "."))))
 297
 298 ;;;###autoload
 299 (defun image-mode-maybe ()
 300   "Set major or minor mode for image files.
 301 Set Image major mode only when there are no other major modes
 302 associated with a filename in `auto-mode-alist'.  When an image
 303 filename matches another major mode in `auto-mode-alist' then
 304 set that major mode and Image minor mode.
 305
 306 See commands `image-mode' and `image-minor-mode' for more
 307 information on these modes."
 308   (interactive)
 309   (let* ((mode-alist
 310           (delq nil (mapcar
 311                      (lambda (elt)
 312                        (unless (memq (or (car-safe (cdr elt)) (cdr elt))
 313                                      '(image-mode image-mode-maybe))
 314                          elt))
 315                      auto-mode-alist))))
 316     (if (assoc-default buffer-file-name mode-alist 'string-match)
 317         (let ((auto-mode-alist mode-alist)
 318               (magic-mode-alist nil))
 319           (set-auto-mode)
 320           (image-minor-mode t))
 321       (image-mode))))
 322
 323 (defun image-toggle-display-text ()
 324   "Showing the text of the image file."
 325   (if (get-char-property (point-min) 'display)
 326       (image-toggle-display)))
 327
 328 (defvar archive-superior-buffer)
 329 (defvar tar-superior-buffer)
 330
 331 (defun image-toggle-display ()
 332   "Start or stop displaying an image file as the actual image.
 333 This command toggles between showing the text of the image file
 334 and showing the image as an image."
 335   (interactive)
 336   (if (get-char-property (point-min) 'display)
 337       (let ((inhibit-read-only t)
 338             (buffer-undo-list t)
 339             (modified (buffer-modified-p)))
 340         (remove-list-of-text-properties (point-min) (point-max)
 341                                         '(display intangible read-nonsticky
 342                                                   read-only front-sticky))
 343         (set-buffer-modified-p modified)
 344         (kill-local-variable 'cursor-type)
 345         (kill-local-variable 'truncate-lines)
 346         (kill-local-variable 'auto-hscroll-mode)
 347         (use-local-map image-mode-text-map)
 348         (setq image-type "text")
 349         (if (eq major-mode 'image-mode)
 350             (setq mode-name "Image[text]"))
 351         (if (called-interactively-p)
 352             (message "Repeat this command to go back to displaying the image")))
 353     ;; Turn the image data into a real image, but only if the whole file
 354     ;; was inserted
 355     (let* ((filename (buffer-file-name))
 356            (data-p (not (and filename
 357                              (file-readable-p filename)
 358                              (not (file-remote-p filename))
 359                              (not (buffer-modified-p))
 360                              (not (and (boundp 'archive-superior-buffer)
 361                                        archive-superior-buffer))
 362                              (not (and (boundp 'tar-superior-buffer)
 363                                        tar-superior-buffer)))))
 364            (file-or-data (if data-p
 365                              (string-make-unibyte
 366                               (buffer-substring-no-properties (point-min) (point-max)))
 367                            filename))
 368            (type (image-type file-or-data nil data-p))
 369            (image (create-image file-or-data type data-p))
 370            (props
 371             `(display ,image
 372                       intangible ,image
 373                       rear-nonsticky (display intangible)
 374                       read-only t front-sticky (read-only)))
 375            (inhibit-read-only t)
 376            (buffer-undo-list t)
 377            (modified (buffer-modified-p)))
 378       (image-refresh image)
 379       (add-text-properties (point-min) (point-max) props)
 380       (set-buffer-modified-p modified)
 381       ;; Inhibit the cursor when the buffer contains only an image,
 382       ;; because cursors look very strange on top of images.
 383       (setq cursor-type nil)
 384       ;; This just makes the arrow displayed in the right fringe
 385       ;; area look correct when the image is wider than the window.
 386       (setq truncate-lines t)
 387       ;; Allow navigation of large images
 388       (set (make-local-variable 'auto-hscroll-mode) nil)
 389       (use-local-map image-mode-map)
 390       (setq image-type type)
 391       (if (eq major-mode 'image-mode)
 392           (setq mode-name (format "Image[%s]" type)))
 393       (if (called-interactively-p)
 394           (message "Repeat this command to go back to displaying the file as text")))))
 395
 396 ;;; Support for bookmark.el
 397
 398 (defun image-bookmark-make-cell (annotation &rest args)
 399   (let ((the-record
 400          `((filename   . ,(buffer-file-name))
 401            (image-type . ,image-type)
 402            (position   . ,(point))
 403            (handler    . image-bookmark-jump))))
 404
 405     ;; Take no chances with text properties
 406     (set-text-properties 0 (length annotation) nil annotation)
 407
 408     (when annotation
 409       (nconc the-record (list (cons 'annotation annotation))))
 410
 411     ;; Finally, return the completed record.
 412     the-record))
 413
 414 (declare-function bookmark-get-filename        "bookmark" (bookmark))
 415 (declare-function bookmark-get-bookmark-record "bookmark" (bookmark))
 416 (declare-function bookmark-get-position        "bookmark" (bookmark))
 417
 418 ;;;###autoload
 419 (defun image-bookmark-jump (bmk)
 420   ;; This implements the `handler' function interface for record type
 421   ;; returned by `bookmark-make-cell-function', which see.
 422   (save-window-excursion
 423     (let ((filename (bookmark-get-filename bmk))
 424           (type (cdr (assq 'image-type (bookmark-get-bookmark-record bmk))))
 425           (pos  (bookmark-get-position bmk)))
 426       (find-file filename)
 427       (when (not (string= image-type type))
 428         (image-toggle-display))
 429       (when (string= image-type "text")
 430         (goto-char pos))
 431       `((buffer ,(current-buffer)) (position ,(point))))))
 432
 433 (provide 'image-mode)
 434
 435 ;; arch-tag: b5b2b7e6-26a7-4b79-96e3-1546b5c4c6cb
 436 ;;; image-mode.el ends here