Download
(defvar viewer-version "$Id: viewer.el,v 1.13 2013/03/14 23:37:05 rubikitch Exp $")
(require 'view)
(eval-when-compile (require 'cl))
(defun define-overriding-view-mode-map-internal (mode-name key-bindings)
(let ((mapsym (intern (concat (symbol-name mode-name) "-view-map")))
(view-mode-sym (intern (concat (symbol-name mode-name) "-view-mode"))))
(eval `(defvar ,mapsym nil))
(let ((map (make-sparse-keymap)))
(loop for (key . command) in key-bindings
do (define-key map (read-kbd-macro key) command))
(set mapsym map)
(setq minor-mode-map-alist
(cons (cons view-mode-sym map)
(delete (assq view-mode-sym minor-mode-map-alist) minor-mode-map-alist)))
nil)))
(defmacro define-overriding-view-mode-map (mode-name &rest key-bindings)
"Define major-mode specific view-mode keymap.
Note that the car of an element of KEY-BINDINGS is `kbd' notation.
For example, to define `view-mode' keys for `emacs-lisp-mode':
(define-overriding-view-mode-map emacs-lisp-mode
(\"C-m\" . find-function)
(\"C-j\" . find-variable))
"
`(define-overriding-view-mode-map-internal ',mode-name ',key-bindings))
(defun viewer-install-extension ()
(when view-mode
(set (make-local-variable (intern (concat (symbol-name major-mode) "-view-mode")))
t)))
(add-hook 'view-mode-hook 'viewer-install-extension)
(defun viewer-uninstall-extension ()
(kill-local-variable (intern (concat (symbol-name major-mode) "-view-mode"))))
(defadvice view-mode-disable (before viewer activate)
(viewer-uninstall-extension))
(defcustom view-mode-by-default-regexp nil
"*Regexp of file name to open by `view-mode'."
:type 'string
:group 'viewer)
(defun view-mode-by-default-setup ()
(when (and buffer-file-name view-mode-by-default-regexp
(string-match view-mode-by-default-regexp buffer-file-name))
(view-mode 1)
(message "view-mode by view-mode-by-default-regexp.")))
(add-hook 'find-file-hook 'view-mode-by-default-setup)
(defgroup viewer nil
"View-mode extensions"
:group 'view)
(defcustom viewer-aggressive-minimum-size 100
"*Minimum file size to enable aggressive view-mode."
:type 'integer
:group 'viewer)
(defcustom viewer-aggressive-writable t
"*When non-nil, aggressive view-mode buffer is writable."
:type 'boolean
:group 'viewer)
(defadvice find-file-noselect (after switch-to-view-file)
(when (bufferp ad-return-value)
(with-current-buffer ad-return-value
(aggressive-view-mode))))
(defun aggressive-view-mode ()
(when (and buffer-file-name
(> (buffer-size) viewer-aggressive-minimum-size)
(file-regular-p buffer-file-name))
(view-mode 1)
(setq buffer-read-only (not (file-writable-p buffer-file-name)))))
(defun viewer-aggressive-setup (arg)
"Setup aggressive `view-mode'.
When ARG is t, all new files are opened by `view-mode'.
When ARG is 'force, enable `view-mode' even if file buffer is selected.
When ARG is nil, uninstall it."
(case arg
('force
(remove-hook 'find-file-hook 'aggressive-view-mode)
(ad-enable-advice 'find-file-noselect 'after 'switch-to-view-file)
(ad-update 'find-file-noselect))
(nil
(remove-hook 'find-file-hook 'aggressive-view-mode)
(ad-disable-advice 'find-file-noselect 'after 'switch-to-view-file)
(ad-update 'find-file-noselect))
(t
(add-hook 'find-file-hook 'aggressive-view-mode)
(ad-disable-advice 'find-file-noselect 'after 'switch-to-view-file)
(ad-update 'find-file-noselect))))
(defvar view-mode-force-exit nil)
(defmacro viewer-stay-in-unless-writable-advice (f)
`(defadvice ,f (around viewer-stay-in-unless-writable activate)
(if (or view-mode-force-exit
(and (boundp 'edebug-active) edebug-active)
(not (and view-mode
(buffer-file-name)
(not (file-writable-p (buffer-file-name))))))
ad-do-it
(message "File is unwritable, so stay in view-mode."))))
(defun view-mode-force-exit ()
(interactive)
(let ((view-mode-force-exit t)) (view-mode-exit)))
(defun viewer-stay-in-setup ()
"Setup stay-in view-mode.
Stay in `view-mode' when the file is unwritable."
(viewer-stay-in-unless-writable-advice view-mode)
(viewer-stay-in-unless-writable-advice view-mode-exit)
(viewer-stay-in-unless-writable-advice view-mode-disable))
(defvar viewer-modeline-color-default (face-background 'mode-line))
(defcustom viewer-modeline-color-unwritable "tomato"
"*Modeline color when file is not writable."
:type 'string
:group 'viewer)
(defcustom viewer-modeline-color-view "orange"
"*Modeline color for `view-mode'."
:type 'string
:group 'viewer)
(defun viewer-change-modeline-color ()
(interactive)
(when (eq (selected-window)
(get-buffer-window (current-buffer)))
(set-face-background
'mode-line
(cond ((and buffer-file-name view-mode
(not (file-writable-p buffer-file-name)))
viewer-modeline-color-unwritable)
(view-mode
viewer-modeline-color-view)
(t
viewer-modeline-color-default)))
(force-mode-line-update)))
(defmacro viewer-change-modeline-color-advice (f)
`(defadvice ,f (after change-mode-line-color activate)
(viewer-change-modeline-color)))
(defun viewer-change-modeline-color-setup ()
"Setup coloring modeline.
See also `viewer-modeline-color-unwritable' and `viewer-modeline-color-view'."
(add-hook 'window-configuration-change-hook 'viewer-change-modeline-color)
(viewer-change-modeline-color-advice toggle-read-only)
(viewer-change-modeline-color-advice view-mode-enable)
(viewer-change-modeline-color-advice view-mode-disable)
(viewer-change-modeline-color-advice other-window)
(defadvice select-window (around change-modeline-color activate)
(let ((curwin (selected-window))
(destwin (ad-get-arg 0)))
ad-do-it
(unless (or (called-interactively-p 'any) (eq curwin destwin))
(viewer-change-modeline-color))))
(viewer-change-modeline-color-advice select-frame)
nil)
(defvar viewer-maintainer-mail-address
(concat "rubiki" "tch@ru" "by-lang.org"))
(defvar viewer-bug-report-salutation
"Describe bug below, using a precise recipe.
When I executed M-x ...
How to send a bug report:
1) Be sure to use the LATEST version of viewer.el.
2) Enable debugger. M-x toggle-debug-on-error or (setq debug-on-error t)
3) Use Lisp version instead of compiled one: (load \"viewer.el\")
4) If you got an error, please paste *Backtrace* buffer.
5) Type C-c C-c to send.
# If you are a Japanese, please write in Japanese:-)")
(defun viewer-send-bug-report ()
(interactive)
(reporter-submit-bug-report
viewer-maintainer-mail-address
"viewer.el"
(apropos-internal "^view" 'boundp)
nil nil
viewer-bug-report-salutation))
(provide 'viewer)