(U+4E9B): Apply new conventions for glyph granularity.
[chise/xemacs-chise.git] / lisp / view-less.el
1 ;;; view-less.el --- Minor mode for browsing files with keybindings like `less'
2
3 ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
4
5 ;; Author: Jonathan Stigelman <stig@hackvan.com>
6 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: wp, unix
8
9 ;; This file is part of XEmacs.
10 ;;
11 ;; XEmacs 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 2 of the License, or
14 ;; (at your option) any later version.
15 ;;
16 ;; XEmacs 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.
20 ;;
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with XEmacs; if not, write to the Free Software
23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
24
25 ;;; Synched up with: Not in FSF.
26
27 ;;; Commentary:
28
29 ;; This mode is for browsing files without changing them.  Keybindings
30 ;; similar to those used by the less(1) program are used.
31 ;;
32 ;; Originally written for v18 by David Gudeman (gudeman@arizona.edu)
33 ;; Mods by Bengt Martensson, to closely resemble less (July 1987)
34 ;;
35 ;; If you would like all write-protected files to be visited in view-mode,
36 ;; then add the following to your .emacs file:
37 ;;
38 ;;      (add-hook 'find-file-hooks 'auto-view-mode)
39
40 ;;; Code:
41
42 (defvar view-search-string ""
43   "Last string searched for with view-search functions.")
44
45 (defvar view-search-arg 1
46   "Argument to last view search.")
47
48 (defvar view-default-lines 10
49   "Default value for the \"d\" and \"u\" commands in view-mode")
50
51 (defvar view-minor-mode nil
52   "Non-nil when view-mode is active.  Call `view-mode' to toggle.")
53 (make-variable-buffer-local 'view-minor-mode)
54
55 ;;;###autoload
56 (defvar view-minor-mode-map
57   (let ((map (make-keymap)))
58     (set-keymap-name map 'view-minor-mode-map)
59     (suppress-keymap map)
60     (define-key map "-" 'negative-argument)
61     (define-key map " " 'scroll-up)
62     (define-key map "f" 'scroll-up)
63     (define-key map "b" 'scroll-down)
64     (define-key map 'backspace 'scroll-down)
65     (define-key map 'delete 'scroll-down)
66     (define-key map "\r" 'view-scroll-lines-up)
67     (define-key map "\n" 'view-scroll-lines-up)
68     (define-key map "e" 'view-scroll-lines-up)
69     (define-key map "j" 'view-scroll-lines-up)
70     (define-key map "y" 'view-scroll-lines-down)
71     (define-key map "k" 'view-scroll-lines-down)
72     (define-key map "d" 'view-scroll-some-lines-up)
73     (define-key map "u" 'view-scroll-some-lines-down)
74     (define-key map "r" 'recenter)
75     (define-key map "t" 'toggle-truncate-lines)
76     (define-key map "N" 'view-buffer)
77     (define-key map "E" 'view-file)
78     (define-key map "P" 'view-buffer)
79     (define-key map "!" 'shell-command)
80     (define-key map "|" 'shell-command-on-region)
81     (define-key map "=" 'what-line)
82     (define-key map "?" 'view-search-backward)
83     (define-key map "h" 'view-mode-describe)
84     (define-key map "s" 'view-repeat-search)
85     (define-key map "n" 'view-repeat-search)
86     (define-key map "/" 'view-search-forward)
87     (define-key map "\\" 'view-search-backward)
88     (define-key map "g" 'view-goto-line)
89     (define-key map "G" 'view-last-windowful)
90     (define-key map "%" 'view-goto-percent)
91     (define-key map "p" 'view-goto-percent)
92     (define-key map "m" 'point-to-register)
93     (define-key map "'" 'register-to-point)
94     (define-key map "C" 'view-cleanup-backspaces)
95     (define-key map "\C-c\C-c" 'view-quit)
96     ;; #### - should this use substitute-command-keys?
97     (define-key map "\C-x\C-q" 'view-quit-toggle-ro)
98     (define-key map "q" 'view-quit)
99     map
100     ))
101
102 (add-minor-mode 'view-minor-mode " View" view-minor-mode-map)
103
104 ;;;###autoload
105 (defvar view-mode-map
106   (let ((map (copy-keymap view-minor-mode-map)))
107     (set-keymap-name map 'view-mode-map)
108     map))
109
110 ;;;###autoload
111 (defun view-file (filename &optional other-window-p)
112   "Find FILENAME, enter view mode.  With prefix arg OTHER-WINDOW-P, use other window."
113   (interactive "fView File: \nP")
114   (let ((old-p (get-file-buffer filename))
115         (obuf (current-buffer)))
116     (if other-window-p
117         (find-file-other-window filename)
118       (find-file filename))
119     (view-mode (if other-window-p nil obuf)
120                (if old-p nil 'kill-buffer))
121     nil))
122
123 ;;;###autoload
124 (defun view-buffer (buffer &optional other-window-p)
125   "Switch to BUFFER, enter view mode.  With prefix arg use other window."
126   (interactive "bView Buffer: \nP")
127   (let ((obuf (current-buffer)))
128     (if other-window-p
129         (switch-to-buffer-other-window buffer)
130       (switch-to-buffer buffer))
131     (view-mode (if other-window-p nil obuf)
132                (if other-window-p nil 'bury-buffer))))
133
134 ;;;###autoload
135 (defun view-file-other-window (filename)
136   "Find FILENAME in other window, and enter view mode."
137   (interactive "fView File: ")
138   (view-file filename t))
139
140 ;;;###autoload
141 (defun view-buffer-other-window (buffer)
142   "Switch to BUFFER in another window, and enter view mode."
143   (interactive "bView Buffer: ")
144   (view-buffer buffer t))
145
146 (defun view-brief-help ()
147   (message
148    (substitute-command-keys
149     "\\<view-minor-mode-map>\\[scroll-up] = page forward; \\[scroll-down] = page back; \
150 \\[view-mode-describe] = help; \\[view-quit] = quit.")))
151
152 (defvar view-major-mode)
153 (defvar view-exit-position)
154 (defvar view-prev-buffer)
155 (defvar view-exit-action)
156 (defvar view-old-buffer-read-only)
157
158 ;;;###autoload
159 (defun view-minor-mode (&optional prev-buffer exit-action)
160   "Minor mode for viewing text, with bindings like `less'.
161 Commands are:
162 \\<view-minor-mode-map>
163 0..9    prefix args
164 -       prefix minus
165 \\[scroll-up]   page forward
166 \\[scroll-down] page back
167 \\[view-scroll-lines-up]        scroll prefix-arg lines forward, default 1.
168 \\[view-scroll-lines-down]      scroll prefix-arg lines backward, default 1.
169 \\[view-scroll-some-lines-down] scroll prefix-arg lines backward, default 10.
170 \\[view-scroll-some-lines-up]   scroll prefix-arg lines forward, default 10.
171 \\[what-line]   print line number
172 \\[view-mode-describe]  print this help message
173 \\[view-search-forward] regexp search, uses previous string if you just hit RET
174 \\[view-search-backward]        as above but searches backward
175 \\[view-repeat-search]  repeat last search
176 \\[view-goto-line]      goto line prefix-arg, default 1
177 \\[view-last-windowful] goto line prefix-arg, default last line
178 \\[view-goto-percent]   goto a position by percentage
179 \\[toggle-truncate-lines]       toggle truncate-lines
180 \\[view-file]   view another file
181 \\[view-buffer] view another buffer
182 \\[view-cleanup-backspaces]     cleanup backspace constructions
183 \\[shell-command]       execute a shell command
184 \\[shell-command-on-region]\
185         execute a shell command with the region as input
186 \\[view-quit]   exit view-mode, and bury the current buffer.
187
188 If invoked with the optional (prefix) arg non-nil, view-mode cleans up
189 backspace constructions.
190
191 More precisely:
192 \\{view-minor-mode-map}"
193   (interactive)
194
195   (make-local-variable 'view-default-lines)
196   (set (make-local-variable 'view-exit-position)      (point))
197   (set (make-local-variable 'view-prev-buffer)   prev-buffer)
198   (set (make-local-variable 'view-exit-action)   exit-action)
199   (set (make-local-variable 'view-old-buffer-read-only)     buffer-read-only)
200   (add-hook (make-local-variable 'change-major-mode-hook)
201             'view-fixup-read-only)
202   (setq view-minor-mode  t
203         buffer-read-only t)
204   (view-brief-help))
205
206 ;;;###autoload
207 (defun view-mode (&optional prev-buffer exit-action clean-bs)
208   "View the current buffer using view-minor-mode.  This exists to be 99.9%
209 compatible with the implementations of `view-mode' in view.el and older
210 versions of view-less.el."
211   (interactive (list nil 'bury-buffer current-prefix-arg))
212   ;; #### - The first two arguments provide compatibility with view.el (and
213   ;; thus FSFmacs), while the third argument as a prefix argument maintains
214   ;; interactive compatibility with older versions of view-less.  --Stig
215   (if clean-bs (cleanup-backspaces))
216   (view-minor-mode prev-buffer exit-action))
217
218 ;;;###autoload
219 (defun view-major-mode (&optional prev-buffer exit-action clean-bs)
220   "View the current buffer using view-mode, as a major mode.
221 This function has a nonstandard name because `view-mode' is wrongly
222 named but is like this for compatibility reasons."
223   ;; #### - The first two arguments provide compatibility with view.el (and
224   ;; thus FSFmacs), while the third argument as a prefix argument maintains
225   ;; interactive compatibility with older versions of view-less.  --Stig
226   (interactive (list nil 'bury-buffer current-prefix-arg))
227   (kill-all-local-variables)
228   (use-local-map view-mode-map)
229   (setq major-mode 'view-mode)
230   (set (make-local-variable 'view-exit-position)      (point))
231   (set (make-local-variable 'view-prev-buffer)   prev-buffer)
232   (set (make-local-variable 'view-exit-action)   exit-action)
233   (set (make-local-variable 'view-old-buffer-read-only)     buffer-read-only)
234   (set (make-local-variable 'view-major-mode) t)
235   (setq buffer-read-only t)
236   (if clean-bs (cleanup-backspaces))
237   (run-hooks 'view-mode-hook))
238
239 ;;;###autoload
240 (defun auto-view-mode ()
241   "If the file of the current buffer is not writable, call view-mode.
242 This is meant to be added to `find-file-hooks'."
243   (or (file-writable-p buffer-file-name)
244       (view-minor-mode)))
245
246 (defun view-fixup-read-only ()
247   ;; doing M-x normal mode should NOT leave the buffer read-only
248   (and (boundp 'view-old-buffer-read-only)
249        (progn (setq buffer-read-only view-old-buffer-read-only)
250               (kill-local-variable 'view-old-buffer-read-only))))
251
252 (defun view-quit-toggle-ro ()
253   "Exit view mode and execute the global binding of the key that invoked this
254 command.  Normally, this will toggle the state of `buffer-read-only', perhaps
255 invoking some version-control mechanism."
256   (interactive)
257   (setq view-exit-position nil)
258   ;; Kludge so this works as advertised.  Stig, why can't you write
259   ;; bug-free code???
260   (let ((buffer-read-only buffer-read-only))
261     (view-quit t))
262   ;; no longer in view-minor-mode, so the keymap has changed...
263   (call-interactively (key-binding (this-command-keys))))
264
265 (defun view-quit (&optional no-exit-action)
266   "Exit view mode.  With prefix argument, keep the current buffer selected."
267   (interactive "P")
268   (view-fixup-read-only)
269   (setq view-minor-mode nil)
270   (if view-exit-position (goto-char view-exit-position))
271   (if (and (boundp 'view-major-mode) view-major-mode)
272       (fundamental-mode)
273     (let ((pbuf view-prev-buffer)
274           (exitact view-exit-action))
275       (if no-exit-action
276           nil
277         (if exitact (funcall exitact (current-buffer)))
278         (if pbuf (switch-to-buffer pbuf))))))
279
280 ;; #### - similar to what's in man.el and this ought to be written in C anyway...  --Stig
281 (defun cleanup-backspaces ()
282   "Cleanup backspace constructions.
283 _^H and ^H_ sequences are deleted.  x^Hx sequences are turned into x for all
284 characters x.  ^^H| and |^H^ sequences are turned into ^.  +^Ho and o^H+ are
285 turned into (+)."
286   (interactive)
287   (save-excursion
288     (goto-char (point-min))
289     (while (= (following-char) ?\C-h)
290       (delete-char 1))
291     (while (search-forward "\C-h" nil t)
292       (backward-char 2)
293       (cond ((looking-at "_\C-h\\|\\(.\\)\C-h\\1\\||\C-h\\^")
294              (delete-char 2))
295             ((looking-at ".\C-h_\\|\\^\C-h|")
296              (forward-char 1)
297              (delete-char 2))
298             ((looking-at "+\C-ho\\|o\C-h+")
299              (delete-char 3)
300              (insert "(+)"))
301             ((looking-at "|\C-h-")
302              (delete-char 3)
303              (insert "*"))
304             (t (forward-char 2))))))
305
306 (defun view-cleanup-backspaces ()
307   "Cleanup backspaces and if buffer is currently unmodified, don't flag it
308 as a modified buffer.  This works even if the buffer is read-only."
309   (interactive)
310   (let ((buffer-read-only)
311         (buf-mod (buffer-modified-p)))
312     (cleanup-backspaces)
313     ;; #### - THIS IS PROBABLY A REALLY DANGEROUS THING TO DO IN A MINOR MODE!!
314     (set-buffer-modified-p buf-mod)))
315
316 ;;;###autoload
317 (defun toggle-truncate-lines (&optional p)
318   "Toggles the values of truncate-lines.
319 Positive prefix arg sets, negative disables."
320   (interactive "P")
321   (setq truncate-lines (if p
322                            (> (prefix-numeric-value p) 0)
323                          (not truncate-lines)))
324   (recenter))
325
326 (defun view-scroll-lines-up (p)
327   "Scroll up prefix-arg lines, default 1."
328   (interactive "p")
329   (scroll-up p))
330
331 (defun view-scroll-lines-down (p)
332   "Scroll down prefix-arg lines, default 1."
333   (interactive "p")
334   (scroll-up (- p)))
335
336 (defun view-scroll-some-lines-down (&optional n)
337   "Scroll down prefix-arg lines, default 10, or last argument."
338   (interactive "p")
339   (if (> n 1) (setq view-default-lines n))
340   (scroll-down view-default-lines))
341
342 (defun view-scroll-some-lines-up (&optional n)
343   "Scroll up prefix-arg lines, default 10, or last argument."
344   (interactive "p")
345   (if (> n 1) (setq view-default-lines n))
346   (scroll-up view-default-lines))
347
348 (defun view-goto-line (&optional n)
349   "Goto prefix arg line N.  N = 1 by default.."
350   (interactive "p")
351   (goto-line n))
352
353 (defun view-last-windowful (&optional n)
354   "Goto prefix arg line N or the first line of the last windowful in buffer."
355   (interactive "p")
356   (if current-prefix-arg
357       (goto-line n)
358     (end-of-buffer)
359     (recenter -1)
360     (move-to-window-line 0)))
361
362 (defun view-goto-percent (&optional percent)
363   "Set mark and go to a position PERCENT way into the current buffer."
364   (interactive "p")
365   (set-mark-command nil)
366   (goto-char (+ (point-min) (/ (* percent (- (point-max) (point-min))) 100)))
367   (beginning-of-line))
368
369 (defun view-mode-describe ()
370   (interactive)
371   (let ((mode-name "View")
372         (major-mode 'view-mode))
373     (describe-mode)))
374
375 (defun view-search-forward (s p)
376   "Search forward for REGEXP.  If regexp is empty, use last search string.
377 With prefix ARG, search forward that many occurrences."
378   (interactive "sView search: \np")
379   (unwind-protect
380       (re-search-forward
381        (if (string-equal "" s) view-search-string s) nil nil p)
382     (setq view-search-arg p)
383     (or (string-equal "" s)
384         (setq view-search-string s))))
385
386 (defun view-search-backward (s p)
387   "Search backward for REGEXP.  If regexp is empty, use last search string.
388 With prefix ARG, search forward that many occurrences."
389   (interactive "sView search backward: \np")
390   (view-search-forward s (- p)))
391
392 (defun view-repeat-search (p)
393   "Repeat last view search command.  If a prefix arg is given, use that
394 instead of the previous arg, if the prefix is just a -, then take the
395 negative of the last prefix arg."
396   (interactive "P")
397   (view-search-forward
398    view-search-string
399    (cond ((null p) view-search-arg)
400          ((eq p '-) (- view-search-arg))
401          (t (prefix-numeric-value p)))))
402
403 (provide 'view)
404 (provide 'view-less)
405
406 ;;; view-less.el ends here